From f85232947e74ee7ef8c7b0ad2338212e7e68f1be Mon Sep 17 00:00:00 2001 From: krasimir Date: Sun, 13 Dec 2009 18:50:29 +0000 Subject: reorganize the directories under src, and rescue the JavaScript interpreter from deprecated --- src/Data/Binary.hs | 791 ---------- src/Data/Binary/Builder.hs | 426 ------ src/Data/Binary/Get.hs | 544 ------- src/Data/Binary/Put.hs | 216 --- src/FILES | 260 ---- src/GF.hs | 45 - src/GF/Command/Abstract.hs | 79 - src/GF/Command/Commands.hs | 931 ------------ src/GF/Command/Importing.hs | 50 - src/GF/Command/Interpreter.hs | 132 -- src/GF/Command/Messages.hs | 54 - src/GF/Command/Parse.hs | 64 - src/GF/Command/TreeOperations.hs | 32 - src/GF/Compile.hs | 252 --- src/GF/Compile/Abstract/Compute.hs | 138 -- src/GF/Compile/Abstract/TC.hs | 294 ---- src/GF/Compile/Abstract/TypeCheck.hs | 83 - src/GF/Compile/CheckGrammar.hs | 284 ---- src/GF/Compile/Coding.hs | 55 - src/GF/Compile/Concrete/AppPredefined.hs | 158 -- src/GF/Compile/Concrete/Compute.hs | 456 ------ src/GF/Compile/Concrete/TypeCheck.hs | 690 --------- src/GF/Compile/Export.hs | 64 - src/GF/Compile/GFCCtoHaskell.hs | 230 --- src/GF/Compile/GFCCtoJS.hs | 138 -- src/GF/Compile/GFCCtoProlog.hs | 279 ---- src/GF/Compile/GenerateFCFG.hs | 568 ------- src/GF/Compile/GeneratePMCFG.hs | 510 ------- src/GF/Compile/GeneratePMCFGOld.hs | 374 ----- src/GF/Compile/GetGrammar.hs | 52 - src/GF/Compile/GrammarToGFCC.hs | 587 ------- src/GF/Compile/ModDeps.hs | 145 -- src/GF/Compile/Optimize.hs | 228 --- src/GF/Compile/OptimizeGFCC.hs | 121 -- src/GF/Compile/PGFPretty.hs | 93 -- src/GF/Compile/ReadFiles.hs | 220 --- src/GF/Compile/Refresh.hs | 133 -- src/GF/Compile/Rename.hs | 313 ---- src/GF/Compile/SubExOpt.hs | 142 -- src/GF/Compile/Update.hs | 226 --- src/GF/Data/Assoc.hs | 143 -- src/GF/Data/BacktrackM.hs | 86 -- src/GF/Data/ErrM.hs | 38 - src/GF/Data/Graph.hs | 178 --- src/GF/Data/Graphviz.hs | 116 -- src/GF/Data/MultiMap.hs | 47 - src/GF/Data/Operations.hs | 374 ----- src/GF/Data/Relation.hs | 193 --- src/GF/Data/SortedList.hs | 127 -- src/GF/Data/Str.hs | 134 -- src/GF/Data/TrieMap.hs | 66 - src/GF/Data/Utilities.hs | 190 --- src/GF/Data/XML.hs | 58 - src/GF/Data/Zipper.hs | 257 ---- src/GF/Grammar.hs | 29 - src/GF/Grammar/Binary.hs | 261 ---- src/GF/Grammar/CF.hs | 128 -- src/GF/Grammar/Grammar.hs | 230 --- src/GF/Grammar/Lexer.hs | 478 ------ src/GF/Grammar/Lexer.x | 272 ---- src/GF/Grammar/Lockfield.hs | 52 - src/GF/Grammar/Lookup.hs | 188 --- src/GF/Grammar/MMacros.hs | 279 ---- src/GF/Grammar/Macros.hs | 627 -------- src/GF/Grammar/Parser.y | 739 --------- src/GF/Grammar/PatternMatch.hs | 165 -- src/GF/Grammar/Predef.hs | 180 --- src/GF/Grammar/Printer.hs | 317 ---- src/GF/Grammar/Unify.hs | 97 -- src/GF/Grammar/Values.hs | 96 -- src/GF/Infra/CheckM.hs | 77 - src/GF/Infra/CompactPrint.hs | 22 - src/GF/Infra/Dependencies.hs | 61 - src/GF/Infra/GetOpt.hs | 381 ----- src/GF/Infra/Ident.hs | 152 -- src/GF/Infra/Modules.hs | 349 ----- src/GF/Infra/Option.hs | 609 -------- src/GF/Infra/UseIO.hs | 186 --- src/GF/JavaScript/AbsJS.hs | 60 - src/GF/JavaScript/JS.cf | 55 - src/GF/JavaScript/LexJS.x | 132 -- src/GF/JavaScript/Makefile | 14 - src/GF/JavaScript/ParJS.y | 225 --- src/GF/JavaScript/PrintJS.hs | 169 -- src/GF/Quiz.hs | 98 -- src/GF/Speech/CFG.hs | 372 ----- src/GF/Speech/CFGToFA.hs | 244 --- src/GF/Speech/FiniteState.hs | 329 ---- src/GF/Speech/GSL.hs | 95 -- src/GF/Speech/JSGF.hs | 113 -- src/GF/Speech/PGFToCFG.hs | 116 -- src/GF/Speech/PrRegExp.hs | 27 - src/GF/Speech/RegExp.hs | 144 -- src/GF/Speech/SISR.hs | 77 - src/GF/Speech/SLF.hs | 178 --- src/GF/Speech/SRG.hs | 205 --- src/GF/Speech/SRGS_ABNF.hs | 127 -- src/GF/Speech/SRGS_XML.hs | 105 -- src/GF/Speech/VoiceXML.hs | 243 --- src/GF/System/NoReadline.hs | 33 - src/GF/System/NoSignal.hs | 29 - src/GF/System/Readline.hs | 35 - src/GF/System/Signal.hs | 27 - src/GF/System/UseEditline.hs | 36 - src/GF/System/UseHaskeline.hs | 43 - src/GF/System/UseReadline.hs | 36 - src/GF/System/UseSignal.hs | 72 - src/GF/Text/CP1250.hs | 77 - src/GF/Text/CP1251.hs | 74 - src/GF/Text/CP1252.hs | 6 - src/GF/Text/Coding.hs | 21 - src/GF/Text/Lexing.hs | 131 -- src/GF/Text/Transliterations.hs | 206 --- src/GF/Text/UTF8.hs | 48 - src/GFC.hs | 88 -- src/GFI.hs | 363 ----- src/HelpFile | 693 --------- src/Makefile | 250 --- src/Makefile.binary | 20 - src/PGF.hs | 352 ----- src/PGF/Binary.hs | 199 --- src/PGF/BuildParser.hs | 76 - src/PGF/CId.hs | 55 - src/PGF/Check.hs | 173 --- src/PGF/Data.hs | 95 -- src/PGF/Editor.hs | 241 --- src/PGF/Expr.hs | 355 ----- src/PGF/Expr.hs-boot | 28 - src/PGF/Generate.hs | 66 - src/PGF/Linearize.hs | 166 -- src/PGF/Macros.hs | 154 -- src/PGF/Morphology.hs | 26 - src/PGF/PMCFG.hs | 119 -- src/PGF/Paraphrase.hs | 112 -- src/PGF/Parsing/FCFG/Active.hs | 205 --- src/PGF/Parsing/FCFG/Incremental.hs | 371 ----- src/PGF/Parsing/FCFG/Utilities.hs | 188 --- src/PGF/ShowLinearize.hs | 113 -- src/PGF/Tree.hs | 71 - src/PGF/Type.hs | 103 -- src/PGF/TypeCheck.hs | 524 ------- src/PGF/VisualizeTree.hs | 353 ----- src/PGF/doc/Eng.gf | 13 - src/PGF/doc/Ex.gf | 8 - src/PGF/doc/Swe.gf | 13 - src/PGF/doc/Test.gf | 64 - src/PGF/doc/gfcc.html | 809 ---------- src/PGF/doc/gfcc.txt | 712 --------- src/PGF/doc/old-GFCC.cf | 50 - src/PGF/doc/old-gfcc.txt | 656 -------- src/PGF/doc/syntax.txt | 180 --- src/ReleaseProcedure | 153 -- src/compiler/GF.hs | 45 + src/compiler/GF/Command/Abstract.hs | 79 + src/compiler/GF/Command/Commands.hs | 931 ++++++++++++ src/compiler/GF/Command/Importing.hs | 50 + src/compiler/GF/Command/Interpreter.hs | 132 ++ src/compiler/GF/Command/Messages.hs | 54 + src/compiler/GF/Command/Parse.hs | 64 + src/compiler/GF/Command/TreeOperations.hs | 32 + src/compiler/GF/Compile.hs | 252 +++ src/compiler/GF/Compile/Abstract/Compute.hs | 138 ++ src/compiler/GF/Compile/Abstract/TC.hs | 294 ++++ src/compiler/GF/Compile/Abstract/TypeCheck.hs | 83 + src/compiler/GF/Compile/CheckGrammar.hs | 284 ++++ src/compiler/GF/Compile/Coding.hs | 55 + src/compiler/GF/Compile/Concrete/AppPredefined.hs | 158 ++ src/compiler/GF/Compile/Concrete/Compute.hs | 456 ++++++ src/compiler/GF/Compile/Concrete/TypeCheck.hs | 690 +++++++++ src/compiler/GF/Compile/Export.hs | 64 + src/compiler/GF/Compile/GFCCtoHaskell.hs | 230 +++ src/compiler/GF/Compile/GFCCtoJS.hs | 138 ++ src/compiler/GF/Compile/GFCCtoProlog.hs | 279 ++++ src/compiler/GF/Compile/GenerateFCFG.hs | 568 +++++++ src/compiler/GF/Compile/GeneratePMCFG.hs | 510 +++++++ src/compiler/GF/Compile/GeneratePMCFGOld.hs | 374 +++++ src/compiler/GF/Compile/GetGrammar.hs | 52 + src/compiler/GF/Compile/GrammarToGFCC.hs | 587 +++++++ src/compiler/GF/Compile/ModDeps.hs | 145 ++ src/compiler/GF/Compile/Optimize.hs | 228 +++ src/compiler/GF/Compile/OptimizeGFCC.hs | 121 ++ src/compiler/GF/Compile/PGFPretty.hs | 93 ++ src/compiler/GF/Compile/ReadFiles.hs | 220 +++ src/compiler/GF/Compile/Refresh.hs | 133 ++ src/compiler/GF/Compile/Rename.hs | 313 ++++ src/compiler/GF/Compile/SubExOpt.hs | 142 ++ src/compiler/GF/Compile/Update.hs | 226 +++ src/compiler/GF/Data/Assoc.hs | 143 ++ src/compiler/GF/Data/BacktrackM.hs | 86 ++ src/compiler/GF/Data/ErrM.hs | 38 + src/compiler/GF/Data/Graph.hs | 178 +++ src/compiler/GF/Data/Graphviz.hs | 116 ++ src/compiler/GF/Data/MultiMap.hs | 47 + src/compiler/GF/Data/Operations.hs | 374 +++++ src/compiler/GF/Data/Relation.hs | 193 +++ src/compiler/GF/Data/SortedList.hs | 127 ++ src/compiler/GF/Data/Str.hs | 134 ++ src/compiler/GF/Data/TrieMap.hs | 66 + src/compiler/GF/Data/Utilities.hs | 190 +++ src/compiler/GF/Data/XML.hs | 58 + src/compiler/GF/Data/Zipper.hs | 257 ++++ src/compiler/GF/Grammar.hs | 29 + src/compiler/GF/Grammar/Binary.hs | 261 ++++ src/compiler/GF/Grammar/CF.hs | 128 ++ src/compiler/GF/Grammar/Grammar.hs | 230 +++ src/compiler/GF/Grammar/Lexer.hs | 478 ++++++ src/compiler/GF/Grammar/Lexer.x | 272 ++++ src/compiler/GF/Grammar/Lockfield.hs | 52 + src/compiler/GF/Grammar/Lookup.hs | 188 +++ src/compiler/GF/Grammar/MMacros.hs | 279 ++++ src/compiler/GF/Grammar/Macros.hs | 627 ++++++++ src/compiler/GF/Grammar/Parser.y | 739 +++++++++ src/compiler/GF/Grammar/PatternMatch.hs | 165 ++ src/compiler/GF/Grammar/Predef.hs | 180 +++ src/compiler/GF/Grammar/Printer.hs | 317 ++++ src/compiler/GF/Grammar/Unify.hs | 97 ++ src/compiler/GF/Grammar/Values.hs | 96 ++ src/compiler/GF/Infra/CheckM.hs | 77 + src/compiler/GF/Infra/CompactPrint.hs | 22 + src/compiler/GF/Infra/Dependencies.hs | 61 + src/compiler/GF/Infra/GetOpt.hs | 381 +++++ src/compiler/GF/Infra/Ident.hs | 152 ++ src/compiler/GF/Infra/Modules.hs | 349 +++++ src/compiler/GF/Infra/Option.hs | 609 ++++++++ src/compiler/GF/Infra/UseIO.hs | 186 +++ src/compiler/GF/JavaScript/AbsJS.hs | 60 + src/compiler/GF/JavaScript/JS.cf | 55 + src/compiler/GF/JavaScript/LexJS.x | 132 ++ src/compiler/GF/JavaScript/Makefile | 14 + src/compiler/GF/JavaScript/ParJS.y | 225 +++ src/compiler/GF/JavaScript/PrintJS.hs | 169 ++ src/compiler/GF/Quiz.hs | 98 ++ src/compiler/GF/Speech/CFG.hs | 372 +++++ src/compiler/GF/Speech/CFGToFA.hs | 244 +++ src/compiler/GF/Speech/FiniteState.hs | 329 ++++ src/compiler/GF/Speech/GSL.hs | 95 ++ src/compiler/GF/Speech/JSGF.hs | 113 ++ src/compiler/GF/Speech/PGFToCFG.hs | 116 ++ src/compiler/GF/Speech/PrRegExp.hs | 27 + src/compiler/GF/Speech/RegExp.hs | 144 ++ src/compiler/GF/Speech/SISR.hs | 77 + src/compiler/GF/Speech/SLF.hs | 178 +++ src/compiler/GF/Speech/SRG.hs | 205 +++ src/compiler/GF/Speech/SRGS_ABNF.hs | 127 ++ src/compiler/GF/Speech/SRGS_XML.hs | 105 ++ src/compiler/GF/Speech/VoiceXML.hs | 243 +++ src/compiler/GF/System/NoReadline.hs | 33 + src/compiler/GF/System/NoSignal.hs | 29 + src/compiler/GF/System/Readline.hs | 35 + src/compiler/GF/System/Signal.hs | 27 + src/compiler/GF/System/UseEditline.hs | 36 + src/compiler/GF/System/UseHaskeline.hs | 43 + src/compiler/GF/System/UseReadline.hs | 36 + src/compiler/GF/System/UseSignal.hs | 72 + src/compiler/GF/Text/CP1250.hs | 77 + src/compiler/GF/Text/CP1251.hs | 74 + src/compiler/GF/Text/CP1252.hs | 6 + src/compiler/GF/Text/Coding.hs | 21 + src/compiler/GF/Text/Lexing.hs | 131 ++ src/compiler/GF/Text/Transliterations.hs | 206 +++ src/compiler/GF/Text/UTF8.hs | 48 + src/compiler/GFC.hs | 88 ++ src/compiler/GFI.hs | 363 +++++ src/config.guess | 1497 ------------------ src/config.mk.in | 37 - src/config.sub | 1608 -------------------- src/configure.ac | 229 --- src/exper/EditShell.hs | 136 -- src/exper/Evaluate.hs | 461 ------ src/exper/Optimize.hs | 273 ---- src/gf.spec | 119 -- src/gf.wxs.in | 63 - src/gf_atk.cfg | 98 -- src/gfc.in | 30 - src/haddock/haddock-check.perl | 169 -- src/haddock/haddock-script.csh | 73 - src/haddock/resources/blank.html | 10 - src/haddock/resources/index.html | 14 - src/install-sh | 251 --- src/runtime/c/Makefile | 19 + src/runtime/c/gfcc-term.c | 203 +++ src/runtime/c/gfcc-term.h | 65 + src/runtime/c/gfcc-tree.c | 61 + src/runtime/c/gfcc-tree.h | 49 + src/runtime/haskell/Data/Binary.hs | 791 ++++++++++ src/runtime/haskell/Data/Binary/Builder.hs | 426 ++++++ src/runtime/haskell/Data/Binary/Get.hs | 544 +++++++ src/runtime/haskell/Data/Binary/Put.hs | 216 +++ src/runtime/haskell/PGF.hs | 352 +++++ src/runtime/haskell/PGF/Binary.hs | 199 +++ src/runtime/haskell/PGF/BuildParser.hs | 76 + src/runtime/haskell/PGF/CId.hs | 55 + src/runtime/haskell/PGF/Check.hs | 173 +++ src/runtime/haskell/PGF/Data.hs | 95 ++ src/runtime/haskell/PGF/Editor.hs | 241 +++ src/runtime/haskell/PGF/Expr.hs | 355 +++++ src/runtime/haskell/PGF/Expr.hs-boot | 28 + src/runtime/haskell/PGF/Generate.hs | 66 + src/runtime/haskell/PGF/Linearize.hs | 166 ++ src/runtime/haskell/PGF/Macros.hs | 154 ++ src/runtime/haskell/PGF/Morphology.hs | 26 + src/runtime/haskell/PGF/PMCFG.hs | 119 ++ src/runtime/haskell/PGF/Paraphrase.hs | 112 ++ src/runtime/haskell/PGF/Parsing/FCFG/Active.hs | 205 +++ .../haskell/PGF/Parsing/FCFG/Incremental.hs | 371 +++++ src/runtime/haskell/PGF/Parsing/FCFG/Utilities.hs | 188 +++ src/runtime/haskell/PGF/ShowLinearize.hs | 113 ++ src/runtime/haskell/PGF/Tree.hs | 71 + src/runtime/haskell/PGF/Type.hs | 103 ++ src/runtime/haskell/PGF/TypeCheck.hs | 524 +++++++ src/runtime/haskell/PGF/VisualizeTree.hs | 353 +++++ src/runtime/javascript/editor.html | 17 + src/runtime/javascript/editorGrammar.js | 1 + src/runtime/javascript/empty.png | Bin 0 -> 161 bytes src/runtime/javascript/gfjseditor.js | 1267 +++++++++++++++ src/runtime/javascript/gflib-xhtml-voice.js | 54 + src/runtime/javascript/gflib.js | 1128 ++++++++++++++ src/runtime/javascript/grammar.js | 1 + src/runtime/javascript/minus.png | Bin 0 -> 201 bytes src/runtime/javascript/plus.png | Bin 0 -> 229 bytes src/runtime/javascript/style.css | 241 +++ src/runtime/javascript/translator.css | 54 + src/runtime/javascript/translator.html | 48 + src/runtime/javascript/translator.js | 51 + src/server/Makefile | 59 - src/server/README | 132 -- 326 files changed, 30036 insertions(+), 35917 deletions(-) delete mode 100644 src/Data/Binary.hs delete mode 100644 src/Data/Binary/Builder.hs delete mode 100644 src/Data/Binary/Get.hs delete mode 100644 src/Data/Binary/Put.hs delete mode 100644 src/FILES delete mode 100644 src/GF.hs delete mode 100644 src/GF/Command/Abstract.hs delete mode 100644 src/GF/Command/Commands.hs delete mode 100644 src/GF/Command/Importing.hs delete mode 100644 src/GF/Command/Interpreter.hs delete mode 100644 src/GF/Command/Messages.hs delete mode 100644 src/GF/Command/Parse.hs delete mode 100644 src/GF/Command/TreeOperations.hs delete mode 100644 src/GF/Compile.hs delete mode 100644 src/GF/Compile/Abstract/Compute.hs delete mode 100644 src/GF/Compile/Abstract/TC.hs delete mode 100644 src/GF/Compile/Abstract/TypeCheck.hs delete mode 100644 src/GF/Compile/CheckGrammar.hs delete mode 100644 src/GF/Compile/Coding.hs delete mode 100644 src/GF/Compile/Concrete/AppPredefined.hs delete mode 100644 src/GF/Compile/Concrete/Compute.hs delete mode 100644 src/GF/Compile/Concrete/TypeCheck.hs delete mode 100644 src/GF/Compile/Export.hs delete mode 100644 src/GF/Compile/GFCCtoHaskell.hs delete mode 100644 src/GF/Compile/GFCCtoJS.hs delete mode 100644 src/GF/Compile/GFCCtoProlog.hs delete mode 100644 src/GF/Compile/GenerateFCFG.hs delete mode 100644 src/GF/Compile/GeneratePMCFG.hs delete mode 100644 src/GF/Compile/GeneratePMCFGOld.hs delete mode 100644 src/GF/Compile/GetGrammar.hs delete mode 100644 src/GF/Compile/GrammarToGFCC.hs delete mode 100644 src/GF/Compile/ModDeps.hs delete mode 100644 src/GF/Compile/Optimize.hs delete mode 100644 src/GF/Compile/OptimizeGFCC.hs delete mode 100644 src/GF/Compile/PGFPretty.hs delete mode 100644 src/GF/Compile/ReadFiles.hs delete mode 100644 src/GF/Compile/Refresh.hs delete mode 100644 src/GF/Compile/Rename.hs delete mode 100644 src/GF/Compile/SubExOpt.hs delete mode 100644 src/GF/Compile/Update.hs delete mode 100644 src/GF/Data/Assoc.hs delete mode 100644 src/GF/Data/BacktrackM.hs delete mode 100644 src/GF/Data/ErrM.hs delete mode 100644 src/GF/Data/Graph.hs delete mode 100644 src/GF/Data/Graphviz.hs delete mode 100644 src/GF/Data/MultiMap.hs delete mode 100644 src/GF/Data/Operations.hs delete mode 100644 src/GF/Data/Relation.hs delete mode 100644 src/GF/Data/SortedList.hs delete mode 100644 src/GF/Data/Str.hs delete mode 100644 src/GF/Data/TrieMap.hs delete mode 100644 src/GF/Data/Utilities.hs delete mode 100644 src/GF/Data/XML.hs delete mode 100644 src/GF/Data/Zipper.hs delete mode 100644 src/GF/Grammar.hs delete mode 100644 src/GF/Grammar/Binary.hs delete mode 100644 src/GF/Grammar/CF.hs delete mode 100644 src/GF/Grammar/Grammar.hs delete mode 100644 src/GF/Grammar/Lexer.hs delete mode 100644 src/GF/Grammar/Lexer.x delete mode 100644 src/GF/Grammar/Lockfield.hs delete mode 100644 src/GF/Grammar/Lookup.hs delete mode 100644 src/GF/Grammar/MMacros.hs delete mode 100644 src/GF/Grammar/Macros.hs delete mode 100644 src/GF/Grammar/Parser.y delete mode 100644 src/GF/Grammar/PatternMatch.hs delete mode 100644 src/GF/Grammar/Predef.hs delete mode 100644 src/GF/Grammar/Printer.hs delete mode 100644 src/GF/Grammar/Unify.hs delete mode 100644 src/GF/Grammar/Values.hs delete mode 100644 src/GF/Infra/CheckM.hs delete mode 100644 src/GF/Infra/CompactPrint.hs delete mode 100644 src/GF/Infra/Dependencies.hs delete mode 100644 src/GF/Infra/GetOpt.hs delete mode 100644 src/GF/Infra/Ident.hs delete mode 100644 src/GF/Infra/Modules.hs delete mode 100644 src/GF/Infra/Option.hs delete mode 100644 src/GF/Infra/UseIO.hs delete mode 100644 src/GF/JavaScript/AbsJS.hs delete mode 100644 src/GF/JavaScript/JS.cf delete mode 100644 src/GF/JavaScript/LexJS.x delete mode 100644 src/GF/JavaScript/Makefile delete mode 100644 src/GF/JavaScript/ParJS.y delete mode 100644 src/GF/JavaScript/PrintJS.hs delete mode 100644 src/GF/Quiz.hs delete mode 100644 src/GF/Speech/CFG.hs delete mode 100644 src/GF/Speech/CFGToFA.hs delete mode 100644 src/GF/Speech/FiniteState.hs delete mode 100644 src/GF/Speech/GSL.hs delete mode 100644 src/GF/Speech/JSGF.hs delete mode 100644 src/GF/Speech/PGFToCFG.hs delete mode 100644 src/GF/Speech/PrRegExp.hs delete mode 100644 src/GF/Speech/RegExp.hs delete mode 100644 src/GF/Speech/SISR.hs delete mode 100644 src/GF/Speech/SLF.hs delete mode 100644 src/GF/Speech/SRG.hs delete mode 100644 src/GF/Speech/SRGS_ABNF.hs delete mode 100644 src/GF/Speech/SRGS_XML.hs delete mode 100644 src/GF/Speech/VoiceXML.hs delete mode 100644 src/GF/System/NoReadline.hs delete mode 100644 src/GF/System/NoSignal.hs delete mode 100644 src/GF/System/Readline.hs delete mode 100644 src/GF/System/Signal.hs delete mode 100644 src/GF/System/UseEditline.hs delete mode 100644 src/GF/System/UseHaskeline.hs delete mode 100644 src/GF/System/UseReadline.hs delete mode 100644 src/GF/System/UseSignal.hs delete mode 100644 src/GF/Text/CP1250.hs delete mode 100644 src/GF/Text/CP1251.hs delete mode 100644 src/GF/Text/CP1252.hs delete mode 100644 src/GF/Text/Coding.hs delete mode 100644 src/GF/Text/Lexing.hs delete mode 100644 src/GF/Text/Transliterations.hs delete mode 100644 src/GF/Text/UTF8.hs delete mode 100644 src/GFC.hs delete mode 100644 src/GFI.hs delete mode 100644 src/HelpFile delete mode 100644 src/Makefile delete mode 100644 src/Makefile.binary delete mode 100644 src/PGF.hs delete mode 100644 src/PGF/Binary.hs delete mode 100644 src/PGF/BuildParser.hs delete mode 100644 src/PGF/CId.hs delete mode 100644 src/PGF/Check.hs delete mode 100644 src/PGF/Data.hs delete mode 100644 src/PGF/Editor.hs delete mode 100644 src/PGF/Expr.hs delete mode 100644 src/PGF/Expr.hs-boot delete mode 100644 src/PGF/Generate.hs delete mode 100644 src/PGF/Linearize.hs delete mode 100644 src/PGF/Macros.hs delete mode 100644 src/PGF/Morphology.hs delete mode 100644 src/PGF/PMCFG.hs delete mode 100644 src/PGF/Paraphrase.hs delete mode 100644 src/PGF/Parsing/FCFG/Active.hs delete mode 100644 src/PGF/Parsing/FCFG/Incremental.hs delete mode 100644 src/PGF/Parsing/FCFG/Utilities.hs delete mode 100644 src/PGF/ShowLinearize.hs delete mode 100644 src/PGF/Tree.hs delete mode 100644 src/PGF/Type.hs delete mode 100644 src/PGF/TypeCheck.hs delete mode 100644 src/PGF/VisualizeTree.hs delete mode 100644 src/PGF/doc/Eng.gf delete mode 100644 src/PGF/doc/Ex.gf delete mode 100644 src/PGF/doc/Swe.gf delete mode 100644 src/PGF/doc/Test.gf delete mode 100644 src/PGF/doc/gfcc.html delete mode 100644 src/PGF/doc/gfcc.txt delete mode 100644 src/PGF/doc/old-GFCC.cf delete mode 100644 src/PGF/doc/old-gfcc.txt delete mode 100644 src/PGF/doc/syntax.txt delete mode 100644 src/ReleaseProcedure create mode 100644 src/compiler/GF.hs create mode 100644 src/compiler/GF/Command/Abstract.hs create mode 100644 src/compiler/GF/Command/Commands.hs create mode 100644 src/compiler/GF/Command/Importing.hs create mode 100644 src/compiler/GF/Command/Interpreter.hs create mode 100644 src/compiler/GF/Command/Messages.hs create mode 100644 src/compiler/GF/Command/Parse.hs create mode 100644 src/compiler/GF/Command/TreeOperations.hs create mode 100644 src/compiler/GF/Compile.hs create mode 100644 src/compiler/GF/Compile/Abstract/Compute.hs create mode 100644 src/compiler/GF/Compile/Abstract/TC.hs create mode 100644 src/compiler/GF/Compile/Abstract/TypeCheck.hs create mode 100644 src/compiler/GF/Compile/CheckGrammar.hs create mode 100644 src/compiler/GF/Compile/Coding.hs create mode 100644 src/compiler/GF/Compile/Concrete/AppPredefined.hs create mode 100644 src/compiler/GF/Compile/Concrete/Compute.hs create mode 100644 src/compiler/GF/Compile/Concrete/TypeCheck.hs create mode 100644 src/compiler/GF/Compile/Export.hs create mode 100644 src/compiler/GF/Compile/GFCCtoHaskell.hs create mode 100644 src/compiler/GF/Compile/GFCCtoJS.hs create mode 100644 src/compiler/GF/Compile/GFCCtoProlog.hs create mode 100644 src/compiler/GF/Compile/GenerateFCFG.hs create mode 100644 src/compiler/GF/Compile/GeneratePMCFG.hs create mode 100644 src/compiler/GF/Compile/GeneratePMCFGOld.hs create mode 100644 src/compiler/GF/Compile/GetGrammar.hs create mode 100644 src/compiler/GF/Compile/GrammarToGFCC.hs create mode 100644 src/compiler/GF/Compile/ModDeps.hs create mode 100644 src/compiler/GF/Compile/Optimize.hs create mode 100644 src/compiler/GF/Compile/OptimizeGFCC.hs create mode 100644 src/compiler/GF/Compile/PGFPretty.hs create mode 100644 src/compiler/GF/Compile/ReadFiles.hs create mode 100644 src/compiler/GF/Compile/Refresh.hs create mode 100644 src/compiler/GF/Compile/Rename.hs create mode 100644 src/compiler/GF/Compile/SubExOpt.hs create mode 100644 src/compiler/GF/Compile/Update.hs create mode 100644 src/compiler/GF/Data/Assoc.hs create mode 100644 src/compiler/GF/Data/BacktrackM.hs create mode 100644 src/compiler/GF/Data/ErrM.hs create mode 100644 src/compiler/GF/Data/Graph.hs create mode 100644 src/compiler/GF/Data/Graphviz.hs create mode 100644 src/compiler/GF/Data/MultiMap.hs create mode 100644 src/compiler/GF/Data/Operations.hs create mode 100644 src/compiler/GF/Data/Relation.hs create mode 100644 src/compiler/GF/Data/SortedList.hs create mode 100644 src/compiler/GF/Data/Str.hs create mode 100644 src/compiler/GF/Data/TrieMap.hs create mode 100644 src/compiler/GF/Data/Utilities.hs create mode 100644 src/compiler/GF/Data/XML.hs create mode 100644 src/compiler/GF/Data/Zipper.hs create mode 100644 src/compiler/GF/Grammar.hs create mode 100644 src/compiler/GF/Grammar/Binary.hs create mode 100644 src/compiler/GF/Grammar/CF.hs create mode 100644 src/compiler/GF/Grammar/Grammar.hs create mode 100644 src/compiler/GF/Grammar/Lexer.hs create mode 100644 src/compiler/GF/Grammar/Lexer.x create mode 100644 src/compiler/GF/Grammar/Lockfield.hs create mode 100644 src/compiler/GF/Grammar/Lookup.hs create mode 100644 src/compiler/GF/Grammar/MMacros.hs create mode 100644 src/compiler/GF/Grammar/Macros.hs create mode 100644 src/compiler/GF/Grammar/Parser.y create mode 100644 src/compiler/GF/Grammar/PatternMatch.hs create mode 100644 src/compiler/GF/Grammar/Predef.hs create mode 100644 src/compiler/GF/Grammar/Printer.hs create mode 100644 src/compiler/GF/Grammar/Unify.hs create mode 100644 src/compiler/GF/Grammar/Values.hs create mode 100644 src/compiler/GF/Infra/CheckM.hs create mode 100644 src/compiler/GF/Infra/CompactPrint.hs create mode 100644 src/compiler/GF/Infra/Dependencies.hs create mode 100644 src/compiler/GF/Infra/GetOpt.hs create mode 100644 src/compiler/GF/Infra/Ident.hs create mode 100644 src/compiler/GF/Infra/Modules.hs create mode 100644 src/compiler/GF/Infra/Option.hs create mode 100644 src/compiler/GF/Infra/UseIO.hs create mode 100644 src/compiler/GF/JavaScript/AbsJS.hs create mode 100644 src/compiler/GF/JavaScript/JS.cf create mode 100644 src/compiler/GF/JavaScript/LexJS.x create mode 100644 src/compiler/GF/JavaScript/Makefile create mode 100644 src/compiler/GF/JavaScript/ParJS.y create mode 100644 src/compiler/GF/JavaScript/PrintJS.hs create mode 100644 src/compiler/GF/Quiz.hs create mode 100644 src/compiler/GF/Speech/CFG.hs create mode 100644 src/compiler/GF/Speech/CFGToFA.hs create mode 100644 src/compiler/GF/Speech/FiniteState.hs create mode 100644 src/compiler/GF/Speech/GSL.hs create mode 100644 src/compiler/GF/Speech/JSGF.hs create mode 100644 src/compiler/GF/Speech/PGFToCFG.hs create mode 100644 src/compiler/GF/Speech/PrRegExp.hs create mode 100644 src/compiler/GF/Speech/RegExp.hs create mode 100644 src/compiler/GF/Speech/SISR.hs create mode 100644 src/compiler/GF/Speech/SLF.hs create mode 100644 src/compiler/GF/Speech/SRG.hs create mode 100644 src/compiler/GF/Speech/SRGS_ABNF.hs create mode 100644 src/compiler/GF/Speech/SRGS_XML.hs create mode 100644 src/compiler/GF/Speech/VoiceXML.hs create mode 100644 src/compiler/GF/System/NoReadline.hs create mode 100644 src/compiler/GF/System/NoSignal.hs create mode 100644 src/compiler/GF/System/Readline.hs create mode 100644 src/compiler/GF/System/Signal.hs create mode 100644 src/compiler/GF/System/UseEditline.hs create mode 100644 src/compiler/GF/System/UseHaskeline.hs create mode 100644 src/compiler/GF/System/UseReadline.hs create mode 100644 src/compiler/GF/System/UseSignal.hs create mode 100644 src/compiler/GF/Text/CP1250.hs create mode 100644 src/compiler/GF/Text/CP1251.hs create mode 100644 src/compiler/GF/Text/CP1252.hs create mode 100644 src/compiler/GF/Text/Coding.hs create mode 100644 src/compiler/GF/Text/Lexing.hs create mode 100644 src/compiler/GF/Text/Transliterations.hs create mode 100644 src/compiler/GF/Text/UTF8.hs create mode 100644 src/compiler/GFC.hs create mode 100644 src/compiler/GFI.hs delete mode 100644 src/config.guess delete mode 100644 src/config.mk.in delete mode 100644 src/config.sub delete mode 100644 src/configure.ac delete mode 100644 src/exper/EditShell.hs delete mode 100644 src/exper/Evaluate.hs delete mode 100644 src/exper/Optimize.hs delete mode 100644 src/gf.spec delete mode 100644 src/gf.wxs.in delete mode 100644 src/gf_atk.cfg delete mode 100644 src/gfc.in delete mode 100644 src/haddock/haddock-check.perl delete mode 100644 src/haddock/haddock-script.csh delete mode 100644 src/haddock/resources/blank.html delete mode 100644 src/haddock/resources/index.html delete mode 100644 src/install-sh create mode 100644 src/runtime/c/Makefile create mode 100644 src/runtime/c/gfcc-term.c create mode 100644 src/runtime/c/gfcc-term.h create mode 100644 src/runtime/c/gfcc-tree.c create mode 100644 src/runtime/c/gfcc-tree.h create mode 100644 src/runtime/haskell/Data/Binary.hs create mode 100644 src/runtime/haskell/Data/Binary/Builder.hs create mode 100644 src/runtime/haskell/Data/Binary/Get.hs create mode 100644 src/runtime/haskell/Data/Binary/Put.hs create mode 100644 src/runtime/haskell/PGF.hs create mode 100644 src/runtime/haskell/PGF/Binary.hs create mode 100644 src/runtime/haskell/PGF/BuildParser.hs create mode 100644 src/runtime/haskell/PGF/CId.hs create mode 100644 src/runtime/haskell/PGF/Check.hs create mode 100644 src/runtime/haskell/PGF/Data.hs create mode 100644 src/runtime/haskell/PGF/Editor.hs create mode 100644 src/runtime/haskell/PGF/Expr.hs create mode 100644 src/runtime/haskell/PGF/Expr.hs-boot create mode 100644 src/runtime/haskell/PGF/Generate.hs create mode 100644 src/runtime/haskell/PGF/Linearize.hs create mode 100644 src/runtime/haskell/PGF/Macros.hs create mode 100644 src/runtime/haskell/PGF/Morphology.hs create mode 100644 src/runtime/haskell/PGF/PMCFG.hs create mode 100644 src/runtime/haskell/PGF/Paraphrase.hs create mode 100644 src/runtime/haskell/PGF/Parsing/FCFG/Active.hs create mode 100644 src/runtime/haskell/PGF/Parsing/FCFG/Incremental.hs create mode 100644 src/runtime/haskell/PGF/Parsing/FCFG/Utilities.hs create mode 100644 src/runtime/haskell/PGF/ShowLinearize.hs create mode 100644 src/runtime/haskell/PGF/Tree.hs create mode 100644 src/runtime/haskell/PGF/Type.hs create mode 100644 src/runtime/haskell/PGF/TypeCheck.hs create mode 100644 src/runtime/haskell/PGF/VisualizeTree.hs create mode 100644 src/runtime/javascript/editor.html create mode 100644 src/runtime/javascript/editorGrammar.js create mode 100644 src/runtime/javascript/empty.png create mode 100644 src/runtime/javascript/gfjseditor.js create mode 100644 src/runtime/javascript/gflib-xhtml-voice.js create mode 100644 src/runtime/javascript/gflib.js create mode 100644 src/runtime/javascript/grammar.js create mode 100644 src/runtime/javascript/minus.png create mode 100644 src/runtime/javascript/plus.png create mode 100644 src/runtime/javascript/style.css create mode 100644 src/runtime/javascript/translator.css create mode 100644 src/runtime/javascript/translator.html create mode 100644 src/runtime/javascript/translator.js delete mode 100644 src/server/Makefile delete mode 100644 src/server/README (limited to 'src') diff --git a/src/Data/Binary.hs b/src/Data/Binary.hs deleted file mode 100644 index 786f5a09e..000000000 --- a/src/Data/Binary.hs +++ /dev/null @@ -1,791 +0,0 @@ -{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Binary --- Copyright : Lennart Kolmodin --- License : BSD3-style (see LICENSE) --- --- Maintainer : Lennart Kolmodin --- Stability : unstable --- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances --- --- Binary serialisation of Haskell values to and from lazy ByteStrings. --- The Binary library provides methods for encoding Haskell values as --- streams of bytes directly in memory. The resulting @ByteString@ can --- then be written to disk, sent over the network, or futher processed --- (for example, compressed with gzip). --- --- The 'Binary' package is notable in that it provides both pure, and --- high performance serialisation. --- --- Values are always encoded in network order (big endian) form, and --- encoded data should be portable across machine endianess, word size, --- or compiler version. For example, data encoded using the Binary class --- could be written from GHC, and read back in Hugs. --- ------------------------------------------------------------------------------ - -module Data.Binary ( - - -- * The Binary class - Binary(..) - - -- $example - - -- * The Get and Put monads - , Get - , Put - - -- * Useful helpers for writing instances - , putWord8 - , getWord8 - - -- * Binary serialisation - , encode -- :: Binary a => a -> ByteString - , decode -- :: Binary a => ByteString -> a - - -- * IO functions for serialisation - , encodeFile -- :: Binary a => FilePath -> a -> IO () - , decodeFile -- :: Binary a => FilePath -> IO a - --- Lazy put and get --- , lazyPut --- , lazyGet - - , module Data.Word -- useful - - ) where - -#include "MachDeps.h" - -import Data.Word - -import Data.Binary.Put -import Data.Binary.Get - -import Control.Monad -import Control.Exception -import Foreign -import System.IO - -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as L - -import Data.Char (chr,ord) -import Data.List (unfoldr) - --- And needed for the instances: -import qualified Data.ByteString as B -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet -import qualified Data.Ratio as R - -import qualified Data.Tree as T - -import Data.Array.Unboxed - --- --- This isn't available in older Hugs or older GHC --- -#if __GLASGOW_HASKELL__ >= 606 -import qualified Data.Sequence as Seq -import qualified Data.Foldable as Fold -#endif - ------------------------------------------------------------------------- - --- | The @Binary@ class provides 'put' and 'get', methods to encode and --- decode a Haskell value to a lazy ByteString. It mirrors the Read and --- Show classes for textual representation of Haskell types, and is --- suitable for serialising Haskell values to disk, over the network. --- --- For parsing and generating simple external binary formats (e.g. C --- structures), Binary may be used, but in general is not suitable --- for complex protocols. Instead use the Put and Get primitives --- directly. --- --- Instances of Binary should satisfy the following property: --- --- > decode . encode == id --- --- That is, the 'get' and 'put' methods should be the inverse of each --- other. A range of instances are provided for basic Haskell types. --- -class Binary t where - -- | Encode a value in the Put monad. - put :: t -> Put - -- | Decode a value in the Get monad - get :: Get t - --- $example --- To serialise a custom type, an instance of Binary for that type is --- required. For example, suppose we have a data structure: --- --- > data Exp = IntE Int --- > | OpE String Exp Exp --- > deriving Show --- --- We can encode values of this type into bytestrings using the --- following instance, which proceeds by recursively breaking down the --- structure to serialise: --- --- > instance Binary Exp where --- > put (IntE i) = do put (0 :: Word8) --- > put i --- > put (OpE s e1 e2) = do put (1 :: Word8) --- > put s --- > put e1 --- > put e2 --- > --- > get = do t <- get :: Get Word8 --- > case t of --- > 0 -> do i <- get --- > return (IntE i) --- > 1 -> do s <- get --- > e1 <- get --- > e2 <- get --- > return (OpE s e1 e2) --- --- Note how we write an initial tag byte to indicate each variant of the --- data type. --- --- We can simplify the writing of 'get' instances using monadic --- combinators: --- --- > get = do tag <- getWord8 --- > case tag of --- > 0 -> liftM IntE get --- > 1 -> liftM3 OpE get get get --- --- The generation of Binary instances has been automated by a script --- using Scrap Your Boilerplate generics. Use the script here: --- . --- --- To derive the instance for a type, load this script into GHCi, and --- bring your type into scope. Your type can then have its Binary --- instances derived as follows: --- --- > $ ghci -fglasgow-exts BinaryDerive.hs --- > *BinaryDerive> :l Example.hs --- > *Main> deriveM (undefined :: Drinks) --- > --- > instance Binary Main.Drinks where --- > put (Beer a) = putWord8 0 >> put a --- > put Coffee = putWord8 1 --- > put Tea = putWord8 2 --- > put EnergyDrink = putWord8 3 --- > put Water = putWord8 4 --- > put Wine = putWord8 5 --- > put Whisky = putWord8 6 --- > get = do --- > tag_ <- getWord8 --- > case tag_ of --- > 0 -> get >>= \a -> return (Beer a) --- > 1 -> return Coffee --- > 2 -> return Tea --- > 3 -> return EnergyDrink --- > 4 -> return Water --- > 5 -> return Wine --- > 6 -> return Whisky --- > --- --- To serialise this to a bytestring, we use 'encode', which packs the --- data structure into a binary format, in a lazy bytestring --- --- > > let e = OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) --- > > let v = encode e --- --- Where 'v' is a binary encoded data structure. To reconstruct the --- original data, we use 'decode' --- --- > > decode v :: Exp --- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) --- --- The lazy ByteString that results from 'encode' can be written to --- disk, and read from disk using Data.ByteString.Lazy IO functions, --- such as hPutStr or writeFile: --- --- > > writeFile "/tmp/exp.txt" (encode e) --- --- And read back with: --- --- > > readFile "/tmp/exp.txt" >>= return . decode :: IO Exp --- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) --- --- We can also directly serialise a value to and from a Handle, or a file: --- --- > > v <- decodeFile "/tmp/exp.txt" :: IO Exp --- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) --- --- And write a value to disk --- --- > > encodeFile "/tmp/a.txt" v --- - ------------------------------------------------------------------------- --- Wrappers to run the underlying monad - --- | Encode a value using binary serialisation to a lazy ByteString. --- -encode :: Binary a => a -> ByteString -encode = runPut . put -{-# INLINE encode #-} - --- | Decode a value from a lazy ByteString, reconstructing the original structure. --- -decode :: Binary a => ByteString -> a -decode = runGet get - ------------------------------------------------------------------------- --- Convenience IO operations - --- | Lazily serialise a value to a file --- --- This is just a convenience function, it's defined simply as: --- --- > encodeFile f = B.writeFile f . encode --- --- So for example if you wanted to compress as well, you could use: --- --- > B.writeFile f . compress . encode --- -encodeFile :: Binary a => FilePath -> a -> IO () -encodeFile f v = L.writeFile f (encode v) - --- | Lazily reconstruct a value previously written to a file. --- --- This is just a convenience function, it's defined simply as: --- --- > decodeFile f = return . decode =<< B.readFile f --- --- So for example if you wanted to decompress as well, you could use: --- --- > return . decode . decompress =<< B.readFile f --- -decodeFile :: Binary a => FilePath -> IO a -decodeFile f = bracket (openBinaryFile f ReadMode) hClose $ \h -> do - s <- L.hGetContents h - evaluate $ runGet get s - --- needs bytestring 0.9.1.x to work - ------------------------------------------------------------------------- --- Lazy put and get - --- lazyPut :: (Binary a) => a -> Put --- lazyPut a = put (encode a) - --- lazyGet :: (Binary a) => Get a --- lazyGet = fmap decode get - ------------------------------------------------------------------------- --- Simple instances - --- The () type need never be written to disk: values of singleton type --- can be reconstructed from the type alone -instance Binary () where - put () = return () - get = return () - --- Bools are encoded as a byte in the range 0 .. 1 -instance Binary Bool where - put = putWord8 . fromIntegral . fromEnum - get = liftM (toEnum . fromIntegral) getWord8 - --- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2 -instance Binary Ordering where - put = putWord8 . fromIntegral . fromEnum - get = liftM (toEnum . fromIntegral) getWord8 - ------------------------------------------------------------------------- --- Words and Ints - --- Words8s are written as bytes -instance Binary Word8 where - put = putWord8 - get = getWord8 - --- Words16s are written as 2 bytes in big-endian (network) order -instance Binary Word16 where - put = putWord16be - get = getWord16be - --- Words32s are written as 4 bytes in big-endian (network) order -instance Binary Word32 where - put = putWord32be - get = getWord32be - --- Words64s are written as 8 bytes in big-endian (network) order -instance Binary Word64 where - put = putWord64be - get = getWord64be - --- Int8s are written as a single byte. -instance Binary Int8 where - put i = put (fromIntegral i :: Word8) - get = liftM fromIntegral (get :: Get Word8) - --- Int16s are written as a 2 bytes in big endian format -instance Binary Int16 where - put i = put (fromIntegral i :: Word16) - get = liftM fromIntegral (get :: Get Word16) - --- Int32s are written as a 4 bytes in big endian format -instance Binary Int32 where - put i = put (fromIntegral i :: Word32) - get = liftM fromIntegral (get :: Get Word32) - --- Int64s are written as a 4 bytes in big endian format -instance Binary Int64 where - put i = put (fromIntegral i :: Word64) - get = liftM fromIntegral (get :: Get Word64) - ------------------------------------------------------------------------- - --- Words are written as sequence of bytes. The last bit of each --- byte indicates whether there are more bytes to be read -instance Binary Word where - put i | i <= 0x7f = do put a - | i <= 0x3fff = do put (a .|. 0x80) - put b - | i <= 0x1fffff = do put (a .|. 0x80) - put (b .|. 0x80) - put c - | i <= 0xfffffff = do put (a .|. 0x80) - put (b .|. 0x80) - put (c .|. 0x80) - put d -#if WORD_SIZE_IN_BITS < 64 - | otherwise = do put (a .|. 0x80) - put (b .|. 0x80) - put (c .|. 0x80) - put (d .|. 0x80) - put e -#else - | i <= 0x7ffffffff = do put (a .|. 0x80) - put (b .|. 0x80) - put (c .|. 0x80) - put (d .|. 0x80) - put e - | i <= 0x3ffffffffff = do put (a .|. 0x80) - put (b .|. 0x80) - put (c .|. 0x80) - put (d .|. 0x80) - put (e .|. 0x80) - put f - | i <= 0x1ffffffffffff = do put (a .|. 0x80) - put (b .|. 0x80) - put (c .|. 0x80) - put (d .|. 0x80) - put (e .|. 0x80) - put (f .|. 0x80) - put g - | i <= 0xffffffffffffff = do put (a .|. 0x80) - put (b .|. 0x80) - put (c .|. 0x80) - put (d .|. 0x80) - put (e .|. 0x80) - put (f .|. 0x80) - put (g .|. 0x80) - put h - | i <= 0xffffffffffffff = do put (a .|. 0x80) - put (b .|. 0x80) - put (c .|. 0x80) - put (d .|. 0x80) - put (e .|. 0x80) - put (f .|. 0x80) - put (g .|. 0x80) - put h - | i <= 0x7fffffffffffffff = do put (a .|. 0x80) - put (b .|. 0x80) - put (c .|. 0x80) - put (d .|. 0x80) - put (e .|. 0x80) - put (f .|. 0x80) - put (g .|. 0x80) - put (h .|. 0x80) - put j - | otherwise = do put (a .|. 0x80) - put (b .|. 0x80) - put (c .|. 0x80) - put (d .|. 0x80) - put (e .|. 0x80) - put (f .|. 0x80) - put (g .|. 0x80) - put (h .|. 0x80) - put (j .|. 0x80) - put k -#endif - where - a = fromIntegral ( i .&. 0x7f) :: Word8 - b = fromIntegral (shiftR i 7 .&. 0x7f) :: Word8 - c = fromIntegral (shiftR i 14 .&. 0x7f) :: Word8 - d = fromIntegral (shiftR i 21 .&. 0x7f) :: Word8 - e = fromIntegral (shiftR i 28 .&. 0x7f) :: Word8 - f = fromIntegral (shiftR i 35 .&. 0x7f) :: Word8 - g = fromIntegral (shiftR i 42 .&. 0x7f) :: Word8 - h = fromIntegral (shiftR i 49 .&. 0x7f) :: Word8 - j = fromIntegral (shiftR i 56 .&. 0x7f) :: Word8 - k = fromIntegral (shiftR i 63 .&. 0x7f) :: Word8 - - get = do i <- getWord8 - (if i <= 0x7f - then return (fromIntegral i) - else do n <- get - return $ (n `shiftL` 7) .|. (fromIntegral (i .&. 0x7f))) - --- Int has the same representation as Word -instance Binary Int where - put i = put (fromIntegral i :: Word) - get = liftM fromIntegral (get :: Get Word) - ------------------------------------------------------------------------- --- --- Portable, and pretty efficient, serialisation of Integer --- - --- Fixed-size type for a subset of Integer -type SmallInt = Int32 - --- Integers are encoded in two ways: if they fit inside a SmallInt, --- they're written as a byte tag, and that value. If the Integer value --- is too large to fit in a SmallInt, it is written as a byte array, --- along with a sign and length field. - -instance Binary Integer where - - {-# INLINE put #-} - put n | n >= lo && n <= hi = do - putWord8 0 - put (fromIntegral n :: SmallInt) -- fast path - where - lo = fromIntegral (minBound :: SmallInt) :: Integer - hi = fromIntegral (maxBound :: SmallInt) :: Integer - - put n = do - putWord8 1 - put sign - put (unroll (abs n)) -- unroll the bytes - where - sign = fromIntegral (signum n) :: Word8 - - {-# INLINE get #-} - get = do - tag <- get :: Get Word8 - case tag of - 0 -> liftM fromIntegral (get :: Get SmallInt) - _ -> do sign <- get - bytes <- get - let v = roll bytes - return $! if sign == (1 :: Word8) then v else - v - --- --- Fold and unfold an Integer to and from a list of its bytes --- -unroll :: Integer -> [Word8] -unroll = unfoldr step - where - step 0 = Nothing - step i = Just (fromIntegral i, i `shiftR` 8) - -roll :: [Word8] -> Integer -roll = foldr unstep 0 - where - unstep b a = a `shiftL` 8 .|. fromIntegral b - -{- - --- --- An efficient, raw serialisation for Integer (GHC only) --- - --- TODO This instance is not architecture portable. GMP stores numbers as --- arrays of machine sized words, so the byte format is not portable across --- architectures with different endianess and word size. - -import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy) -import GHC.Base hiding (ord, chr) -import GHC.Prim -import GHC.Ptr (Ptr(..)) -import GHC.IOBase (IO(..)) - -instance Binary Integer where - put (S# i) = putWord8 0 >> put (I# i) - put (J# s ba) = do - putWord8 1 - put (I# s) - put (BA ba) - - get = do - b <- getWord8 - case b of - 0 -> do (I# i#) <- get - return (S# i#) - _ -> do (I# s#) <- get - (BA a#) <- get - return (J# s# a#) - -instance Binary ByteArray where - - -- Pretty safe. - put (BA ba) = - let sz = sizeofByteArray# ba -- (primitive) in *bytes* - addr = byteArrayContents# ba - bs = unsafePackAddress (I# sz) addr - in put bs -- write as a ByteString. easy, yay! - - -- Pretty scary. Should be quick though - get = do - (fp, off, n@(I# sz)) <- liftM toForeignPtr get -- so decode a ByteString - assert (off == 0) $ return $ unsafePerformIO $ do - (MBA arr) <- newByteArray sz -- and copy it into a ByteArray# - let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe? - withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n) - freezeByteArray arr - --- wrapper for ByteArray# -data ByteArray = BA {-# UNPACK #-} !ByteArray# -data MBA = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld) - -newByteArray :: Int# -> IO MBA -newByteArray sz = IO $ \s -> - case newPinnedByteArray# sz s of { (# s', arr #) -> - (# s', MBA arr #) } - -freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray -freezeByteArray arr = IO $ \s -> - case unsafeFreezeByteArray# arr s of { (# s', arr' #) -> - (# s', BA arr' #) } - --} - -instance (Binary a,Integral a) => Binary (R.Ratio a) where - put r = put (R.numerator r) >> put (R.denominator r) - get = liftM2 (R.%) get get - ------------------------------------------------------------------------- - --- Char is serialised as UTF-8 -instance Binary Char where - put a | c <= 0x7f = put (fromIntegral c :: Word8) - | c <= 0x7ff = do put (0xc0 .|. y) - put (0x80 .|. z) - | c <= 0xffff = do put (0xe0 .|. x) - put (0x80 .|. y) - put (0x80 .|. z) - | c <= 0x10ffff = do put (0xf0 .|. w) - put (0x80 .|. x) - put (0x80 .|. y) - put (0x80 .|. z) - | otherwise = error "Not a valid Unicode code point" - where - c = ord a - z, y, x, w :: Word8 - z = fromIntegral (c .&. 0x3f) - y = fromIntegral (shiftR c 6 .&. 0x3f) - x = fromIntegral (shiftR c 12 .&. 0x3f) - w = fromIntegral (shiftR c 18 .&. 0x7) - - get = do - let getByte = liftM (fromIntegral :: Word8 -> Int) get - shiftL6 = flip shiftL 6 :: Int -> Int - w <- getByte - r <- case () of - _ | w < 0x80 -> return w - | w < 0xe0 -> do - x <- liftM (xor 0x80) getByte - return (x .|. shiftL6 (xor 0xc0 w)) - | w < 0xf0 -> do - x <- liftM (xor 0x80) getByte - y <- liftM (xor 0x80) getByte - return (y .|. shiftL6 (x .|. shiftL6 - (xor 0xe0 w))) - | otherwise -> do - x <- liftM (xor 0x80) getByte - y <- liftM (xor 0x80) getByte - z <- liftM (xor 0x80) getByte - return (z .|. shiftL6 (y .|. shiftL6 - (x .|. shiftL6 (xor 0xf0 w)))) - return $! chr r - ------------------------------------------------------------------------- --- Instances for the first few tuples - -instance (Binary a, Binary b) => Binary (a,b) where - put (a,b) = put a >> put b - get = liftM2 (,) get get - -instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where - put (a,b,c) = put a >> put b >> put c - get = liftM3 (,,) get get get - -instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where - put (a,b,c,d) = put a >> put b >> put c >> put d - get = liftM4 (,,,) get get get get - -instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where - put (a,b,c,d,e) = put a >> put b >> put c >> put d >> put e - get = liftM5 (,,,,) get get get get get - --- --- and now just recurse: --- - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) - => Binary (a,b,c,d,e,f) where - put (a,b,c,d,e,f) = put (a,(b,c,d,e,f)) - get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) - => Binary (a,b,c,d,e,f,g) where - put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g)) - get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, - Binary f, Binary g, Binary h) - => Binary (a,b,c,d,e,f,g,h) where - put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h)) - get = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, - Binary f, Binary g, Binary h, Binary i) - => Binary (a,b,c,d,e,f,g,h,i) where - put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i)) - get = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, - Binary f, Binary g, Binary h, Binary i, Binary j) - => Binary (a,b,c,d,e,f,g,h,i,j) where - put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j)) - get = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j) - ------------------------------------------------------------------------- --- Container types - -instance Binary a => Binary [a] where - put l = put (length l) >> mapM_ put l - get = do n <- get :: Get Int - xs <- replicateM n get - return xs - -instance (Binary a) => Binary (Maybe a) where - put Nothing = putWord8 0 - put (Just x) = putWord8 1 >> put x - get = do - w <- getWord8 - case w of - 0 -> return Nothing - _ -> liftM Just get - -instance (Binary a, Binary b) => Binary (Either a b) where - put (Left a) = putWord8 0 >> put a - put (Right b) = putWord8 1 >> put b - get = do - w <- getWord8 - case w of - 0 -> liftM Left get - _ -> liftM Right get - ------------------------------------------------------------------------- --- ByteStrings (have specially efficient instances) - -instance Binary B.ByteString where - put bs = do put (B.length bs) - putByteString bs - get = get >>= getByteString - --- --- Using old versions of fps, this is a type synonym, and non portable --- --- Requires 'flexible instances' --- -instance Binary ByteString where - put bs = do put (fromIntegral (L.length bs) :: Int) - putLazyByteString bs - get = get >>= getLazyByteString - ------------------------------------------------------------------------- --- Maps and Sets - -instance (Ord a, Binary a) => Binary (Set.Set a) where - put s = put (Set.size s) >> mapM_ put (Set.toAscList s) - get = liftM Set.fromDistinctAscList get - -instance (Ord k, Binary k, Binary e) => Binary (Map.Map k e) where - put m = put (Map.size m) >> mapM_ put (Map.toAscList m) - get = liftM Map.fromDistinctAscList get - -instance Binary IntSet.IntSet where - put s = put (IntSet.size s) >> mapM_ put (IntSet.toAscList s) - get = liftM IntSet.fromDistinctAscList get - -instance (Binary e) => Binary (IntMap.IntMap e) where - put m = put (IntMap.size m) >> mapM_ put (IntMap.toAscList m) - get = liftM IntMap.fromDistinctAscList get - ------------------------------------------------------------------------- --- Queues and Sequences - -#if __GLASGOW_HASKELL__ >= 606 --- --- This is valid Hugs, but you need the most recent Hugs --- - -instance (Binary e) => Binary (Seq.Seq e) where - put s = put (Seq.length s) >> Fold.mapM_ put s - get = do n <- get :: Get Int - rep Seq.empty n get - where rep xs 0 _ = return $! xs - rep xs n g = xs `seq` n `seq` do - x <- g - rep (xs Seq.|> x) (n-1) g - -#endif - ------------------------------------------------------------------------- --- Floating point - -instance Binary Double where - put d = put (decodeFloat d) - get = liftM2 encodeFloat get get - -instance Binary Float where - put f = put (decodeFloat f) - get = liftM2 encodeFloat get get - ------------------------------------------------------------------------- --- Trees - -instance (Binary e) => Binary (T.Tree e) where - put (T.Node r s) = put r >> put s - get = liftM2 T.Node get get - ------------------------------------------------------------------------- --- Arrays - -instance (Binary i, Ix i, Binary e) => Binary (Array i e) where - put a = do - put (bounds a) - put (rangeSize $ bounds a) -- write the length - mapM_ put (elems a) -- now the elems. - get = do - bs <- get - n <- get -- read the length - xs <- replicateM n get -- now the elems. - return (listArray bs xs) - --- --- The IArray UArray e constraint is non portable. Requires flexible instances --- -instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where - put a = do - put (bounds a) - put (rangeSize $ bounds a) -- now write the length - mapM_ put (elems a) - get = do - bs <- get - n <- get - xs <- replicateM n get - return (listArray bs xs) diff --git a/src/Data/Binary/Builder.hs b/src/Data/Binary/Builder.hs deleted file mode 100644 index cccbe6fa4..000000000 --- a/src/Data/Binary/Builder.hs +++ /dev/null @@ -1,426 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fglasgow-exts #-} --- for unboxed shifts - ------------------------------------------------------------------------------ --- | --- Module : Data.Binary.Builder --- Copyright : Lennart Kolmodin, Ross Paterson --- License : BSD3-style (see LICENSE) --- --- Maintainer : Lennart Kolmodin --- Stability : experimental --- Portability : portable to Hugs and GHC --- --- Efficient construction of lazy bytestrings. --- ------------------------------------------------------------------------------ - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -#include "MachDeps.h" -#endif - -module Data.Binary.Builder ( - - -- * The Builder type - Builder - , toLazyByteString - - -- * Constructing Builders - , empty - , singleton - , append - , fromByteString -- :: S.ByteString -> Builder - , fromLazyByteString -- :: L.ByteString -> Builder - - -- * Flushing the buffer state - , flush - - -- * Derived Builders - -- ** Big-endian writes - , putWord16be -- :: Word16 -> Builder - , putWord32be -- :: Word32 -> Builder - , putWord64be -- :: Word64 -> Builder - - -- ** Little-endian writes - , putWord16le -- :: Word16 -> Builder - , putWord32le -- :: Word32 -> Builder - , putWord64le -- :: Word64 -> Builder - - -- ** Host-endian, unaligned writes - , putWordhost -- :: Word -> Builder - , putWord16host -- :: Word16 -> Builder - , putWord32host -- :: Word32 -> Builder - , putWord64host -- :: Word64 -> Builder - - ) where - -import Foreign -import Data.Monoid -import Data.Word -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - -#ifdef BYTESTRING_IN_BASE -import Data.ByteString.Base (inlinePerformIO) -import qualified Data.ByteString.Base as S -#else -import Data.ByteString.Internal (inlinePerformIO) -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Lazy.Internal as L -#endif - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -import GHC.Base -import GHC.Word (Word32(..),Word16(..),Word64(..)) - -#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608 -import GHC.Word (uncheckedShiftRL64#) -#endif -#endif - ------------------------------------------------------------------------- - --- | A 'Builder' is an efficient way to build lazy 'L.ByteString's. --- There are several functions for constructing 'Builder's, but only one --- to inspect them: to extract any data, you have to turn them into lazy --- 'L.ByteString's using 'toLazyByteString'. --- --- Internally, a 'Builder' constructs a lazy 'L.Bytestring' by filling byte --- arrays piece by piece. As each buffer is filled, it is \'popped\' --- off, to become a new chunk of the resulting lazy 'L.ByteString'. --- All this is hidden from the user of the 'Builder'. - -newtype Builder = Builder { - -- Invariant (from Data.ByteString.Lazy): - -- The lists include no null ByteStrings. - runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString] - } - -instance Monoid Builder where - mempty = empty - {-# INLINE mempty #-} - mappend = append - {-# INLINE mappend #-} - ------------------------------------------------------------------------- - --- | /O(1)./ The empty Builder, satisfying --- --- * @'toLazyByteString' 'empty' = 'L.empty'@ --- -empty :: Builder -empty = Builder id -{-# INLINE empty #-} - --- | /O(1)./ A Builder taking a single byte, satisfying --- --- * @'toLazyByteString' ('singleton' b) = 'L.singleton' b@ --- -singleton :: Word8 -> Builder -singleton = writeN 1 . flip poke -{-# INLINE singleton #-} - ------------------------------------------------------------------------- - --- | /O(1)./ The concatenation of two Builders, an associative operation --- with identity 'empty', satisfying --- --- * @'toLazyByteString' ('append' x y) = 'L.append' ('toLazyByteString' x) ('toLazyByteString' y)@ --- -append :: Builder -> Builder -> Builder -append (Builder f) (Builder g) = Builder (f . g) -{-# INLINE append #-} - --- | /O(1)./ A Builder taking a 'S.ByteString', satisfying --- --- * @'toLazyByteString' ('fromByteString' bs) = 'L.fromChunks' [bs]@ --- -fromByteString :: S.ByteString -> Builder -fromByteString bs - | S.null bs = empty - | otherwise = flush `append` mapBuilder (bs :) -{-# INLINE fromByteString #-} - --- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying --- --- * @'toLazyByteString' ('fromLazyByteString' bs) = bs@ --- -fromLazyByteString :: L.ByteString -> Builder -fromLazyByteString bss = flush `append` mapBuilder (L.toChunks bss ++) -{-# INLINE fromLazyByteString #-} - ------------------------------------------------------------------------- - --- Our internal buffer type -data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) - {-# UNPACK #-} !Int -- offset - {-# UNPACK #-} !Int -- used bytes - {-# UNPACK #-} !Int -- length left - ------------------------------------------------------------------------- - --- | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'. --- The construction work takes place if and when the relevant part of --- the lazy 'L.ByteString' is demanded. --- -toLazyByteString :: Builder -> L.ByteString -toLazyByteString m = L.fromChunks $ unsafePerformIO $ do - buf <- newBuffer defaultSize - return (runBuilder (m `append` flush) (const []) buf) - --- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any, --- yielding a new chunk in the result lazy 'L.ByteString'. -flush :: Builder -flush = Builder $ \ k buf@(Buffer p o u l) -> - if u == 0 - then k buf - else S.PS p o u : k (Buffer p (o+u) 0 l) - ------------------------------------------------------------------------- - --- --- copied from Data.ByteString.Lazy --- -defaultSize :: Int -defaultSize = 32 * k - overhead - where k = 1024 - overhead = 2 * sizeOf (undefined :: Int) - ------------------------------------------------------------------------- - --- | Sequence an IO operation on the buffer -unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder -unsafeLiftIO f = Builder $ \ k buf -> inlinePerformIO $ do - buf' <- f buf - return (k buf') -{-# INLINE unsafeLiftIO #-} - --- | Get the size of the buffer -withSize :: (Int -> Builder) -> Builder -withSize f = Builder $ \ k buf@(Buffer _ _ _ l) -> - runBuilder (f l) k buf - --- | Map the resulting list of bytestrings. -mapBuilder :: ([S.ByteString] -> [S.ByteString]) -> Builder -mapBuilder f = Builder (f .) - ------------------------------------------------------------------------- - --- | Ensure that there are at least @n@ many bytes available. -ensureFree :: Int -> Builder -ensureFree n = n `seq` withSize $ \ l -> - if n <= l then empty else - flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize))) -{-# INLINE ensureFree #-} - --- | Ensure that @n@ many bytes are available, and then use @f@ to write some --- bytes into the memory. -writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder -writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f) -{-# INLINE writeN #-} - -writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer -writeNBuffer n f (Buffer fp o u l) = do - withForeignPtr fp (\p -> f (p `plusPtr` (o+u))) - return (Buffer fp o (u+n) (l-n)) -{-# INLINE writeNBuffer #-} - -newBuffer :: Int -> IO Buffer -newBuffer size = do - fp <- S.mallocByteString size - return $! Buffer fp 0 0 size -{-# INLINE newBuffer #-} - ------------------------------------------------------------------------- --- Aligned, host order writes of storable values - --- | Ensure that @n@ many bytes are available, and then use @f@ to write some --- storable values into the memory. -writeNbytes :: Storable a => Int -> (Ptr a -> IO ()) -> Builder -writeNbytes n f = ensureFree n `append` unsafeLiftIO (writeNBufferBytes n f) -{-# INLINE writeNbytes #-} - -writeNBufferBytes :: Storable a => Int -> (Ptr a -> IO ()) -> Buffer -> IO Buffer -writeNBufferBytes n f (Buffer fp o u l) = do - withForeignPtr fp (\p -> f (p `plusPtr` (o+u))) - return (Buffer fp o (u+n) (l-n)) -{-# INLINE writeNBufferBytes #-} - ------------------------------------------------------------------------- - --- --- We rely on the fromIntegral to do the right masking for us. --- The inlining here is critical, and can be worth 4x performance --- - --- | Write a Word16 in big endian format -putWord16be :: Word16 -> Builder -putWord16be w = writeN 2 $ \p -> do - poke p (fromIntegral (shiftr_w16 w 8) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (w) :: Word8) -{-# INLINE putWord16be #-} - --- | Write a Word16 in little endian format -putWord16le :: Word16 -> Builder -putWord16le w = writeN 2 $ \p -> do - poke p (fromIntegral (w) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8) -{-# INLINE putWord16le #-} - --- putWord16le w16 = writeN 2 (\p -> poke (castPtr p) w16) - --- | Write a Word32 in big endian format -putWord32be :: Word32 -> Builder -putWord32be w = writeN 4 $ \p -> do - poke p (fromIntegral (shiftr_w32 w 24) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (w) :: Word8) -{-# INLINE putWord32be #-} - --- --- a data type to tag Put/Check. writes construct these which are then --- inlined and flattened. matching Checks will be more robust with rules. --- - --- | Write a Word32 in little endian format -putWord32le :: Word32 -> Builder -putWord32le w = writeN 4 $ \p -> do - poke p (fromIntegral (w) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 w 24) :: Word8) -{-# INLINE putWord32le #-} - --- on a little endian machine: --- putWord32le w32 = writeN 4 (\p -> poke (castPtr p) w32) - --- | Write a Word64 in big endian format -putWord64be :: Word64 -> Builder -#if WORD_SIZE_IN_BITS < 64 --- --- To avoid expensive 64 bit shifts on 32 bit machines, we cast to --- Word32, and write that --- -putWord64be w = - let a = fromIntegral (shiftr_w64 w 32) :: Word32 - b = fromIntegral w :: Word32 - in writeN 8 $ \p -> do - poke p (fromIntegral (shiftr_w32 a 24) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (a) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (b) :: Word8) -#else -putWord64be w = writeN 8 $ \p -> do - poke p (fromIntegral (shiftr_w64 w 56) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 8) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (w) :: Word8) -#endif -{-# INLINE putWord64be #-} - --- | Write a Word64 in little endian format -putWord64le :: Word64 -> Builder - -#if WORD_SIZE_IN_BITS < 64 -putWord64le w = - let b = fromIntegral (shiftr_w64 w 32) :: Word32 - a = fromIntegral w :: Word32 - in writeN 8 $ \p -> do - poke (p) (fromIntegral (a) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 8) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (b) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 8) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8) -#else -putWord64le w = writeN 8 $ \p -> do - poke p (fromIntegral (w) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8) - poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8) - poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 24) :: Word8) - poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 32) :: Word8) - poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 40) :: Word8) - poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 48) :: Word8) - poke (p `plusPtr` 7) (fromIntegral (shiftr_w64 w 56) :: Word8) -#endif -{-# INLINE putWord64le #-} - --- on a little endian machine: --- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64) - ------------------------------------------------------------------------- --- Unaligned, word size ops - --- | /O(1)./ A Builder taking a single native machine word. The word is --- written in host order, host endian form, for the machine you're on. --- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine, --- 4 bytes. Values written this way are not portable to --- different endian or word sized machines, without conversion. --- -putWordhost :: Word -> Builder -putWordhost w = writeNbytes (sizeOf (undefined :: Word)) (\p -> poke p w) -{-# INLINE putWordhost #-} - --- | Write a Word16 in native host order and host endianness. --- 2 bytes will be written, unaligned. -putWord16host :: Word16 -> Builder -putWord16host w16 = writeNbytes (sizeOf (undefined :: Word16)) (\p -> poke p w16) -{-# INLINE putWord16host #-} - --- | Write a Word32 in native host order and host endianness. --- 4 bytes will be written, unaligned. -putWord32host :: Word32 -> Builder -putWord32host w32 = writeNbytes (sizeOf (undefined :: Word32)) (\p -> poke p w32) -{-# INLINE putWord32host #-} - --- | Write a Word64 in native host order. --- On a 32 bit machine we write two host order Word32s, in big endian form. --- 8 bytes will be written, unaligned. -putWord64host :: Word64 -> Builder -putWord64host w = writeNbytes (sizeOf (undefined :: Word64)) (\p -> poke p w) -{-# INLINE putWord64host #-} - ------------------------------------------------------------------------- --- Unchecked shifts - -{-# INLINE shiftr_w16 #-} -shiftr_w16 :: Word16 -> Int -> Word16 -{-# INLINE shiftr_w32 #-} -shiftr_w32 :: Word32 -> Int -> Word32 -{-# INLINE shiftr_w64 #-} -shiftr_w64 :: Word64 -> Int -> Word64 - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i) -shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) - -#if WORD_SIZE_IN_BITS < 64 -shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i) - -#if __GLASGOW_HASKELL__ <= 606 --- Exported by GHC.Word in GHC 6.8 and higher -foreign import ccall unsafe "stg_uncheckedShiftRL64" - uncheckedShiftRL64# :: Word64# -> Int# -> Word64# -#endif - -#else -shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i) -#endif - -#else -shiftr_w16 = shiftR -shiftr_w32 = shiftR -shiftr_w64 = shiftR -#endif diff --git a/src/Data/Binary/Get.hs b/src/Data/Binary/Get.hs deleted file mode 100644 index 51062ad31..000000000 --- a/src/Data/Binary/Get.hs +++ /dev/null @@ -1,544 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fglasgow-exts #-} --- for unboxed shifts - ------------------------------------------------------------------------------ --- | --- Module : Data.Binary.Get --- Copyright : Lennart Kolmodin --- License : BSD3-style (see LICENSE) --- --- Maintainer : Lennart Kolmodin --- Stability : experimental --- Portability : portable to Hugs and GHC. --- --- The Get monad. A monad for efficiently building structures from --- encoded lazy ByteStrings --- ------------------------------------------------------------------------------ - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -#include "MachDeps.h" -#endif - -module Data.Binary.Get ( - - -- * The Get type - Get - , runGet - , runGetState - - -- * Parsing - , skip - , uncheckedSkip - , lookAhead - , lookAheadM - , lookAheadE - , uncheckedLookAhead - - -- * Utility - , bytesRead - , getBytes - , remaining - , isEmpty - - -- * Parsing particular types - , getWord8 - - -- ** ByteStrings - , getByteString - , getLazyByteString - , getLazyByteStringNul - , getRemainingLazyByteString - - -- ** Big-endian reads - , getWord16be - , getWord32be - , getWord64be - - -- ** Little-endian reads - , getWord16le - , getWord32le - , getWord64le - - -- ** Host-endian, unaligned reads - , getWordhost - , getWord16host - , getWord32host - , getWord64host - - ) where - -import Control.Monad (when,liftM,ap) -import Control.Monad.Fix -import Data.Maybe (isNothing) - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L - -#ifdef BYTESTRING_IN_BASE -import qualified Data.ByteString.Base as B -#else -import qualified Data.ByteString.Internal as B -import qualified Data.ByteString.Lazy.Internal as L -#endif - -#ifdef APPLICATIVE_IN_BASE -import Control.Applicative (Applicative(..)) -#endif - -import Foreign - --- used by splitAtST -import Control.Monad.ST -import Data.STRef - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -import GHC.Base -import GHC.Word -import GHC.Int -#endif - --- | The parse state -data S = S {-# UNPACK #-} !B.ByteString -- current chunk - L.ByteString -- the rest of the input - {-# UNPACK #-} !Int64 -- bytes read - --- | The Get monad is just a State monad carrying around the input ByteString -newtype Get a = Get { unGet :: S -> (a, S) } - -instance Functor Get where - fmap f m = Get (\s -> case unGet m s of - (a, s') -> (f a, s')) - {-# INLINE fmap #-} - -#ifdef APPLICATIVE_IN_BASE -instance Applicative Get where - pure = return - (<*>) = ap -#endif - -instance Monad Get where - return a = Get (\s -> (a, s)) - {-# INLINE return #-} - - m >>= k = Get (\s -> case unGet m s of - (a, s') -> unGet (k a) s') - {-# INLINE (>>=) #-} - - fail = failDesc - -instance MonadFix Get where - mfix f = Get (\s -> let (a,s') = unGet (f a) s - in (a,s')) - ------------------------------------------------------------------------- - -get :: Get S -get = Get (\s -> (s, s)) - -put :: S -> Get () -put s = Get (\_ -> ((), s)) - ------------------------------------------------------------------------- --- --- dons, GHC 6.10: explicit inlining disabled, was killing performance. --- Without it, GHC seems to do just fine. And we get similar --- performance with 6.8.2 anyway. --- - -initState :: L.ByteString -> S -initState xs = mkState xs 0 -{- INLINE initState -} - -{- -initState (B.LPS xs) = - case xs of - [] -> S B.empty L.empty 0 - (x:xs') -> S x (B.LPS xs') 0 --} - -#ifndef BYTESTRING_IN_BASE -mkState :: L.ByteString -> Int64 -> S -mkState l = case l of - L.Empty -> S B.empty L.empty - L.Chunk x xs -> S x xs -{- INLINE mkState -} - -#else -mkState :: L.ByteString -> Int64 -> S -mkState (B.LPS xs) = - case xs of - [] -> S B.empty L.empty - (x:xs') -> S x (B.LPS xs') -#endif - --- | Run the Get monad applies a 'get'-based parser on the input ByteString -runGet :: Get a -> L.ByteString -> a -runGet m str = case unGet m (initState str) of (a, _) -> a - --- | Run the Get monad applies a 'get'-based parser on the input --- ByteString. Additional to the result of get it returns the number of --- consumed bytes and the rest of the input. -runGetState :: Get a -> L.ByteString -> Int64 -> (a, L.ByteString, Int64) -runGetState m str off = - case unGet m (mkState str off) of - (a, ~(S s ss newOff)) -> (a, s `join` ss, newOff) - ------------------------------------------------------------------------- - -failDesc :: String -> Get a -failDesc err = do - S _ _ bytes <- get - Get (error (err ++ ". Failed reading at byte position " ++ show bytes)) - --- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. -skip :: Int -> Get () -skip n = readN (fromIntegral n) (const ()) - --- | Skip ahead @n@ bytes. No error if there isn't enough bytes. -uncheckedSkip :: Int64 -> Get () -uncheckedSkip n = do - S s ss bytes <- get - if fromIntegral (B.length s) >= n - then put (S (B.drop (fromIntegral n) s) ss (bytes + n)) - else do - let rest = L.drop (n - fromIntegral (B.length s)) ss - put $! mkState rest (bytes + n) - --- | Run @ga@, but return without consuming its input. --- Fails if @ga@ fails. -lookAhead :: Get a -> Get a -lookAhead ga = do - s <- get - a <- ga - put s - return a - --- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'. --- Fails if @gma@ fails. -lookAheadM :: Get (Maybe a) -> Get (Maybe a) -lookAheadM gma = do - s <- get - ma <- gma - when (isNothing ma) $ - put s - return ma - --- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'. --- Fails if @gea@ fails. -lookAheadE :: Get (Either a b) -> Get (Either a b) -lookAheadE gea = do - s <- get - ea <- gea - case ea of - Left _ -> put s - _ -> return () - return ea - --- | Get the next up to @n@ bytes as a lazy ByteString, without consuming them. -uncheckedLookAhead :: Int64 -> Get L.ByteString -uncheckedLookAhead n = do - S s ss _ <- get - if n <= fromIntegral (B.length s) - then return (L.fromChunks [B.take (fromIntegral n) s]) - else return $ L.take n (s `join` ss) - ------------------------------------------------------------------------- --- Utility - --- | Get the total number of bytes read to this point. -bytesRead :: Get Int64 -bytesRead = do - S _ _ b <- get - return b - --- | Get the number of remaining unparsed bytes. --- Useful for checking whether all input has been consumed. --- Note that this forces the rest of the input. -remaining :: Get Int64 -remaining = do - S s ss _ <- get - return (fromIntegral (B.length s) + L.length ss) - --- | Test whether all input has been consumed, --- i.e. there are no remaining unparsed bytes. -isEmpty :: Get Bool -isEmpty = do - S s ss _ <- get - return (B.null s && L.null ss) - ------------------------------------------------------------------------- --- Utility with ByteStrings - --- | An efficient 'get' method for strict ByteStrings. Fails if fewer --- than @n@ bytes are left in the input. -getByteString :: Int -> Get B.ByteString -getByteString n = readN n id -{-# INLINE getByteString #-} - --- | An efficient 'get' method for lazy ByteStrings. Does not fail if fewer than --- @n@ bytes are left in the input. -getLazyByteString :: Int64 -> Get L.ByteString -getLazyByteString n = do - S s ss bytes <- get - let big = s `join` ss - case splitAtST n big of - (consume, rest) -> do put $ mkState rest (bytes + n) - return consume -{-# INLINE getLazyByteString #-} - --- | Get a lazy ByteString that is terminated with a NUL byte. Fails --- if it reaches the end of input without hitting a NUL. -getLazyByteStringNul :: Get L.ByteString -getLazyByteStringNul = do - S s ss bytes <- get - let big = s `join` ss - (consume, t) = L.break (== 0) big - (h, rest) = L.splitAt 1 t - if L.null h - then fail "too few bytes" - else do - put $ mkState rest (bytes + L.length consume + 1) - return consume -{-# INLINE getLazyByteStringNul #-} - --- | Get the remaining bytes as a lazy ByteString -getRemainingLazyByteString :: Get L.ByteString -getRemainingLazyByteString = do - S s ss _ <- get - return (s `join` ss) - ------------------------------------------------------------------------- --- Helpers - --- | Pull @n@ bytes from the input, as a strict ByteString. -getBytes :: Int -> Get B.ByteString -getBytes n = do - S s ss bytes <- get - if n <= B.length s - then do let (consume,rest) = B.splitAt n s - put $! S rest ss (bytes + fromIntegral n) - return $! consume - else - case L.splitAt (fromIntegral n) (s `join` ss) of - (consuming, rest) -> - do let now = B.concat . L.toChunks $ consuming - put $! mkState rest (bytes + fromIntegral n) - -- forces the next chunk before this one is returned - if (B.length now < n) - then - fail "too few bytes" - else - return now -{- INLINE getBytes -} --- ^ important - -#ifndef BYTESTRING_IN_BASE -join :: B.ByteString -> L.ByteString -> L.ByteString -join bb lb - | B.null bb = lb - | otherwise = L.Chunk bb lb - -#else -join :: B.ByteString -> L.ByteString -> L.ByteString -join bb (B.LPS lb) - | B.null bb = B.LPS lb - | otherwise = B.LPS (bb:lb) -#endif - -- don't use L.append, it's strict in it's second argument :/ -{- INLINE join -} - --- | Split a ByteString. If the first result is consumed before the -- --- second, this runs in constant heap space. --- --- You must force the returned tuple for that to work, e.g. --- --- > case splitAtST n xs of --- > (ys,zs) -> consume ys ... consume zs --- -splitAtST :: Int64 -> L.ByteString -> (L.ByteString, L.ByteString) -splitAtST i ps | i <= 0 = (L.empty, ps) -#ifndef BYTESTRING_IN_BASE -splitAtST i ps = runST ( - do r <- newSTRef undefined - xs <- first r i ps - ys <- unsafeInterleaveST (readSTRef r) - return (xs, ys)) - - where - first r 0 xs@(L.Chunk _ _) = writeSTRef r xs >> return L.Empty - first r _ L.Empty = writeSTRef r L.Empty >> return L.Empty - - first r n (L.Chunk x xs) - | n < l = do writeSTRef r (L.Chunk (B.drop (fromIntegral n) x) xs) - return $ L.Chunk (B.take (fromIntegral n) x) L.Empty - | otherwise = do writeSTRef r (L.drop (n - l) xs) - liftM (L.Chunk x) $ unsafeInterleaveST (first r (n - l) xs) - - where l = fromIntegral (B.length x) -#else -splitAtST i (B.LPS ps) = runST ( - do r <- newSTRef undefined - xs <- first r i ps - ys <- unsafeInterleaveST (readSTRef r) - return (B.LPS xs, B.LPS ys)) - - where first r 0 xs = writeSTRef r xs >> return [] - first r _ [] = writeSTRef r [] >> return [] - first r n (x:xs) - | n < l = do writeSTRef r (B.drop (fromIntegral n) x : xs) - return [B.take (fromIntegral n) x] - | otherwise = do writeSTRef r (L.toChunks (L.drop (n - l) (B.LPS xs))) - fmap (x:) $ unsafeInterleaveST (first r (n - l) xs) - - where l = fromIntegral (B.length x) -#endif -{- INLINE splitAtST -} - --- Pull n bytes from the input, and apply a parser to those bytes, --- yielding a value. If less than @n@ bytes are available, fail with an --- error. This wraps @getBytes@. -readN :: Int -> (B.ByteString -> a) -> Get a -readN n f = fmap f $ getBytes n -{- INLINE readN -} --- ^ important - ------------------------------------------------------------------------- --- Primtives - --- helper, get a raw Ptr onto a strict ByteString copied out of the --- underlying lazy byteString. So many indirections from the raw parser --- state that my head hurts... - -getPtr :: Storable a => Int -> Get a -getPtr n = do - (fp,o,_) <- readN n B.toForeignPtr - return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o) -{- INLINE getPtr -} - ------------------------------------------------------------------------- - --- | Read a Word8 from the monad state -getWord8 :: Get Word8 -getWord8 = getPtr (sizeOf (undefined :: Word8)) -{- INLINE getWord8 -} - --- | Read a Word16 in big endian format -getWord16be :: Get Word16 -getWord16be = do - s <- readN 2 id - return $! (fromIntegral (s `B.index` 0) `shiftl_w16` 8) .|. - (fromIntegral (s `B.index` 1)) -{- INLINE getWord16be -} - --- | Read a Word16 in little endian format -getWord16le :: Get Word16 -getWord16le = do - s <- readN 2 id - return $! (fromIntegral (s `B.index` 1) `shiftl_w16` 8) .|. - (fromIntegral (s `B.index` 0) ) -{- INLINE getWord16le -} - --- | Read a Word32 in big endian format -getWord32be :: Get Word32 -getWord32be = do - s <- readN 4 id - return $! (fromIntegral (s `B.index` 0) `shiftl_w32` 24) .|. - (fromIntegral (s `B.index` 1) `shiftl_w32` 16) .|. - (fromIntegral (s `B.index` 2) `shiftl_w32` 8) .|. - (fromIntegral (s `B.index` 3) ) -{- INLINE getWord32be -} - --- | Read a Word32 in little endian format -getWord32le :: Get Word32 -getWord32le = do - s <- readN 4 id - return $! (fromIntegral (s `B.index` 3) `shiftl_w32` 24) .|. - (fromIntegral (s `B.index` 2) `shiftl_w32` 16) .|. - (fromIntegral (s `B.index` 1) `shiftl_w32` 8) .|. - (fromIntegral (s `B.index` 0) ) -{- INLINE getWord32le -} - --- | Read a Word64 in big endian format -getWord64be :: Get Word64 -getWord64be = do - s <- readN 8 id - return $! (fromIntegral (s `B.index` 0) `shiftl_w64` 56) .|. - (fromIntegral (s `B.index` 1) `shiftl_w64` 48) .|. - (fromIntegral (s `B.index` 2) `shiftl_w64` 40) .|. - (fromIntegral (s `B.index` 3) `shiftl_w64` 32) .|. - (fromIntegral (s `B.index` 4) `shiftl_w64` 24) .|. - (fromIntegral (s `B.index` 5) `shiftl_w64` 16) .|. - (fromIntegral (s `B.index` 6) `shiftl_w64` 8) .|. - (fromIntegral (s `B.index` 7) ) -{- INLINE getWord64be -} - --- | Read a Word64 in little endian format -getWord64le :: Get Word64 -getWord64le = do - s <- readN 8 id - return $! (fromIntegral (s `B.index` 7) `shiftl_w64` 56) .|. - (fromIntegral (s `B.index` 6) `shiftl_w64` 48) .|. - (fromIntegral (s `B.index` 5) `shiftl_w64` 40) .|. - (fromIntegral (s `B.index` 4) `shiftl_w64` 32) .|. - (fromIntegral (s `B.index` 3) `shiftl_w64` 24) .|. - (fromIntegral (s `B.index` 2) `shiftl_w64` 16) .|. - (fromIntegral (s `B.index` 1) `shiftl_w64` 8) .|. - (fromIntegral (s `B.index` 0) ) -{- INLINE getWord64le -} - ------------------------------------------------------------------------- --- Host-endian reads - --- | /O(1)./ Read a single native machine word. The word is read in --- host order, host endian form, for the machine you're on. On a 64 bit --- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes. -getWordhost :: Get Word -getWordhost = getPtr (sizeOf (undefined :: Word)) -{- INLINE getWordhost -} - --- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness. -getWord16host :: Get Word16 -getWord16host = getPtr (sizeOf (undefined :: Word16)) -{- INLINE getWord16host -} - --- | /O(1)./ Read a Word32 in native host order and host endianness. -getWord32host :: Get Word32 -getWord32host = getPtr (sizeOf (undefined :: Word32)) -{- INLINE getWord32host -} - --- | /O(1)./ Read a Word64 in native host order and host endianess. -getWord64host :: Get Word64 -getWord64host = getPtr (sizeOf (undefined :: Word64)) -{- INLINE getWord64host -} - ------------------------------------------------------------------------- --- Unchecked shifts - -shiftl_w16 :: Word16 -> Int -> Word16 -shiftl_w32 :: Word32 -> Int -> Word32 -shiftl_w64 :: Word64 -> Int -> Word64 - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i) -shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i) - -#if WORD_SIZE_IN_BITS < 64 -shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i) - -#if __GLASGOW_HASKELL__ <= 606 --- Exported by GHC.Word in GHC 6.8 and higher -foreign import ccall unsafe "stg_uncheckedShiftL64" - uncheckedShiftL64# :: Word64# -> Int# -> Word64# -#endif - -#else -shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i) -#endif - -#else -shiftl_w16 = shiftL -shiftl_w32 = shiftL -shiftl_w64 = shiftL -#endif diff --git a/src/Data/Binary/Put.hs b/src/Data/Binary/Put.hs deleted file mode 100644 index a1f78dfba..000000000 --- a/src/Data/Binary/Put.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Binary.Put --- Copyright : Lennart Kolmodin --- License : BSD3-style (see LICENSE) --- --- Maintainer : Lennart Kolmodin --- Stability : stable --- Portability : Portable to Hugs and GHC. Requires MPTCs --- --- The Put monad. A monad for efficiently constructing lazy bytestrings. --- ------------------------------------------------------------------------------ - -module Data.Binary.Put ( - - -- * The Put type - Put - , PutM(..) - , runPut - , runPutM - , putBuilder - , execPut - - -- * Flushing the implicit parse state - , flush - - -- * Primitives - , putWord8 - , putByteString - , putLazyByteString - - -- * Big-endian primitives - , putWord16be - , putWord32be - , putWord64be - - -- * Little-endian primitives - , putWord16le - , putWord32le - , putWord64le - - -- * Host-endian, unaligned writes - , putWordhost -- :: Word -> Put - , putWord16host -- :: Word16 -> Put - , putWord32host -- :: Word32 -> Put - , putWord64host -- :: Word64 -> Put - - ) where - -import Data.Monoid -import Data.Binary.Builder (Builder, toLazyByteString) -import qualified Data.Binary.Builder as B - -import Data.Word -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - -#ifdef APPLICATIVE_IN_BASE -import Control.Applicative -#endif - - ------------------------------------------------------------------------- - --- XXX Strict in buffer only. -data PairS a = PairS a {-# UNPACK #-}!Builder - -sndS :: PairS a -> Builder -sndS (PairS _ b) = b - --- | The PutM type. A Writer monad over the efficient Builder monoid. -newtype PutM a = Put { unPut :: PairS a } - --- | Put merely lifts Builder into a Writer monad, applied to (). -type Put = PutM () - -instance Functor PutM where - fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w - {-# INLINE fmap #-} - -#ifdef APPLICATIVE_IN_BASE -instance Applicative PutM where - pure = return - m <*> k = Put $ - let PairS f w = unPut m - PairS x w' = unPut k - in PairS (f x) (w `mappend` w') -#endif - --- Standard Writer monad, with aggressive inlining -instance Monad PutM where - return a = Put $ PairS a mempty - {-# INLINE return #-} - - m >>= k = Put $ - let PairS a w = unPut m - PairS b w' = unPut (k a) - in PairS b (w `mappend` w') - {-# INLINE (>>=) #-} - - m >> k = Put $ - let PairS _ w = unPut m - PairS b w' = unPut k - in PairS b (w `mappend` w') - {-# INLINE (>>) #-} - -tell :: Builder -> Put -tell b = Put $ PairS () b -{-# INLINE tell #-} - -putBuilder :: Builder -> Put -putBuilder = tell -{-# INLINE putBuilder #-} - --- | Run the 'Put' monad -execPut :: PutM a -> Builder -execPut = sndS . unPut -{-# INLINE execPut #-} - --- | Run the 'Put' monad with a serialiser -runPut :: Put -> L.ByteString -runPut = toLazyByteString . sndS . unPut -{-# INLINE runPut #-} - --- | Run the 'Put' monad with a serialiser and get its result -runPutM :: PutM a -> (a, L.ByteString) -runPutM (Put (PairS f s)) = (f, toLazyByteString s) -{-# INLINE runPutM #-} - ------------------------------------------------------------------------- - --- | Pop the ByteString we have constructed so far, if any, yielding a --- new chunk in the result ByteString. -flush :: Put -flush = tell B.flush -{-# INLINE flush #-} - --- | Efficiently write a byte into the output buffer -putWord8 :: Word8 -> Put -putWord8 = tell . B.singleton -{-# INLINE putWord8 #-} - --- | An efficient primitive to write a strict ByteString into the output buffer. --- It flushes the current buffer, and writes the argument into a new chunk. -putByteString :: S.ByteString -> Put -putByteString = tell . B.fromByteString -{-# INLINE putByteString #-} - --- | Write a lazy ByteString efficiently, simply appending the lazy --- ByteString chunks to the output buffer -putLazyByteString :: L.ByteString -> Put -putLazyByteString = tell . B.fromLazyByteString -{-# INLINE putLazyByteString #-} - --- | Write a Word16 in big endian format -putWord16be :: Word16 -> Put -putWord16be = tell . B.putWord16be -{-# INLINE putWord16be #-} - --- | Write a Word16 in little endian format -putWord16le :: Word16 -> Put -putWord16le = tell . B.putWord16le -{-# INLINE putWord16le #-} - --- | Write a Word32 in big endian format -putWord32be :: Word32 -> Put -putWord32be = tell . B.putWord32be -{-# INLINE putWord32be #-} - --- | Write a Word32 in little endian format -putWord32le :: Word32 -> Put -putWord32le = tell . B.putWord32le -{-# INLINE putWord32le #-} - --- | Write a Word64 in big endian format -putWord64be :: Word64 -> Put -putWord64be = tell . B.putWord64be -{-# INLINE putWord64be #-} - --- | Write a Word64 in little endian format -putWord64le :: Word64 -> Put -putWord64le = tell . B.putWord64le -{-# INLINE putWord64le #-} - ------------------------------------------------------------------------- - --- | /O(1)./ Write a single native machine word. The word is --- written in host order, host endian form, for the machine you're on. --- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine, --- 4 bytes. Values written this way are not portable to --- different endian or word sized machines, without conversion. --- -putWordhost :: Word -> Put -putWordhost = tell . B.putWordhost -{-# INLINE putWordhost #-} - --- | /O(1)./ Write a Word16 in native host order and host endianness. --- For portability issues see @putWordhost@. -putWord16host :: Word16 -> Put -putWord16host = tell . B.putWord16host -{-# INLINE putWord16host #-} - --- | /O(1)./ Write a Word32 in native host order and host endianness. --- For portability issues see @putWordhost@. -putWord32host :: Word32 -> Put -putWord32host = tell . B.putWord32host -{-# INLINE putWord32host #-} - --- | /O(1)./ Write a Word64 in native host order --- On a 32 bit machine we write two host order Word32s, in big endian form. --- For portability issues see @putWordhost@. -putWord64host :: Word64 -> Put -putWord64host = tell . B.putWord64host -{-# INLINE putWord64host #-} diff --git a/src/FILES b/src/FILES deleted file mode 100644 index 1311108b6..000000000 --- a/src/FILES +++ /dev/null @@ -1,260 +0,0 @@ - -Code map for GF source files. - -$Author: peb $ -$Date: 2005/02/07 10:58:08 $ - -Directories: - -[top level] GF main function and runtime-related modules -api high-level access to GF functionalities -canonical GFC (= GF Canonical) basic functionalities -cf context-free skeleton used in parsing -cfgm multilingual context-free skeleton exported to Java -compile compilation phases from GF to GFC -conversions [OBSOLETE] formats used in parser generation -for-ghc GHC-specific files (Glasgow Haskell Compiler) -for-hugs Hugs-specific files (a Haskell interpreter) -for-windows Windows-specific files (an operating system from Microsoft) -grammar basic functionalities of GF grammars used in compilation -infra GF-independent infrastructure and auxiliaries -newparsing parsing with GF grammars: current version (cf. parsing) -notrace debugging utilities for parser development (cf. trace) -parsers parsers of GF and GFC files -parsing [OBSOLETE] parsing with GF grammars: old version (cf. newparsing) -shell interaction shells -source utilities for reading in GF source files -speech generation of speech recognition grammars -trace debugging utilities for parser development (cf. notrace) -useGrammar grammar functionalities for applications -util utilities for using GF - - -Individual files: - -GF.hs the Main module -GFModes.hs -HelpFile.hs [AUTO] help file generated by util/MkHelpFile -Today.hs [AUTO] file generated by "make today" - -api/API.hs high-level access to GF functionalities -api/BatchTranslate.hs -api/GetMyTree.hs -api/GrammarToHaskell.hs -api/IOGrammar.hs -api/MyParser.hs slot for defining your own parser - -canonical/AbsGFC.hs [AUTO] abstract syntax of GFC -canonical/CanonToGrammar.hs -canonical/CMacros.hs -canonical/ErrM.hs -canonical/GetGFC.hs -canonical/GFC.cf [LBNF] source of GFC parser -canonical/GFC.hs -canonical/LexGFC.hs -canonical/Look.hs -canonical/MkGFC.hs -canonical/PrExp.hs -canonical/PrintGFC.hs pretty-printer of GFC -canonical/Share.hs -canonical/SkelGFC.hs [AUTO] -canonical/TestGFC.hs [AUTO] -canonical/Unlex.hs - -cf/CanonToCF.hs -cf/CF.hs abstract syntax of context-free grammars -cf/CFIdent.hs -cf/CFtoGrammar.hs -cf/CFtoSRG.hs -cf/ChartParser.hs the current default parsing method -cf/EBNF.hs -cf/PPrCF.hs -cf/PrLBNF.hs -cf/Profile.hs - -cfgm/CFG.cf [LBNF] source -cfgm/AbsCFG.hs [AUTO] -cfgm/LexCFG.hs [AUTO] -cfgm/ParCFG.hs [AUTO] -cfgm/PrintCFG.hs [AUTO] -cfgm/PrintCFGrammar.hs - -compile/CheckGrammar.hs -compile/Compile.hs the complete compiler pipeline -compile/Extend.hs -compile/GetGrammar.hs -compile/GrammarToCanon.hs -compile/MkResource.hs -compile/MkUnion.hs -compile/ModDeps.hs -compile/Optimize.hs -compile/PGrammar.hs -compile/PrOld.hs -compile/Rebuild.hs -compile/RemoveLiT.hs -compile/Rename.hs -compile/ShellState.hs the run-time multilingual grammar datastructure -compile/Update.hs - -for-ghc/ArchEdit.hs -for-ghc/Arch.hs - -for-ghc-nofud/ArchEdit.hs@ -for-ghc-nofud/Arch.hs@ - -for-hugs/ArchEdit.hs -for-hugs/Arch.hs -for-hugs/JGF.hs -for-hugs/MoreCustom.hs -for-hugs/Unicode.hs - -for-hugs/Arch.hs -for-hugs/ArchEdit.hs -for-hugs/JGF.hs -for-hugs/LexCFG.hs dummy CFG lexer -for-hugs/LexGF.hs dummy GF lexer -for-hugs/LexGFC.hs dummy GFC lexer -for-hugs/MoreCustom.hs -for-hugs/ParCFG.hs dummy CFG parser -for-hugs/ParGFC.hs dummy GFC parser -for-hugs/ParGF.hs dummy GF parser -for-hugs/Tracing.hs -for-hugs/Unicode.hs - -for-windows/ArchEdit.hs -for-windows/Arch.hs - -grammar/AbsCompute.hs -grammar/Abstract.hs GF and GFC abstract syntax datatypes -grammar/AppPredefined.hs -grammar/Compute.hs -grammar/Grammar.hs GF source grammar datatypes -grammar/LookAbs.hs -grammar/Lookup.hs -grammar/Macros.hs macros for creating GF terms and types -grammar/MMacros.hs more macros, mainly for abstract syntax -grammar/PatternMatch.hs -grammar/PrGrammar.hs the top-level grammar printer -grammar/Refresh.hs -grammar/ReservedWords.hs -grammar/TC.hs Coquand's type checking engine -grammar/TypeCheck.hs -grammar/Unify.hs -grammar/Values.hs - -infra/Arabic.hs ASCII coding of Arabic Unicode -infra/Assoc.hs finite maps/association lists as binary search trees -infra/CheckM.hs -infra/Comments.hs -infra/Devanagari.hs ASCII coding of Devanagari Unicode -infra/ErrM.hs -infra/Ethiopic.hs -infra/EventF.hs -infra/ExtendedArabic.hs -infra/ExtraDiacritics.hs -infra/FudgetOps.hs -infra/Glue.hs -infra/Greek.hs -infra/Hebrew.hs -infra/Hiragana.hs -infra/Ident.hs -infra/LatinASupplement.hs -infra/Map.hs finite maps as red black trees -infra/Modules.hs -infra/OCSCyrillic.hs -infra/Operations.hs library of strings, search trees, error monads -infra/Option.hs -infra/OrdMap2.hs abstract class of finite maps + implementation as association lists -infra/OrdSet.hs abstract class of sets + implementation as sorted lists -infra/Parsers.hs -infra/ReadFiles.hs -infra/RedBlack.hs red black trees -infra/RedBlackSet.hs sets and maps as red black trees -infra/Russian.hs -infra/SortedList.hs sets as sorted lists -infra/Str.hs -infra/Tamil.hs -infra/Text.hs -infra/Trie2.hs -infra/Trie.hs -infra/UnicodeF.hs -infra/Unicode.hs -infra/UseIO.hs -infra/UTF8.hs UTF3 en/decoding -infra/Zipper.hs - -newparsing/CFGrammar.hs type definitions for context-free grammars -newparsing/CFParserGeneral.hs several variants of general CFG chart parsing -newparsing/CFParserIncremental.hs several variants of incremental (Earley-style) CFG chart parsing -newparsing/ConvertGFCtoMCFG.hs converting GFC to MCFG -newparsing/ConvertGrammar.hs conversions between different grammar formats -newparsing/ConvertMCFGtoCFG.hs converting MCFG to CFG -newparsing/GeneralChart.hs Haskell framework for "parsing as deduction" -newparsing/GrammarTypes.hs instantiations of grammar types -newparsing/IncrementalChart.hs Haskell framework for incremental chart parsing -newparsing/MCFGrammar.hs type definitions for multiple CFG -newparsing/MCFParserBasic.hs MCFG chart parser -newparsing/MCFRange.hs ranges for MCFG parsing -newparsing/ParseCFG.hs parsing of CFG -newparsing/ParseCF.hs parsing of the CF format -newparsing/ParseGFC.hs parsing of GFC -newparsing/ParseMCFG.hs parsing of MCFG -newparsing/Parser.hs general definitions for parsers -newparsing/PrintParser.hs pretty-printing class for parsers -newparsing/PrintSimplifiedTerm.hs simplified pretty-printing for GFC terms - -notrace/Tracing.hs tracing predicates when we DON'T want tracing capabilities (normal case) - -parsers/ParGFC.hs [AUTO] -parsers/ParGF.hs [AUTO] - -shell/CommandF.hs -shell/CommandL.hs line-based syntax of editor commands -shell/Commands.hs commands of GF editor shell -shell/IDE.hs -shell/JGF.hs -shell/PShell.hs -shell/ShellCommands.hs commands of GF main shell -shell/Shell.hs -shell/SubShell.hs -shell/TeachYourself.hs - -source/AbsGF.hs [AUTO] -source/ErrM.hs -source/GF.cf [LBNF] source of GF parser -source/GrammarToSource.hs -source/LexGF.hs [AUTO] -source/PrintGF.hs [AUTO] -source/SourceToGrammar.hs - -speech/PrGSL.hs -speech/PrJSGF.hs -speech/SRG.hs -speech/TransformCFG.hs - -trace/Tracing.hs tracing predicates when we want tracing capabilities - -translate/GFT.hs Main module of html-producing batch translator - -useGrammar/Custom.hs database for customizable commands -useGrammar/Editing.hs -useGrammar/Generate.hs -useGrammar/GetTree.hs -useGrammar/Information.hs -useGrammar/Linear.hs the linearization algorithm -useGrammar/MoreCustom.hs -useGrammar/Morphology.hs -useGrammar/Paraphrases.hs -useGrammar/Parsing.hs the top-level parsing algorithm -useGrammar/Randomized.hs -useGrammar/RealMoreCustom.hs -useGrammar/Session.hs -useGrammar/TeachYourself.hs -useGrammar/Tokenize.hs lexer definitions (listed in Custom) -useGrammar/Transfer.hs - -util/GFDoc.hs utility for producing LaTeX and HTML from GF -util/HelpFile source of ../HelpFile.hs -util/Htmls.hs utility for chopping a HTML document to slides -util/MkHelpFile.hs -util/WriteF.hs diff --git a/src/GF.hs b/src/GF.hs deleted file mode 100644 index 32a95ca1f..000000000 --- a/src/GF.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# OPTIONS -cpp #-} -module Main where - -import GFC -import GFI -import GF.Data.ErrM -import GF.Infra.Option -import GF.Infra.UseIO -import Paths_gf - -import Data.Version -import System.Directory -import System.Environment (getArgs) -import System.Exit -import System.IO -#ifdef mingw32_HOST_OS -import System.Win32.Console -import System.Win32.NLS -#endif - -main :: IO () -main = do -#ifdef mingw32_HOST_OS - codepage <- getACP - setConsoleCP codepage - setConsoleOutputCP codepage -#endif - args <- getArgs - case parseOptions args of - Ok (opts,files) -> do curr_dir <- getCurrentDirectory - lib_dir <- getLibraryDirectory opts - mainOpts (fixRelativeLibPaths curr_dir lib_dir opts) files - Bad err -> do hPutStrLn stderr err - hPutStrLn stderr "You may want to try --help." - exitFailure - -mainOpts :: Options -> [FilePath] -> IO () -mainOpts opts files = - case flag optMode opts of - ModeVersion -> putStrLn $ "Grammatical Framework (GF) version " ++ showVersion version - ModeHelp -> putStrLn helpMessage - ModeInteractive -> mainGFI opts files - ModeRun -> mainRunGFI opts files - ModeCompiler -> dieIOE (mainGFC opts files) - diff --git a/src/GF/Command/Abstract.hs b/src/GF/Command/Abstract.hs deleted file mode 100644 index 1f7c4014e..000000000 --- a/src/GF/Command/Abstract.hs +++ /dev/null @@ -1,79 +0,0 @@ -module GF.Command.Abstract where - -import PGF.CId -import PGF.Data - -type Ident = String - -type CommandLine = [Pipe] - -type Pipe = [Command] - -data Command - = Command Ident [Option] Argument - deriving (Eq,Ord,Show) - -data Option - = OOpt Ident - | OFlag Ident Value - deriving (Eq,Ord,Show) - -data Value - = VId Ident - | VInt Int - | VStr String - deriving (Eq,Ord,Show) - -data Argument - = AExpr Expr - | ANoArg - | AMacro Ident - deriving (Eq,Ord,Show) - -valCIdOpts :: String -> CId -> [Option] -> CId -valCIdOpts flag def opts = - case [v | OFlag f (VId v) <- opts, f == flag] of - (v:_) -> mkCId v - _ -> def - -valIntOpts :: String -> Int -> [Option] -> Int -valIntOpts flag def opts = - case [v | OFlag f (VInt v) <- opts, f == flag] of - (v:_) -> v - _ -> def - -valStrOpts :: String -> String -> [Option] -> String -valStrOpts flag def opts = - case [v | OFlag f v <- opts, f == flag] of - (VStr v:_) -> v - (VId v:_) -> v - (VInt v:_) -> show v - _ -> def - -isOpt :: String -> [Option] -> Bool -isOpt o opts = elem o [x | OOpt x <- opts] - -isFlag :: String -> [Option] -> Bool -isFlag o opts = elem o [x | OFlag x _ <- opts] - -optsAndFlags :: [Option] -> ([Option],[Option]) -optsAndFlags = foldr add ([],[]) where - add o (os,fs) = case o of - OOpt _ -> (o:os,fs) - OFlag _ _ -> (os,o:fs) - -prOpt :: Option -> String -prOpt o = case o of - OOpt i -> i - OFlag f x -> f ++ "=" ++ show x - -mkOpt :: String -> Option -mkOpt = OOpt - --- abbreviation convention from gf commands -getCommandOp s = case break (=='_') s of - (a:_,_:b:_) -> [a,b] -- axx_byy --> ab - _ -> case s of - [a,b] -> s -- ab --> ab - a:_ -> [a] -- axx --> a - diff --git a/src/GF/Command/Commands.hs b/src/GF/Command/Commands.hs deleted file mode 100644 index d8e2a3023..000000000 --- a/src/GF/Command/Commands.hs +++ /dev/null @@ -1,931 +0,0 @@ -{-# LANGUAGE PatternGuards #-} - -module GF.Command.Commands ( - allCommands, - lookCommand, - exec, - isOpt, - options, - flags, - needsTypeCheck, - CommandInfo, - CommandOutput - ) where - -import PGF -import PGF.CId -import PGF.ShowLinearize -import PGF.VisualizeTree -import PGF.Macros -import PGF.Data ---- -import PGF.Morphology -import GF.Compile.Export -import GF.Infra.Option (noOptions, readOutputFormat, Encoding(..)) -import GF.Infra.UseIO -import GF.Data.ErrM ---- -import GF.Command.Abstract -import GF.Command.Messages -import GF.Text.Lexing -import GF.Text.Transliterations -import GF.Quiz - -import GF.Command.TreeOperations ---- temporary place for typecheck and compute - -import GF.Data.Operations -import GF.Text.Coding - -import Data.List -import Data.Maybe -import qualified Data.Map as Map -import System.Cmd -import Text.PrettyPrint -import Data.List (sort) -import Debug.Trace - -type CommandOutput = ([Expr],String) ---- errors, etc - -data CommandInfo = CommandInfo { - exec :: [Option] -> [Expr] -> IO CommandOutput, - synopsis :: String, - syntax :: String, - explanation :: String, - longname :: String, - options :: [(String,String)], - flags :: [(String,String)], - examples :: [String], - needsTypeCheck :: Bool - } - -emptyCommandInfo :: CommandInfo -emptyCommandInfo = CommandInfo { - exec = \_ ts -> return (ts,[]), ---- - synopsis = "", - syntax = "", - explanation = "", - longname = "", - options = [], - flags = [], - examples = [], - needsTypeCheck = True - } - -lookCommand :: String -> Map.Map String CommandInfo -> Maybe CommandInfo -lookCommand = Map.lookup - -commandHelpAll :: Encoding -> PGFEnv -> [Option] -> String -commandHelpAll cod pgf opts = unlines - [commandHelp (isOpt "full" opts) (co,info) - | (co,info) <- Map.assocs (allCommands cod pgf)] - -commandHelp :: Bool -> (String,CommandInfo) -> String -commandHelp full (co,info) = unlines $ [ - co ++ ", " ++ longname info, - synopsis info] ++ if full then [ - "", - "syntax:" ++++ " " ++ syntax info, - "", - explanation info, - "options:" ++++ unlines [" -" ++ o ++ "\t" ++ e | (o,e) <- options info], - "flags:" ++++ unlines [" -" ++ o ++ "\t" ++ e | (o,e) <- flags info], - "examples:" ++++ unlines [" " ++ s | s <- examples info] - ] else [] - --- for printing with txt2tags formatting - -commandHelpTags :: Bool -> (String,CommandInfo) -> String -commandHelpTags full (co,info) = unlines $ [ - "#VSPACE","","#NOINDENT", - lit co ++ " = " ++ lit (longname info) ++ ": " ++ - "//" ++ synopsis info ++ ".//"] ++ if full then [ - "","#TINY","", - explanation info, - "- Syntax: ``" ++ syntax info ++ "``", - "- Options:\n" ++++ - unlines [" | ``-" ++ o ++ "`` | " ++ e | (o,e) <- options info], - "- Flags:\n" ++++ - unlines [" | ``-" ++ o ++ "`` | " ++ e | (o,e) <- flags info], - "- Examples:\n```" ++++ - unlines [" " ++ s | s <- examples info], - "```", - "", "#NORMAL", "" - ] else [] - where - lit s = "``" ++ s ++ "``" - -type PGFEnv = (PGF, Map.Map Language Morpho) - --- this list must no more be kept sorted by the command name -allCommands :: Encoding -> PGFEnv -> Map.Map String CommandInfo -allCommands cod env@(pgf, mos) = Map.fromList [ - ("!", emptyCommandInfo { - synopsis = "system command: escape to system shell", - syntax = "! SYSTEMCOMMAND", - examples = [ - "! ls *.gf -- list all GF files in the working directory" - ], - needsTypeCheck = False - }), - ("?", emptyCommandInfo { - synopsis = "system pipe: send value from previous command to a system command", - syntax = "? SYSTEMCOMMAND", - examples = [ - "gt | l | ? wc -- generate, linearize, word-count" - ], - needsTypeCheck = False - }), - - ("aw", emptyCommandInfo { - longname = "align_words", - synopsis = "show word alignments between languages graphically", - explanation = unlines [ - "Prints a set of strings in the .dot format (the graphviz format).", - "The graph can be saved in a file by the wf command as usual.", - "If the -view flag is defined, the graph is saved in a temporary file", - "which is processed by graphviz and displayed by the program indicated", - "by the flag. The target format is postscript, unless overridden by the", - "flag -format." - ], - exec = \opts es -> do - let grph = if null es then [] else graphvizAlignment pgf (head es) - if isFlag "view" opts || isFlag "format" opts then do - let file s = "_grph." ++ s - let view = optViewGraph opts ++ " " - let format = optViewFormat opts - writeFile (file "dot") (enc grph) - system $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format ++ - " ; " ++ view ++ file format - return void - else return $ fromString grph, - examples = [ - "gr | aw -- generate a tree and show word alignment as graph script", - "gr | vt -view=\"open\" -- generate a tree and display alignment on a Mac" - ], - options = [ - ], - flags = [ - ("format","format of the visualization file (default \"png\")"), - ("view","program to open the resulting file (default \"open\")") - ] - }), - - ("cc", emptyCommandInfo { - longname = "compute_concrete", - syntax = "cc (-all | -table | -unqual)? TERM", - synopsis = "computes concrete syntax term using a source grammar", - explanation = unlines [ - "Compute TERM by concrete syntax definitions. Uses the topmost", - "module (the last one imported) to resolve constant names.", - "N.B.1 You need the flag -retain when importing the grammar, if you want", - "the definitions to be retained after compilation.", - "N.B.2 The resulting term is not a tree in the sense of abstract syntax", - "and hence not a valid input to a Tree-expecting command.", - "This command must be a line of its own, and thus cannot be a part", - "of a pipe." - ], - options = [ - ("all","pick all strings (forms and variants) from records and tables"), - ("table","show all strings labelled by parameters"), - ("unqual","hide qualifying module names") - ], - needsTypeCheck = False - }), - ("dc", emptyCommandInfo { - longname = "define_command", - syntax = "dc IDENT COMMANDLINE", - synopsis = "define a command macro", - explanation = unlines [ - "Defines IDENT as macro for COMMANDLINE, until IDENT gets redefined.", - "A call of the command has the form %IDENT. The command may take an", - "argument, which in COMMANDLINE is marked as ?0. Both strings and", - "trees can be arguments. Currently at most one argument is possible.", - "This command must be a line of its own, and thus cannot be a part", - "of a pipe." - ], - needsTypeCheck = False - }), - ("dt", emptyCommandInfo { - longname = "define_tree", - syntax = "dt IDENT (TREE | STRING | \"<\" COMMANDLINE)", - synopsis = "define a tree or string macro", - explanation = unlines [ - "Defines IDENT as macro for TREE or STRING, until IDENT gets redefined.", - "The defining value can also come from a command, preceded by \"<\".", - "If the command gives many values, the first one is selected.", - "A use of the macro has the form %IDENT. Currently this use cannot be", - "a subtree of another tree. This command must be a line of its own", - "and thus cannot be a part of a pipe." - ], - examples = [ - ("dt ex \"hello world\" -- define ex as string"), - ("dt ex UseN man_N -- define ex as string"), - ("dt ex < p -cat=NP \"the man in the car\" -- define ex as parse result"), - ("l -lang=LangSwe %ex | ps -to_utf8 -- linearize the tree ex") - ], - needsTypeCheck = False - }), - ("e", emptyCommandInfo { - longname = "empty", - synopsis = "empty the environment" - }), - ("gr", emptyCommandInfo { - longname = "generate_random", - synopsis = "generate random trees in the current abstract syntax", - syntax = "gr [-cat=CAT] [-number=INT]", - examples = [ - "gr -- one tree in the startcat of the current grammar", - "gr -cat=NP -number=16 -- 16 trees in the category NP", - "gr -lang=LangHin,LangTha -cat=Cl -- Cl, both in LangHin and LangTha" - ], - explanation = unlines [ - "Generates a list of random trees, by default one tree." ----- "If a tree argument is given, the command completes the Tree with values to", ----- "the metavariables in the tree." - ], - flags = [ - ("cat","generation category"), - ("lang","uses only functions that have linearizations in all these languages"), - ("number","number of trees generated") - ], - exec = \opts _ -> do - let pgfr = optRestricted opts - ts <- generateRandom pgfr (optType opts) - returnFromExprs $ take (optNum opts) ts - }), - ("gt", emptyCommandInfo { - longname = "generate_trees", - synopsis = "generates a list of trees, by default exhaustive", - explanation = unlines [ - "Generates all trees of a given category, with increasing depth.", - "By default, the depth is 4, but this can be changed by a flag." - ---- "If a Tree argument is given, the command completes the Tree with values", - ---- "to the metavariables in the tree." - ], - flags = [ - ("cat","the generation category"), - ("depth","the maximum generation depth"), - ("lang","excludes functions that have no linearization in this language"), - ("number","the number of trees generated") - ], - exec = \opts _ -> do - let pgfr = optRestricted opts - let dp = return $ valIntOpts "depth" 4 opts - let ts = generateAllDepth pgfr (optType opts) dp - returnFromExprs $ take (optNumInf opts) ts - }), - ("h", emptyCommandInfo { - longname = "help", - syntax = "h (-full)? COMMAND?", - synopsis = "get description of a command, or a the full list of commands", - explanation = unlines [ - "Displays information concerning the COMMAND.", - "Without argument, shows the synopsis of all commands." - ], - options = [ - ("changes","give a summary of changes from GF 2.9"), - ("coding","give advice on character encoding"), - ("full","give full information of the commands"), - ("license","show copyright and license information") - ], - exec = \opts ts -> - let - msg = case ts of - _ | isOpt "changes" opts -> changesMsg - _ | isOpt "coding" opts -> codingMsg - _ | isOpt "license" opts -> licenseMsg - [t] -> let co = getCommandOp (showExpr [] t) in - case lookCommand co (allCommands cod env) of ---- new map ??!! - Just info -> commandHelp True (co,info) - _ -> "command not found" - _ -> commandHelpAll cod env opts - in return (fromString msg), - needsTypeCheck = False - }), - ("i", emptyCommandInfo { - longname = "import", - synopsis = "import a grammar from source code or compiled .pgf file", - explanation = unlines [ - "Reads a grammar from File and compiles it into a GF runtime grammar.", - "If a grammar with the same concrete name is already in the state", - "it is overwritten - but only if compilation succeeds.", - "The grammar parser depends on the file name suffix:", - " .gf normal GF source", - " .gfo compiled GF source", - " .pgf precompiled grammar in Portable Grammar Format" - ], - options = [ - -- ["prob", "retain", "gfo", "src", "no-cpu", "cpu", "quiet", "verbose"] - ("retain","retain operations (used for cc command)"), - ("src", "force compilation from source"), - ("v", "be verbose - show intermediate status information") - ], - needsTypeCheck = False - }), - ("l", emptyCommandInfo { - longname = "linearize", - synopsis = "convert an abstract syntax expression to string", - explanation = unlines [ - "Shows the linearization of a Tree by the grammars in scope.", - "The -lang flag can be used to restrict this to fewer languages.", - "A sequence of string operations (see command ps) can be given", - "as options, and works then like a pipe to the ps command, except", - "that it only affect the strings, not e.g. the table labels.", - "These can be given separately to each language with the unlexer flag", - "whose results are prepended to the other lexer flags. The value of the", - "unlexer flag is a space-separated list of comma-separated string operation", - "sequences; see example." - ], - examples = [ - "l -langs=LangSwe,LangNor no_Utt -- linearize tree to LangSwe and LangNor", - "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -to_utf8 -- hindi table", - "l -unlexer=\"LangSwe=to_utf8 LangHin=to_devanagari,to_utf8\" -- different lexers" - ], - exec = \opts -> return . fromStrings . map (optLin opts), - options = [ - ("all","show all forms and variants"), - ("bracket","show tree structure with brackets and paths to nodes"), - ("multi","linearize to all languages (default)"), - ("record","show source-code-like record"), - ("table","show all forms labelled by parameters"), - ("term", "show PGF term"), - ("treebank","show the tree and tag linearizations with language names") - ] ++ stringOpOptions, - flags = [ - ("lang","the languages of linearization (comma-separated, no spaces)"), - ("unlexer","set unlexers separately to each language (space-separated)") - ] - }), - ("ma", emptyCommandInfo { - longname = "morpho_analyse", - synopsis = "print the morphological analyses of all words in the string", - explanation = unlines [ - "Prints all the analyses of space-separated words in the input string,", - "using the morphological analyser of the actual grammar (see command pf)" - ], - exec = \opts -> - return . fromString . unlines . - map prMorphoAnalysis . concatMap (morphos opts) . - concatMap words . toStrings - }), - - ("mq", emptyCommandInfo { - longname = "morpho_quiz", - synopsis = "start a morphology quiz", - exec = \opts _ -> do - let lang = optLang opts - let typ = optType opts - morphologyQuiz cod pgf lang typ - return void, - flags = [ - ("lang","language of the quiz"), - ("cat","category of the quiz"), - ("number","maximum number of questions") - ] - }), - - ("p", emptyCommandInfo { - longname = "parse", - synopsis = "parse a string to abstract syntax expression", - explanation = unlines [ - "Shows all trees returned by parsing a string in the grammars in scope.", - "The -lang flag can be used to restrict this to fewer languages.", - "The default start category can be overridden by the -cat flag.", - "See also the ps command for lexing and character encoding.", - "", - "The -openclass flag is experimental and allows some robustness in ", - "the parser. For example if -openclass=\"A,N,V\" is given, the parser", - "will accept unknown adjectives, nouns and verbs with the resource grammar." - ], - exec = \opts -> returnFromExprs . concatMap (par opts) . toStrings, - flags = [ - ("cat","target category of parsing"), - ("lang","the languages of parsing (comma-separated, no spaces)"), - ("openclass","list of open-class categories for robust parsing") - ] - }), - ("pg", emptyCommandInfo { ----- - longname = "print_grammar", - synopsis = "print the actual grammar with the given printer", - explanation = unlines [ - "Prints the actual grammar, with all involved languages.", - "In some printers, this can be restricted to a subset of languages", - "with the -lang=X,Y flag (comma-separated, no spaces).", - "The -printer=P flag sets the format in which the grammar is printed.", - "N.B.1 Since grammars are compiled when imported, this command", - "generally shows a grammar that looks rather different from the source.", - "N.B.2 This command is slightly obsolete: to produce different formats", - "the batch compiler gfc is recommended, and has many more options." - ], - exec = \opts _ -> prGrammar opts, - flags = [ - --"cat", - ("lang", "select languages for the some options (default all languages)"), - ("printer","select the printing format (see gfc --help)") - ], - options = [ - ("cats", "show just the names of abstract syntax categories"), - ("fullform", "print the fullform lexicon"), - ("missing","show just the names of functions that have no linearization") - ] - }), - ("ph", emptyCommandInfo { - longname = "print_history", - synopsis = "print command history", - explanation = unlines [ - "Prints the commands issued during the GF session.", - "The result is readable by the eh command.", - "The result can be used as a script when starting GF." - ], - examples = [ - "ph | wf -file=foo.gfs -- save the history into a file" - ] - }), - ("ps", emptyCommandInfo { - longname = "put_string", - syntax = "ps OPT? STRING", - synopsis = "return a string, possibly processed with a function", - explanation = unlines [ - "Returns a string obtained from its argument string by applying", - "string processing functions in the order given in the command line", - "option list. Thus 'ps -f -g s' returns g (f s). Typical string processors", - "are lexers and unlexers, but also character encoding conversions are possible.", - "The unlexers preserve the division of their input to lines.", - "To see transliteration tables, use command ut." - ], - examples = [ - "l (EAdd 3 4) | ps -code -- linearize code-like output", - "ps -lexer=code | p -cat=Exp -- parse code-like input", - "gr -cat=QCl | l | ps -bind -- linearization output from LangFin", - "ps -to_devanagari \"A-p\" -- show Devanagari in UTF8 terminal", - "rf -file=Hin.gf | ps -env=quotes -to_devanagari -- convert translit to UTF8", - "rf -file=Ara.gf | ps -from_utf8 -env=quotes -from_arabic -- convert UTF8 to transliteration" - ], - exec = \opts -> - let (os,fs) = optsAndFlags opts in - return . fromString . stringOps (envFlag fs) (map prOpt os) . toString, - options = stringOpOptions, - flags = [ - ("env","apply in this environment only") - ] - }), - ("pt", emptyCommandInfo { - longname = "put_tree", - syntax = "ps OPT? TREE", - synopsis = "return a tree, possibly processed with a function", - explanation = unlines [ - "Returns a tree obtained from its argument tree by applying", - "tree processing functions in the order given in the command line", - "option list. Thus 'pt -f -g s' returns g (f s). Typical tree processors", - "are type checking and semantic computation." - ], - examples = [ - "pt -compute (plus one two) -- compute value" - ], - exec = \opts -> - returnFromExprs . takeOptNum opts . treeOps opts, - options = treeOpOptions pgf, - flags = [("number","take at most this many trees")] ++ treeOpFlags pgf - }), - ("q", emptyCommandInfo { - longname = "quit", - synopsis = "exit GF interpreter" - }), - ("rf", emptyCommandInfo { - longname = "read_file", - synopsis = "read string or tree input from a file", - explanation = unlines [ - "Reads input from file. The filename must be in double quotes.", - "The input is interpreted as a string by default, and can hence be", - "piped e.g. to the parse command. The option -tree interprets the", - "input as a tree, which can be given e.g. to the linearize command.", - "The option -lines will result in a list of strings or trees, one by line." - ], - options = [ - ("lines","return the list of lines, instead of the singleton of all contents"), - ("tree","convert strings into trees") - ], - exec = \opts _ -> do - let file = valStrOpts "file" "_gftmp" opts - let exprs [] = ([],empty) - exprs ((n,s):ls) | null s - = exprs ls - exprs ((n,s):ls) = case readExpr s of - Just e -> let (es,err) = exprs ls - in case inferExpr pgf e of - Right (e,t) -> (e:es,err) - Left tcerr -> (es,text "on line" <+> int n <> colon $$ nest 2 (ppTcError tcerr) $$ err) - Nothing -> let (es,err) = exprs ls - in (es,text "on line" <+> int n <> colon <+> text "parse error" $$ err) - returnFromLines ls = case exprs ls of - (es, err) | null es -> return ([], render (err $$ text "no trees found")) - | otherwise -> return (es, render err) - - s <- readFile file - case opts of - _ | isOpt "lines" opts && isOpt "tree" opts -> - returnFromLines (zip [1..] (lines s)) - _ | isOpt "tree" opts -> - returnFromLines [(1,s)] - _ | isOpt "lines" opts -> return (fromStrings $ lines s) - _ -> return (fromString s), - flags = [("file","the input file name")] - }), - ("tq", emptyCommandInfo { - longname = "translation_quiz", - synopsis = "start a translation quiz", - exec = \opts _ -> do - let from = valCIdOpts "from" (optLang opts) opts - let to = valCIdOpts "to" (optLang opts) opts - let typ = optType opts - translationQuiz cod pgf from to typ - return void, - flags = [ - ("from","translate from this language"), - ("to","translate to this language"), - ("cat","translate in this category"), - ("number","the maximum number of questions") - ] - }), - ("se", emptyCommandInfo { - longname = "set_encoding", - synopsis = "set the encoding used in current terminal", - syntax = "se ID", - examples = [ - "se cp1251 -- set encoding to cp1521", - "se utf8 -- set encoding to utf8 (default)" - ], - needsTypeCheck = False - }), - ("sp", emptyCommandInfo { - longname = "system_pipe", - synopsis = "send argument to a system command", - syntax = "sp -command=\"SYSTEMCOMMAND\", alt. ? SYSTEMCOMMAND", - exec = \opts arg -> do - let tmpi = "_tmpi" --- - let tmpo = "_tmpo" - writeFile tmpi $ enc $ toString arg - let syst = optComm opts ++ " " ++ tmpi - system $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo - s <- readFile tmpo - return $ fromString s, - flags = [ - ("command","the system command applied to the argument") - ], - examples = [ - "sp -command=\"wc\" \"foo\"", - "gt | l | sp -command=\"grep \\\"who\\\"\" | sp -command=\"wc\"" - ] - }), - ("ut", emptyCommandInfo { - longname = "unicode_table", - synopsis = "show a transliteration table for a unicode character set", - exec = \opts _ -> do - let t = concatMap prOpt (take 1 opts) - let out = maybe "no such transliteration" characterTable $ transliteration t - return $ fromString out, - options = transliterationPrintNames - }), - - ("vd", emptyCommandInfo { - longname = "visualize_dependency", - synopsis = "show word dependency tree graphically", - explanation = unlines [ - "Prints a dependency tree in the .dot format (the graphviz format, default)", - "or the MaltParser/CoNLL format (flag -output=malt for training, malt_input)", - "for unanalysed input.", - "By default, the last argument is the head of every abstract syntax", - "function; moreover, the head depends on the head of the function above.", - "The graph can be saved in a file by the wf command as usual.", - "If the -view flag is defined, the graph is saved in a temporary file", - "which is processed by graphviz and displayed by the program indicated", - "by the flag. The target format is png, unless overridden by the", - "flag -format." - ], - exec = \opts es -> do - let debug = isOpt "v" opts - let file = valStrOpts "file" "" opts - let outp = valStrOpts "output" "dot" opts - mlab <- case file of - "" -> return Nothing - _ -> readFile file >>= return . Just . getDepLabels . lines - let lang = optLang opts - let grphs = unlines $ map (graphvizDependencyTree outp debug mlab Nothing pgf lang) es - if isFlag "view" opts || isFlag "format" opts then do - let file s = "_grphd." ++ s - let view = optViewGraph opts ++ " " - let format = optViewFormat opts - writeFile (file "dot") (enc grphs) - system $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format ++ - " ; " ++ view ++ file format - return void - else return $ fromString grphs, - examples = [ - "gr | vd -- generate a tree and show dependency tree in .dot", - "gr | vd -view=open -- generate a tree and display dependency tree on a Mac", - "gr -number=1000 | vd -file=dep.labels -output=malt -- generate training treebank", - "gr -number=100 | vd -file=dep.labels -output=malt_input -- generate test sentences" - ], - options = [ - ("v","show extra information") - ], - flags = [ - ("file","configuration file for labels per fun, format 'fun l1 ... label ... l2'"), - ("format","format of the visualization file (default \"png\")"), - ("output","output format of graph source (default \"dot\")"), - ("view","program to open the resulting file (default \"open\")") - ] - }), - - - ("vp", emptyCommandInfo { - longname = "visualize_parse", - synopsis = "show parse tree graphically", - explanation = unlines [ - "Prints a parse tree the .dot format (the graphviz format).", - "The graph can be saved in a file by the wf command as usual.", - "If the -view flag is defined, the graph is saved in a temporary file", - "which is processed by graphviz and displayed by the program indicated", - "by the flag. The target format is png, unless overridden by the", - "flag -format." - ], - exec = \opts es -> do - let lang = optLang opts - let grph = if null es then [] else graphvizParseTree pgf lang (head es) - if isFlag "view" opts || isFlag "format" opts then do - let file s = "_grph." ++ s - let view = optViewGraph opts ++ " " - let format = optViewFormat opts - writeFile (file "dot") (enc grph) - system $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format ++ - " ; " ++ view ++ file format - return void - else return $ fromString grph, - examples = [ - "p \"John walks\" | vp -- generate a tree and show parse tree as .dot script", - "gr | vp -view=\"open\" -- generate a tree and display parse tree on a Mac" - ], - options = [ - ], - flags = [ - ("format","format of the visualization file (default \"png\")"), - ("view","program to open the resulting file (default \"open\")") - ] - }), - - ("vt", emptyCommandInfo { - longname = "visualize_tree", - synopsis = "show a set of trees graphically", - explanation = unlines [ - "Prints a set of trees in the .dot format (the graphviz format).", - "The graph can be saved in a file by the wf command as usual.", - "If the -view flag is defined, the graph is saved in a temporary file", - "which is processed by graphviz and displayed by the program indicated", - "by the flag. The target format is postscript, unless overridden by the", - "flag -format.", - "With option -mk, use for showing library style function names of form 'mkC'." - ], - exec = \opts es -> - if isOpt "mk" opts - then return $ fromString $ unlines $ map (tree2mk pgf) es - else do - let funs = not (isOpt "nofun" opts) - let cats = not (isOpt "nocat" opts) - let grph = unlines (map (graphvizAbstractTree pgf (funs,cats)) es) -- True=digraph - if isFlag "view" opts || isFlag "format" opts then do - let file s = "_grph." ++ s - let view = optViewGraph opts ++ " " - let format = optViewFormat opts - writeFile (file "dot") (enc grph) - system $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format ++ - " ; " ++ view ++ file format - return void - else return $ fromString grph, - examples = [ - "p \"hello\" | vt -- parse a string and show trees as graph script", - "p \"hello\" | vt -view=\"open\" -- parse a string and display trees on a Mac" - ], - options = [ - ("mk", "show the tree with function names converted to 'mkC' with value cats C"), - ("nofun","don't show functions but only categories"), - ("nocat","don't show categories but only functions") - ], - flags = [ - ("format","format of the visualization file (default \"png\")"), - ("view","program to open the resulting file (default \"open\")") - ] - }), - ("wf", emptyCommandInfo { - longname = "write_file", - synopsis = "send string or tree to a file", - exec = \opts arg -> do - let file = valStrOpts "file" "_gftmp" opts - if isOpt "append" opts - then appendFile file (enc (toString arg)) - else writeFile file (enc (toString arg)) - return void, - options = [ - ("append","append to file, instead of overwriting it") - ], - flags = [("file","the output filename")] - }), - ("ai", emptyCommandInfo { - longname = "abstract_info", - syntax = "ai IDENTIFIER or ai EXPR", - synopsis = "Provides an information about a function, an expression or a category from the abstract syntax", - explanation = unlines [ - "The command has one argument which is either function, expression or", - "a category defined in the abstract syntax of the current grammar. ", - "If the argument is a function then ?its type is printed out.", - "If it is a category then the category definition is printed.", - "If a whole expression is given it prints the expression with refined", - "metavariables and the type of the expression." - ], - exec = \opts arg -> do - case arg of - [EFun id] -> case Map.lookup id (funs (abstract pgf)) of - Just (ty,_,eqs) -> return $ fromString $ - render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$ - if null eqs - then empty - else text "def" <+> vcat [let (scope,ds) = mapAccumL (ppPatt 9) [] patts - in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs]) - Nothing -> case Map.lookup id (cats (abstract pgf)) of - Just hyps -> do return $ fromString $ - render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL ppHypo [] hyps)) $$ - if null (functionsToCat pgf id) - then empty - else space $$ - text "fun" <+> vcat [ppCId fid <+> colon <+> ppType 0 [] ty - | (fid,ty) <- functionsToCat pgf id]) - Nothing -> do putStrLn ("unknown category of function identifier "++show id) - return void - [e] -> case inferExpr pgf e of - Left tcErr -> error $ render (ppTcError tcErr) - Right (e,ty) -> do putStrLn ("Expression: "++showExpr [] e) - putStrLn ("Type: "++showType [] ty) - return void - _ -> do putStrLn "a single identifier or expression is expected from the command" - return void, - needsTypeCheck = False - }) - ] - where - enc = encodeUnicode cod - par opts s = case optOpenTypes opts of - [] -> concat [parse pgf lang (optType opts) s | lang <- optLangs opts, canParse pgf lang] - open_typs -> concat [parseWithRecovery pgf lang (optType opts) open_typs s | lang <- optLangs opts, canParse pgf lang] - - void = ([],[]) - - optLin opts t = unlines $ - case opts of - _ | isOpt "treebank" opts -> (showCId (abstractName pgf) ++ ": " ++ showExpr [] t) : - [showCId lang ++ ": " ++ linear opts lang t | lang <- optLangs opts] - _ -> [linear opts lang t | lang <- optLangs opts] - - linear :: [Option] -> CId -> Expr -> String - linear opts lang = let unl = unlex opts lang in case opts of - _ | isOpt "all" opts -> allLinearize unl pgf lang - _ | isOpt "table" opts -> tableLinearize unl pgf lang - _ | isOpt "term" opts -> termLinearize pgf lang - _ | isOpt "record" opts -> recordLinearize pgf lang - _ | isOpt "bracket" opts -> markLinearize pgf lang - _ -> unl . linearize pgf lang - - unlex opts lang = stringOps Nothing (getUnlex opts lang ++ map prOpt opts) ---- - - getUnlex opts lang = case words (valStrOpts "unlexer" "" opts) of - lexs -> case lookup lang - [(mkCId la,tail le) | lex <- lexs, let (la,le) = span (/='=') lex, not (null le)] of - Just le -> chunks ',' le - _ -> [] - --- Proposed logic of coding in unlexing: --- - If lang has no coding flag, or -to_utf8 is not in opts, just opts are used. --- - If lang has flag coding=utf8, -to_utf8 is ignored. --- - If lang has coding=other, and -to_utf8 is in opts, from_other is applied first. --- THIS DOES NOT WORK UNFORTUNATELY - can't use the grammar flag properly - unlexx opts lang = {- trace (unwords optsC) $ -} stringOps Nothing optsC where ---- - optsC = case lookFlag pgf lang "coding" of - Just "utf8" -> filter (/="to_utf8") $ map prOpt opts - Just other | isOpt "to_utf8" opts -> - let cod = ("from_" ++ other) - in cod : filter (/=cod) (map prOpt opts) - _ -> map prOpt opts - - optRestricted opts = - restrictPGF (\f -> and [hasLin pgf la f | la <- optLangs opts]) pgf - - optLangs opts = case valStrOpts "lang" "" opts of - "" -> languages pgf - lang -> map mkCId (chunks ',' lang) - optLang opts = head $ optLangs opts ++ [wildCId] - - optOpenTypes opts = case valStrOpts "openclass" "" opts of - "" -> [] - cats -> mapMaybe readType (chunks ',' cats) - - optType opts = - let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts - in case readType str of - Just ty -> case checkType pgf ty of - Left tcErr -> error $ render (ppTcError tcErr) - Right ty -> ty - Nothing -> error ("Can't parse '"++str++"' as type") - optComm opts = valStrOpts "command" "" opts - optViewFormat opts = valStrOpts "format" "png" opts - optViewGraph opts = valStrOpts "view" "open" opts - optNum opts = valIntOpts "number" 1 opts - optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9 - takeOptNum opts = take (optNumInf opts) - - fromExprs es = (es,unlines (map (showExpr []) es)) - fromStrings ss = (map (ELit . LStr) ss, unlines ss) - fromString s = ([ELit (LStr s)], s) - toStrings = map showAsString - toString = unwords . toStrings - - returnFromExprs es = return $ case es of - [] -> ([], "no trees found") - _ -> fromExprs es - - prGrammar opts - | isOpt "cats" opts = return $ fromString $ unwords $ map showCId $ categories pgf - | isOpt "fullform" opts = return $ fromString $ concatMap (morpho "" prFullFormLexicon) $ optLangs opts - | isOpt "missing" opts = return $ fromString $ unlines $ [unwords (showCId la:":": map showCId cs) | - la <- optLangs opts, let cs = missingLins pgf la] - | otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts) - return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf - - morphos opts s = - [morpho [] (\mo -> lookupMorpho mo s) la | la <- optLangs opts] - - morpho z f la = maybe z f $ Map.lookup la mos - - -- ps -f -g s returns g (f s) - stringOps menv opts s = foldr (menvop . app) s (reverse opts) where - app f = maybe id id (stringOp f) - menvop op = maybe op (\ (b,e) -> opInEnv b e op) menv - - envFlag fs = case valStrOpts "env" "global" fs of - "quotes" -> Just ("\"","\"") - _ -> Nothing - - treeOps opts s = foldr app s (reverse opts) where - app (OOpt op) | Just (Left f) <- treeOp pgf op = f - app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f (mkCId x) - app _ = id - - showAsString t = case t of - ELit (LStr s) -> s - _ -> "\n" ++ showExpr [] t --- newline needed in other cases than the first - -stringOpOptions = sort $ [ - ("bind","bind tokens separated by Prelude.BIND, i.e. &+"), - ("chars","lexer that makes every non-space character a token"), - ("from_cp1251","decode from cp1251 (Cyrillic used in Bulgarian resource)"), - ("from_utf8","decode from utf8 (default)"), - ("lextext","text-like lexer"), - ("lexcode","code-like lexer"), - ("lexmixed","mixture of text and code (code between $...$)"), - ("to_cp1251","encode to cp1251 (Cyrillic used in Bulgarian resource)"), - ("to_html","wrap in a html file with linebreaks"), - ("to_utf8","encode to utf8 (default)"), - ("unlextext","text-like unlexer"), - ("unlexcode","code-like unlexer"), - ("unlexmixed","mixture of text and code (code between $...$)"), - ("unchars","unlexer that puts no spaces between tokens"), - ("unwords","unlexer that puts a single space between tokens (default)"), - ("words","lexer that assumes tokens separated by spaces (default)") - ] ++ - concat [ - [("from_" ++ p, "from unicode to GF " ++ n ++ " transliteration"), - ("to_" ++ p, "from GF " ++ n ++ " transliteration to unicode")] | - (p,n) <- transliterationPrintNames] - -treeOpOptions pgf = [(op,expl) | (op,(expl,Left _)) <- allTreeOps pgf] -treeOpFlags pgf = [(op,expl) | (op,(expl,Right _)) <- allTreeOps pgf] - -translationQuiz :: Encoding -> PGF -> Language -> Language -> Type -> IO () -translationQuiz cod pgf ig og typ = do - tts <- translationList pgf ig og typ infinity - mkQuiz cod "Welcome to GF Translation Quiz." tts - -morphologyQuiz :: Encoding -> PGF -> Language -> Type -> IO () -morphologyQuiz cod pgf ig typ = do - tts <- morphologyList pgf ig typ infinity - mkQuiz cod "Welcome to GF Morphology Quiz." tts - --- | the maximal number of precompiled quiz problems -infinity :: Int -infinity = 256 - -lookFlag :: PGF -> String -> String -> Maybe String -lookFlag pgf lang flag = lookConcrFlag pgf (mkCId lang) (mkCId flag) - -prFullFormLexicon :: Morpho -> String -prFullFormLexicon mo = - unlines [w ++ " : " ++ prMorphoAnalysis ts | (w,ts) <- fullFormLexicon mo] - -prMorphoAnalysis :: [(Lemma,Analysis)] -> String -prMorphoAnalysis lps = unlines [showCId l ++ " " ++ p | (l,p) <- lps] - diff --git a/src/GF/Command/Importing.hs b/src/GF/Command/Importing.hs deleted file mode 100644 index 06deab6c6..000000000 --- a/src/GF/Command/Importing.hs +++ /dev/null @@ -1,50 +0,0 @@ -module GF.Command.Importing (importGrammar, importSource) where - -import PGF -import PGF.Data - -import GF.Compile -import GF.Grammar.Grammar (SourceGrammar) -- for cc command -import GF.Grammar.CF -import GF.Infra.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 :: PGF -> Options -> [FilePath] -> IO PGF -importGrammar pgf0 _ [] = return pgf0 -importGrammar pgf0 opts files = - case takeExtensions (last files) of - ".cf" -> do - s <- fmap unlines $ mapM readFile files - let cnc = justModuleName (last files) - gf <- case getCF cnc s of - Ok g -> return g - Bad s -> error s ---- - Ok gr <- appIOE $ compileSourceGrammar opts gf - epgf <- appIOE $ link opts (cnc ++ "Abs") gr - case epgf of - Ok pgf -> return pgf - Bad s -> error s ---- - s | elem s [".gf",".gfo"] -> do - res <- appIOE $ compileToPGF opts files - case res of - Ok pgf2 -> do return $ unionPGF pgf0 pgf2 - Bad msg -> do putStrLn ('\n':'\n':msg) - return pgf0 - ".pgf" -> do - pgf2 <- mapM readPGF files >>= return . foldl1 unionPGF - return $ unionPGF pgf0 pgf2 - ext -> die $ "Unknown filename extension: " ++ show ext - -importSource :: SourceGrammar -> Options -> [FilePath] -> IO SourceGrammar -importSource src0 opts files = do - src <- appIOE $ batchCompile opts files - case src of - Ok gr -> return gr - Bad msg -> do - putStrLn msg - return src0 diff --git a/src/GF/Command/Interpreter.hs b/src/GF/Command/Interpreter.hs deleted file mode 100644 index ff84da8a3..000000000 --- a/src/GF/Command/Interpreter.hs +++ /dev/null @@ -1,132 +0,0 @@ -module GF.Command.Interpreter ( - CommandEnv (..), - mkCommandEnv, - emptyCommandEnv, - interpretCommandLine, - interpretPipe, - getCommandOp - ) where - -import GF.Command.Commands -import GF.Command.Abstract -import GF.Command.Parse -import PGF -import PGF.Data -import PGF.Morphology -import GF.System.Signal -import GF.Infra.UseIO -import GF.Infra.Option - -import Text.PrettyPrint -import Control.Monad.Error -import qualified Data.Map as Map - -data CommandEnv = CommandEnv { - multigrammar :: PGF, - morphos :: Map.Map Language Morpho, - commands :: Map.Map String CommandInfo, - commandmacros :: Map.Map String CommandLine, - expmacros :: Map.Map String Expr - } - -mkCommandEnv :: Encoding -> PGF -> CommandEnv -mkCommandEnv enc pgf = - let mos = Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf] in - CommandEnv pgf mos (allCommands enc (pgf, mos)) Map.empty Map.empty - -emptyCommandEnv :: CommandEnv -emptyCommandEnv = mkCommandEnv UTF_8 emptyPGF - -interpretCommandLine :: (String -> String) -> CommandEnv -> String -> IO () -interpretCommandLine enc env line = - case readCommandLine line of - Just [] -> return () - Just pipes -> mapM_ (interpretPipe enc env) pipes - Nothing -> putStrLnFlush "command not parsed" - -interpretPipe enc env cs = do - v@(_,s) <- intercs ([],"") cs - putStrLnFlush $ enc s - return v - where - intercs treess [] = return treess - intercs (trees,_) (c:cs) = do - treess2 <- interc trees c - intercs treess2 cs - interc es comm@(Command co opts arg) = case co of - '%':f -> case Map.lookup f (commandmacros env) of - Just css -> - case getCommandTrees env False arg es of - Right es -> do mapM_ (interpretPipe enc env) (appLine es css) - return ([],[]) - Left msg -> do putStrLn ('\n':msg) - return ([],[]) - Nothing -> do - putStrLn $ "command macro " ++ co ++ " not interpreted" - return ([],[]) - _ -> interpret enc env es comm - appLine es = map (map (appCommand es)) - --- macro definition applications: replace ?i by (exps !! i) -appCommand :: [Expr] -> Command -> Command -appCommand xs c@(Command i os arg) = case arg of - AExpr e -> Command i os (AExpr (app e)) - _ -> c - where - app e = case e of - EAbs b x e -> EAbs b x (app e) - EApp e1 e2 -> EApp (app e1) (app e2) - ELit l -> ELit l - EMeta i -> xs !! i - EFun x -> EFun x - --- return the trees to be sent in pipe, and the output possibly printed -interpret :: (String -> String) -> CommandEnv -> [Expr] -> Command -> IO CommandOutput -interpret enc env trees comm = - case getCommand env trees comm of - Left msg -> do putStrLn ('\n':msg) - return ([],[]) - Right (info,opts,trees) -> do tss@(_,s) <- exec info opts trees - if isOpt "tr" opts - then putStrLn (enc s) - else return () - return tss - --- analyse command parse tree to a uniform datastructure, normalizing comm name ---- the env is needed for macro lookup -getCommand :: CommandEnv -> [Expr] -> Command -> Either String (CommandInfo,[Option],[Expr]) -getCommand env es co@(Command c opts arg) = do - info <- getCommandInfo env c - checkOpts info opts - es <- getCommandTrees env (needsTypeCheck info) arg es - return (info,opts,es) - -getCommandInfo :: CommandEnv -> String -> Either String CommandInfo -getCommandInfo env cmd = - case lookCommand (getCommandOp cmd) (commands env) of - Just info -> return info - Nothing -> fail $ "command " ++ cmd ++ " not interpreted" - -checkOpts :: CommandInfo -> [Option] -> Either String () -checkOpts info opts = - case - [o | OOpt o <- opts, notElem o ("tr" : map fst (options info))] ++ - [o | OFlag o _ <- opts, notElem o (map fst (flags info))] - of - [] -> return () - [o] -> fail $ "option not interpreted: " ++ o - os -> fail $ "options not interpreted: " ++ unwords os - -getCommandTrees :: CommandEnv -> Bool -> Argument -> [Expr] -> Either String [Expr] -getCommandTrees env needsTypeCheck a es = - case a of - AMacro m -> case Map.lookup m (expmacros env) of - Just e -> return [e] - _ -> return [] - AExpr e -> if needsTypeCheck - then case inferExpr (multigrammar env) e of - Left tcErr -> fail $ render (ppTcError tcErr) - Right (e,ty) -> return [e] -- ignore piped - else return [e] - ANoArg -> return es -- use piped - diff --git a/src/GF/Command/Messages.hs b/src/GF/Command/Messages.hs deleted file mode 100644 index 8dda92d49..000000000 --- a/src/GF/Command/Messages.hs +++ /dev/null @@ -1,54 +0,0 @@ -module GF.Command.Messages where - -licenseMsg = unlines [ - "Copyright (c)", - "Krasimir Angelov, Bj\246rn Bringert, H\229kan Burden, Hans-Joachim Daniels,", - "Markus Forsberg, Thomas Hallgren, Harald Hammarstr\246m, Kristofer Johannisson,", - "Janna Khegai, Peter Ljungl\246f, Petri M\228enp\228\228, and", - "Aarne Ranta, 1998-2008, under GNU General Public License (GPL)", - "see LICENSE in GF distribution, or http://www.gnu.org/licenses/gpl.html." - ] - -codingMsg = unlines [ - "The GF shell uses Unicode internally, but assumes user input to be UTF8", - "and converts terminal and file output to UTF8. If your terminal is not UTF8", - "see 'help set_encoding." - ] - -changesMsg = unlines [ - "While GF 3.0 is backward compatible with source grammars, the shell commands", - "have changed from version 2.9. Below the most importand changes. Bug reports", - "and feature requests should be sent to http://trac.haskell.org/gf/.", - "", - "af use wf -append", - "at not supported", - "eh not yet supported", - "es no longer supported; use javascript generation", - "g not yet supported", - "l now by default multilingual", - "ml not yet supported", - "p now by default multilingual", - "pi not yet supported", - "pl not yet supported", - "pm subsumed to pg", - "po not yet supported", - "pt not yet supported", - "r not yet supported", - "rf changed syntax", - "rl not supported", - "s no longer needed", - "sa not supported", - "sf not supported", - "si not supported", - "so not yet supported", - "t use pipe with l and p", - "tb use l -treebank", - "tl not yet supported", - "tq changed syntax", - "ts not supported", - "tt use ps", - "ut not supported", - "vg not yet supported", - "wf changed syntax", - "wt not supported" - ] diff --git a/src/GF/Command/Parse.hs b/src/GF/Command/Parse.hs deleted file mode 100644 index 44366c472..000000000 --- a/src/GF/Command/Parse.hs +++ /dev/null @@ -1,64 +0,0 @@ -module GF.Command.Parse(readCommandLine, pCommand) where - -import PGF.CId -import PGF.Expr -import GF.Command.Abstract - -import Data.Char -import Control.Monad -import qualified Text.ParserCombinators.ReadP as RP - -readCommandLine :: String -> Maybe CommandLine -readCommandLine s = case [x | (x,cs) <- RP.readP_to_S pCommandLine s, all isSpace cs] of - [x] -> Just x - _ -> Nothing - -pCommandLine = - (RP.skipSpaces >> RP.char '-' >> RP.char '-' >> RP.skipMany (RP.satisfy (const True)) >> return []) -- comment - RP.<++ - (RP.sepBy (RP.skipSpaces >> pPipe) (RP.skipSpaces >> RP.char ';')) - -pPipe = RP.sepBy1 (RP.skipSpaces >> pCommand) (RP.skipSpaces >> RP.char '|') - -pCommand = (do - cmd <- pIdent RP.<++ (RP.char '%' >> pIdent >>= return . ('%':)) - RP.skipSpaces - opts <- RP.sepBy pOption RP.skipSpaces - arg <- pArgument - return (Command cmd opts arg) - ) - RP.<++ (do - RP.char '?' - c <- pSystemCommand - return (Command "sp" [OFlag "command" (VStr c)] ANoArg) - ) - -pOption = do - RP.char '-' - flg <- pIdent - RP.option (OOpt flg) (fmap (OFlag flg) (RP.char '=' >> pValue)) - -pValue = do - fmap (VInt . read) (RP.munch1 isDigit) - RP.<++ - fmap VStr pStr - RP.<++ - fmap VId pFilename - -pFilename = liftM2 (:) (RP.satisfy isFileFirst) (RP.munch (not . isSpace)) where - isFileFirst c = not (isSpace c) && not (isDigit c) - -pArgument = - RP.option ANoArg - (fmap AExpr pExpr - RP.<++ - (RP.munch isSpace >> RP.char '%' >> fmap AMacro pIdent)) - -pSystemCommand = - RP.munch isSpace >> ( - (RP.char '"' >> (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"'))) - RP.<++ - RP.many RP.get - ) - where - pEsc = RP.char '\\' >> RP.get diff --git a/src/GF/Command/TreeOperations.hs b/src/GF/Command/TreeOperations.hs deleted file mode 100644 index 941f03782..000000000 --- a/src/GF/Command/TreeOperations.hs +++ /dev/null @@ -1,32 +0,0 @@ -module GF.Command.TreeOperations ( - treeOp, - allTreeOps - ) where - -import PGF -import PGF.Data -import Data.List - -type TreeOp = [Expr] -> [Expr] - -treeOp :: PGF -> String -> Maybe (Either TreeOp (CId -> TreeOp)) -treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf - -allTreeOps :: PGF -> [(String,(String,Either TreeOp (CId -> TreeOp)))] -allTreeOps pgf = [ - ("compute",("compute by using semantic definitions (def)", - Left $ map (compute pgf))), - ("transfer",("syntactic transfer by applying function and computing", - Right $ \f -> map (compute pgf . EApp (EFun f)))), - ("paraphrase",("paraphrase by using semantic definitions (def)", - Left $ nub . concatMap (paraphrase pgf))), - ("smallest",("sort trees from smallest to largest, in number of nodes", - Left $ smallest)) - ] - -smallest :: [Expr] -> [Expr] -smallest = sortBy (\t u -> compare (size t) (size u)) where - size t = case t of - EAbs _ _ e -> size e + 1 - EApp e1 e2 -> size e1 + size e2 + 1 - _ -> 1 diff --git a/src/GF/Compile.hs b/src/GF/Compile.hs deleted file mode 100644 index e0c60178e..000000000 --- a/src/GF/Compile.hs +++ /dev/null @@ -1,252 +0,0 @@ -module GF.Compile (batchCompile, link, compileToPGF, compileSourceGrammar) where - --- the main compiler passes -import GF.Compile.GetGrammar -import GF.Compile.Rename -import GF.Compile.CheckGrammar -import GF.Compile.Optimize -import GF.Compile.SubExOpt -import GF.Compile.OptimizeGFCC -import GF.Compile.GrammarToGFCC -import GF.Compile.ReadFiles -import GF.Compile.Update -import GF.Compile.Refresh - -import GF.Compile.Coding -import GF.Text.UTF8 ---- - -import GF.Grammar.Grammar -import GF.Grammar.Lookup -import GF.Grammar.Printer -import GF.Grammar.Binary - -import GF.Infra.Ident -import GF.Infra.Option -import GF.Infra.Modules -import GF.Infra.UseIO -import GF.Infra.CheckM - -import GF.Data.Operations - -import Control.Monad -import System.IO -import System.Directory -import System.FilePath -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.List(nub) -import Data.Maybe (isNothing) -import Data.Binary -import Text.PrettyPrint - -import PGF.Check -import PGF.CId -import PGF.Data -import PGF.Macros - - --- | Compiles a number of source files and builds a 'PGF' structure for them. -compileToPGF :: Options -> [FilePath] -> IOE PGF -compileToPGF opts fs = - do gr <- batchCompile opts fs - let name = justModuleName (last fs) - link opts name gr - -link :: Options -> String -> SourceGrammar -> IOE PGF -link opts cnc gr = do - let isv = (verbAtLeast opts Normal) - gc1 <- putPointE Normal opts "linking ... " $ - let (abs,gc0) = mkCanon2gfcc opts cnc gr - in case checkPGF gc0 of - Ok (gc,b) -> do - case (isv,b) of - (True, True) -> ioeIO $ putStrLn "OK" - (False,True) -> return () - _ -> ioeIO $ putStrLn $ "Corrupted PGF" - return gc - Bad s -> fail s - ioeIO $ buildParser opts $ optimize opts gc1 - -optimize :: Options -> PGF -> PGF -optimize opts = cse . suf - where os = flag optOptimizations opts - cse = if OptCSE `Set.member` os then cseOptimize else id - suf = if OptStem `Set.member` os then suffixOptimize else id - -buildParser :: Options -> PGF -> IO PGF -buildParser opts = - case flag optBuildParser opts of - BuildParser -> addParsers opts - DontBuildParser -> return - BuildParserOnDemand -> return . mapConcretes (\cnc -> cnc { cflags = Map.insert (mkCId "parser") "ondemand" (cflags cnc) }) - -batchCompile :: Options -> [FilePath] -> IOE SourceGrammar -batchCompile opts files = do - (_,gr,_) <- foldM (compileModule opts) emptyCompileEnv files - return gr - --- to compile a set of modules, e.g. an old GF or a .cf file -compileSourceGrammar :: Options -> SourceGrammar -> IOE SourceGrammar -compileSourceGrammar opts gr@(MGrammar ms) = do - (_,gr',_) <- foldM compOne (0,emptySourceGrammar,Map.empty) ms - return gr' - where - compOne env mo = do - (k,mo') <- compileSourceModule opts env mo - extendCompileEnvInt env k Nothing mo' --- file for the same of modif time... - --- to output an intermediate stage -intermOut :: Options -> Dump -> Doc -> IOE () -intermOut opts d doc - | dump opts d = ioeIO (hPutStrLn stderr (encodeUTF8 (render (text "\n\n--#" <+> text (show d) $$ doc)))) - | otherwise = return () - --- | 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 -- ^ Options from program command line and shell command. - -> CompileEnv -> FilePath -> IOE CompileEnv -compileModule opts1 env file = do - file <- getRealFile file - opts0 <- getOptionsFromFile file - curr_dir <- return $ dropFileName file - lib_dir <- ioeIO $ getLibraryDirectory (addOptions opts0 opts1) - let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1 - ps0 <- ioeIO $ extendPathEnv opts - let ps = nub (curr_dir : ps0) - ioeIO $ putIfVerb opts $ "module search path:" +++ show ps ---- - let (_,sgr,rfs) = env - files <- getAllFiles opts ps rfs file - ioeIO $ putIfVerb opts $ "files to read:" +++ show files ---- - let names = map justModuleName files - ioeIO $ putIfVerb opts $ "modules to include:" +++ show names ---- - foldM (compileOne opts) (0,sgr,rfs) files - where - getRealFile file = do - exists <- ioeIO $ doesFileExist file - if exists - then return file - else if isRelative file - then do lib_dir <- ioeIO $ getLibraryDirectory opts1 - let file1 = lib_dir file - exists <- ioeIO $ doesFileExist file1 - if exists - then return file1 - else ioeErr $ Bad (render (text "None of this files exist:" $$ nest 2 (text file $$ text file1))) - else ioeErr $ Bad (render (text "File" <+> text file <+> text "does not exist.")) - -compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv -compileOne opts env@(_,srcgr,_) file = do - - let putpOpt v m act - | verbAtLeast opts Verbose = putPointE Normal opts v act - | verbAtLeast opts Normal = ioeIO (putStrFlush m) >> act - | otherwise = putPointE Verbose opts v act - - let gf = takeExtensions file - let path = dropFileName file - let name = dropExtension file - - case gf of - - -- for compiled gf, read the file and update environment - -- also undo common subexp optimization, to enable normal computations - ".gfo" -> do - sm00 <- putPointE Normal opts ("+ reading" +++ file) $ ioeIO (decodeFile file) - let sm0 = addOptionsToModule opts sm00 - - intermOut opts DumpSource (ppModule Qualified sm0) - - let sm1 = unsubexpModule sm0 - sm <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ extendModule srcgr sm1 - - extendCompileEnv env file sm - - -- for gf source, do full compilation and generate code - _ -> do - - let gfo = gf2gfo opts file - b1 <- ioeIO $ doesFileExist file - if not b1 - then compileOne opts env $ gfo - else do - - sm00 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ - getSourceModule opts file - let sm0 = decodeStringsInModule sm00 - - intermOut opts DumpSource (ppModule Qualified sm0) - - (k',sm) <- compileSourceModule opts env sm0 - putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo sm - extendCompileEnvInt env k' (Just gfo) sm - where - isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete - -compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule) -compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do - - let puts = putPointE Quiet opts - putpp = putPointE Verbose opts - - mo1 <- ioeErr $ rebuildModule gr mo - intermOut opts DumpRebuild (ppModule Qualified mo1) - - mo1b <- ioeErr $ extendModule gr mo1 - intermOut opts DumpExtend (ppModule Qualified mo1b) - - case mo1b of - (_,n) | not (isCompleteModule n) -> do - return (k,mo1b) -- refresh would fail, since not renamed - _ -> do - let mos = modules gr - - (mo2,warnings) <- putpp " renaming " $ ioeErr $ runCheck (renameModule mos mo1b) - if null warnings then return () else puts warnings $ return () - intermOut opts DumpRename (ppModule Qualified mo2) - - (mo3,warnings) <- putpp " type checking" $ ioeErr $ runCheck (checkModule mos mo2) - if null warnings then return () else puts warnings $ return () - intermOut opts DumpTypeCheck (ppModule Qualified mo3) - - (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3 - intermOut opts DumpRefresh (ppModule Qualified mo3r) - - mo4 <- putpp " optimizing " $ ioeErr $ optimizeModule opts mos mo3r - intermOut opts DumpOptimize (ppModule Qualified mo4) - - return (k',mo4) - -generateModuleCode :: Options -> FilePath -> SourceModule -> IOE SourceModule -generateModuleCode opts file minfo = do - let minfo1 = subexpModule minfo - minfo2 = case minfo1 of - (m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi) - , positions=Map.empty}) - putPointE Normal opts (" wrote file" +++ file) $ ioeIO $ encodeFile file minfo2 - return minfo1 - --- auxiliaries - -reverseModules (MGrammar ms) = MGrammar $ reverse ms - -emptyCompileEnv :: CompileEnv -emptyCompileEnv = (0,emptyMGrammar,Map.empty) - -extendCompileEnvInt (_,MGrammar ss,menv) k mfile sm = do - let (mod,imps) = importsOfModule sm - menv2 <- case mfile of - Just file -> do - t <- ioeIO $ getModificationTime file - return $ Map.insert mod (t,imps) menv - _ -> return menv - return (k,MGrammar (sm:ss),menv2) --- reverse later - -extendCompileEnv e@(k,_,_) file sm = extendCompileEnvInt e k (Just file) sm - - diff --git a/src/GF/Compile/Abstract/Compute.hs b/src/GF/Compile/Abstract/Compute.hs deleted file mode 100644 index d5c9a163c..000000000 --- a/src/GF/Compile/Abstract/Compute.hs +++ /dev/null @@ -1,138 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Compile.Abstract.Compute --- 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.Compile.Abstract.Compute (LookDef, - compute, - computeAbsTerm, - computeAbsTermIn, - beta - ) where - -import GF.Data.Operations - -import GF.Grammar -import GF.Grammar.Lookup - -import Debug.Trace -import Data.List(intersperse) -import Control.Monad (liftM, liftM2) -import Text.PrettyPrint - --- for debugging -tracd m t = t --- tracd = trace - -compute :: SourceGrammar -> Exp -> Err Exp -compute = computeAbsTerm - -computeAbsTerm :: SourceGrammar -> 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 Int,Maybe [Equation]) - -computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp -computeAbsTermIn lookd xs e = errIn (render (text "computing" <+> ppTerm Unqualified 0 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' = map snd yy ++ vv - aa' <- mapM (compt vv') aa - case look f of - Just eqs -> tracd (text "\nmatching" <+> ppTerm Unqualified 0 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 (text "by Egs:" <+> ppTerm Unqualified 0 d') $ return $ mkAbs yy $ d' - _ -> tracd (text "no match" <+> ppTerm Unqualified 0 t') $ - do - let v = mkApp f aa' - return $ mkAbs yy $ v - _ -> do - let t2 = mkAbs yy $ mkApp f aa' - tracd (text "not defined" <+> ppTerm Unqualified 0 t2) $ return t2 - - look t = case t of - (Q m f) -> case lookd m f of - Ok (_,md) -> md - _ -> Nothing - _ -> 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 b x a t -> Prod b x (beta vv a) (beta (x:vv) t) - Abs b x t -> Abs b x (beta (x:vv) t) - _ -> 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 $ render (text "no applicable case for" <+> hcat (punctuate comma (map (ppTerm Unqualified 0) terms))) - (patts,_):_ | length patts /= length terms -> - Bad (render (text "wrong number of args for patterns :" <+> - hsep (map (ppPatt Unqualified 0) patts) <+> text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms))) - (patts,val):cc -> case mapM tryMatch (zip patts terms) of - Ok substs -> return (tracd (text "value" <+> ppTerm Unqualified 0 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 - (PW, _) | 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' - (PAs x p',_) -> do - subst <- trym p' t' - return $ (x,t) : subst - _ -> Bad (render (text "no match in pattern" <+> ppPatt Unqualified 0 p <+> text "for" <+> ppTerm Unqualified 0 t)) - - notMeta e = case e of - Meta _ -> False - App f a -> notMeta f && notMeta a - Abs _ _ b -> notMeta b - _ -> True - - prtm p g = - ppPatt Unqualified 0 p <+> colon $$ hsep (punctuate semi [ppIdent x <+> char '=' <+> ppTerm Unqualified 0 y | (x,y) <- g]) diff --git a/src/GF/Compile/Abstract/TC.hs b/src/GF/Compile/Abstract/TC.hs deleted file mode 100644 index 163301838..000000000 --- a/src/GF/Compile/Abstract/TC.hs +++ /dev/null @@ -1,294 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : TC --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/02 20:50:19 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.11 $ --- --- Thierry Coquand's type checking algorithm that creates a trace ------------------------------------------------------------------------------ - -module GF.Compile.Abstract.TC (AExp(..), - Theory, - checkExp, - inferExp, - checkBranch, - eqVal, - whnf - ) where - -import GF.Data.Operations -import GF.Grammar -import GF.Grammar.Predef - -import Control.Monad -import Data.List (sortBy) -import Data.Maybe -import Text.PrettyPrint - -data AExp = - AVr Ident Val - | ACn QIdent Val - | AType - | AInt Integer - | AFloat Double - | AStr String - | AMeta MetaId Val - | AApp AExp AExp Val - | AAbs Ident Val AExp - | AProd Ident AExp AExp - | AEqs [([Exp],AExp)] --- not used - | ARecType [ALabelling] - | AR [AAssign] - | AP AExp Label Val - | AData Val - deriving (Eq,Show) - -type ALabelling = (Label, AExp) -type AAssign = (Label, (Val, AExp)) - -type Theory = QIdent -> Err Val - -lookupConst :: Theory -> QIdent -> Err Val -lookupConst th f = th f - -lookupVar :: Env -> Ident -> Err Val -lookupVar g x = maybe (Bad (render (text "unknown variable" <+> ppIdent 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) - RecType xs -> do xs <- mapM (\(l,e) -> eval env e >>= \e -> return (l,e)) xs - return (VRecType xs) - _ -> 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,[]) - - 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) - _ -> Bad (render (text "function type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ)) - - 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) - - R xs -> - case typ of - VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of - [] -> return () - ls -> fail (render (text "no value given for label:" <+> fsep (punctuate comma (map ppLabel ls)))) - r <- mapM (checkAssign th tenv ys) xs - let (xs,css) = unzip r - return (AR xs, concat css) - _ -> Bad (render (text "record type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ)) - - P r l -> do (r',cs) <- checkExp th tenv r (VRecType [(l,typ)]) - return (AP r' l typ,cs) - - _ -> 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 && isPredefCat c - -> 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, []) - RecType xs -> do r <- mapM (checkLabelling th tenv) xs - let (xs,css) = unzip r - return (ARecType xs, vType, concat css) - 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) - _ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ)) - _ -> Bad (render (text "cannot infer type of expression" <+> ppTerm Unqualified 0 e)) - -checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)]) -checkLabelling th tenv (lbl,typ) = do - (atyp,cs) <- checkType th tenv typ - return ((lbl,atyp),cs) - -checkAssign :: Theory -> TCEnv -> [(Label,Val)] -> Assign -> Err (AAssign, [(Val,Val)]) -checkAssign th tenv@(k,rho,gamma) typs (lbl,(Just typ,exp)) = do - (atyp,cs1) <- checkType th tenv typ - val <- eval rho typ - cs2 <- case lookup lbl typs of - Nothing -> return [] - Just val0 -> eqVal k val val0 - (aexp,cs3) <- checkExp th tenv exp val - return ((lbl,(val,aexp)),cs1++cs2++cs3) -checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do - case lookup lbl typs of - Nothing -> do (aexp,val,cs) <- inferExp th tenv exp - return ((lbl,(val,aexp)),cs) - Just val -> do (aexp,cs) <- checkExp th tenv exp val - return ((lbl,(val,aexp)),cs) - -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 - _ -> Bad (render (text "Product expected for definiens" <+> ppTerm Unqualified 0 t <+> text "instead of" <+> ppValue Unqualified 0 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 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 (Q m c) xss : ps, j, g',k') - where (xss,j,g',k') = foldr p2t ([],i,g,k) xs - _ -> error $ render (text "undefined p2t case" <+> ppPatt Unqualified 0 p <+> text "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) - _ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ)) - _ -> Bad (render (text "cannot typecheck pattern" <+> ppTerm Unqualified 0 exp)) - --- auxiliaries - -noConstr :: Err Val -> Err (Val,[(Val,Val)]) -noConstr er = er >>= (\v -> return (v,[])) - -mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)]) -mkAnnot a ti = do - (v,cs) <- ti - return (a v, v, cs) - diff --git a/src/GF/Compile/Abstract/TypeCheck.hs b/src/GF/Compile/Abstract/TypeCheck.hs deleted file mode 100644 index 2632c54dd..000000000 --- a/src/GF/Compile/Abstract/TypeCheck.hs +++ /dev/null @@ -1,83 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : TypeCheck --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/15 16:22:02 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.16 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Compile.Abstract.TypeCheck (-- * top-level type checking functions; TC should not be called directly. - checkContext, - checkTyp, - checkDef, - checkConstrs, - ) where - -import GF.Data.Operations - -import GF.Infra.CheckM -import GF.Grammar -import GF.Grammar.Lookup -import GF.Grammar.Unify -import GF.Compile.Refresh -import GF.Compile.Abstract.Compute -import GF.Compile.Abstract.TC - -import Text.PrettyPrint -import Control.Monad (foldM, liftM, liftM2) - --- | invariant way of creating TCEnv from context -initTCEnv gamma = - (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) - --- interface to TC type checker - -type2val :: Type -> Val -type2val = VClos [] - -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 - -justTypeCheck :: SourceGrammar -> Exp -> Val -> Err Constraints -justTypeCheck gr e v = do - (_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v - (constrs1,_) <- unifyVal constrs0 - return $ filter notJustMeta constrs1 - -notJustMeta (c,k) = case (c,k) of - (VClos g1 (Meta m1), VClos g2 (Meta m2)) -> False - _ -> True - -grammar2theory :: SourceGrammar -> 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 - -checkContext :: SourceGrammar -> Context -> [Message] -checkContext st = checkTyp st . cont2exp - -checkTyp :: SourceGrammar -> Type -> [Message] -checkTyp gr typ = err (\x -> [text x]) ppConstrs $ justTypeCheck gr typ vType - -checkDef :: SourceGrammar -> Fun -> Type -> [Equation] -> [Message] -checkDef gr (m,fun) typ eqs = err (\x -> [text x]) ppConstrs $ do - bcs <- mapM (\b -> checkBranch (grammar2theory gr) (initTCEnv []) b (type2val typ)) eqs - let (bs,css) = unzip bcs - (constrs,_) <- unifyVal (concat css) - return $ filter notJustMeta constrs - -checkConstrs :: SourceGrammar -> Cat -> [Ident] -> [String] -checkConstrs gr cat _ = [] ---- check constructors! diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs deleted file mode 100644 index f4765eb26..000000000 --- a/src/GF/Compile/CheckGrammar.hs +++ /dev/null @@ -1,284 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CheckGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:33 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.31 $ --- --- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003 --- --- type checking also does the following modifications: --- --- - types of operations and local constants are inferred and put in place --- --- - both these types and linearization types are computed --- --- - tables are type-annotated ------------------------------------------------------------------------------ - -module GF.Compile.CheckGrammar(checkModule) where - -import GF.Infra.Ident -import GF.Infra.Modules - -import GF.Compile.Abstract.TypeCheck -import GF.Compile.Concrete.TypeCheck - -import GF.Grammar -import GF.Grammar.Lexer -import GF.Grammar.Lookup -import GF.Grammar.Predef -import GF.Grammar.PatternMatch - -import GF.Data.Operations -import GF.Infra.CheckM - -import Data.List -import qualified Data.Set as Set -import Control.Monad -import Text.PrettyPrint - --- | checking is performed in the dependency order of modules -checkModule :: [SourceModule] -> SourceModule -> Check SourceModule -checkModule ms m@(name,mo) = checkIn (text "checking module" <+> ppIdent name) $ do - checkRestrictedInheritance ms m - m <- case mtype mo of - MTConcrete a -> do let gr = MGrammar (m:ms) - abs <- checkErr $ lookupModule gr a - checkCompleteGrammar gr (a,abs) m - _ -> return m - infos <- checkErr $ topoSortJments m - foldM updateCheckInfo m infos - where - updateCheckInfo (name,mo) (i,info) = do - info <- checkInfo ms (name,mo) i info - return (name,updateModule mo i info) - --- 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,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 -> checkError (text "In inherited module" <+> ppIdent i <> text ", dependence of excluded constants:" $$ - nest 2 (vcat [ppIdent f <+> text "on" <+> fsep (map ppIdent is) | (f,is) <- cs])) - allDeps = concatMap (allDependencies (const True) . jments . snd) mos - -checkCompleteGrammar :: SourceGrammar -> SourceModule -> SourceModule -> Check SourceModule -checkCompleteGrammar gr (am,abs) (cm,cnc) = do - let jsa = jments abs - let jsc = jments cnc - - -- check that all concrete constants are in abstract; build types for all lin - jsc <- foldM checkCnc emptyBinTree (tree2list jsc) - - -- check that all abstract constants are in concrete; build default lin and lincats - jsc <- foldM checkAbs jsc (tree2list jsa) - - return (cm,replaceJudgements cnc jsc) - where - checkAbs js i@(c,info) = - case info of - AbsFun (Just ty) _ _ -> do let mb_def = do - let (cxt,(_,i),_) = typeForm ty - info <- lookupIdent i js - info <- case info of - (AnyInd _ m) -> do (m,info) <- lookupOrigInfo gr m i - return info - _ -> return info - case info of - CncCat (Just (RecType [])) _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt) - _ -> Bad "no def lin" - - case lookupIdent c js of - Ok (AnyInd _ _) -> return js - Ok (CncFun ty (Just def) pn) -> - return $ updateTree (c,CncFun ty (Just def) pn) js - Ok (CncFun ty Nothing pn) -> - case mb_def of - Ok def -> return $ updateTree (c,CncFun ty (Just def) pn) js - Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c - return js - _ -> do - case mb_def of - Ok def -> do (cont,val) <- linTypeOfType gr cm ty - let linty = (snd (valCat ty),cont,val) - return $ updateTree (c,CncFun (Just linty) (Just def) Nothing) js - Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c - return js - AbsCat (Just _) _ -> case lookupIdent c js of - Ok (AnyInd _ _) -> return js - Ok (CncCat (Just _) _ _) -> return js - Ok (CncCat _ mt mp) -> do - checkWarn $ - text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}" - return $ updateTree (c,CncCat (Just defLinType) mt mp) js - _ -> do - checkWarn $ - text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}" - return $ updateTree (c,CncCat (Just defLinType) Nothing Nothing) js - _ -> return js - - checkCnc js i@(c,info) = - case info of - CncFun _ d pn -> case lookupOrigInfo gr am c of - Ok (_,AbsFun (Just ty) _ _) -> - do (cont,val) <- linTypeOfType gr cm ty - let linty = (snd (valCat ty),cont,val) - return $ updateTree (c,CncFun (Just linty) d pn) js - _ -> do checkWarn $ text "function" <+> ppIdent c <+> text "is not in abstract" - return js - CncCat _ _ _ -> case lookupOrigInfo gr am c of - Ok _ -> return $ updateTree i js - _ -> do checkWarn $ text "category" <+> ppIdent c <+> text "is not in abstract" - return js - _ -> return $ updateTree i js - - --- | General Principle: only Just-values are checked. --- A May-value has always been checked in its origin module. -checkInfo :: [SourceModule] -> SourceModule -> Ident -> Info -> Check Info -checkInfo ms (m,mo) c info = do - checkReservedId c - case info of - AbsCat (Just cont) _ -> mkCheck "category" $ - checkContext gr cont - - AbsFun (Just typ0) ma md -> do - typ <- compAbsTyp [] typ0 -- to calculate let definitions - mkCheck "type of function" $ - checkTyp gr typ - case md of - Just eqs -> mkCheck "definition of function" $ - checkDef gr (m,c) typ eqs - Nothing -> return info - return (AbsFun (Just typ) ma md) - - CncFun linty@(Just (cat,cont,val)) (Just trm) mpr -> chIn "linearization of" $ do - (trm',_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars - mpr <- checkPrintname gr mpr - return (CncFun linty (Just trm') mpr) - - CncCat (Just typ) mdef mpr -> chIn "linearization type of" $ do - (typ,_) <- checkLType gr [] typ typeType - typ <- computeLType gr [] typ - mdef <- case mdef of - Just def -> do - (def,_) <- checkLType gr [] def (mkFunType [typeStr] typ) - return $ Just def - _ -> return mdef - mpr <- checkPrintname gr mpr - return (CncCat (Just typ) mdef mpr) - - ResOper pty pde -> chIn "operation" $ do - (pty', pde') <- case (pty,pde) of - (Just ty, Just de) -> do - ty' <- checkLType gr [] ty typeType >>= computeLType gr [] . fst - (de',_) <- checkLType gr [] de ty' - return (Just ty', Just de') - (_ , Just de) -> do - (de',ty') <- inferLType gr [] de - return (Just ty', Just de') - (_ , Nothing) -> do - checkError (text "No definition given to the operation") - return (ResOper pty' pde') - - ResOverload os tysts -> chIn "overloading" $ do - tysts' <- mapM (uncurry $ flip (checkLType gr [])) tysts -- return explicit ones - tysts0 <- checkErr $ lookupOverload gr m c -- check against inherited ones too - tysts1 <- mapM (uncurry $ flip (checkLType gr [])) - [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0] - --- this can only be a partial guarantee, since matching - --- with value type is only possible if expected type is given - checkUniq $ - sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1] - return (ResOverload os [(y,x) | (x,y) <- tysts']) - - ResParam (Just pcs) _ -> chIn "parameter type" $ do - ts <- checkErr $ liftM concat $ mapM mkPar pcs - return (ResParam (Just pcs) (Just ts)) - - _ -> return info - where - gr = MGrammar ((m,mo) : ms) - chIn cat = checkIn (text "Happened in" <+> text cat <+> ppIdent c <+> ppPosition mo c <> colon) - - mkPar (f,co) = do - vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co - return $ map (mkApp (QC m f)) vs - - checkUniq xss = case xss of - x:y:xs - | x == y -> checkError $ text "ambiguous for type" <+> - ppType (mkFunType (tail x) (head x)) - | otherwise -> checkUniq $ y:xs - _ -> return () - - mkCheck cat ss = case ss of - [] -> return info - _ -> checkError (vcat ss $$ text "in" <+> text cat <+> ppIdent c <+> ppPosition mo c) - - compAbsTyp g t = case t of - Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g - Let (x,(_,a)) b -> do - a' <- compAbsTyp g a - compAbsTyp ((x, a'):g) b - Prod b x a t -> do - a' <- compAbsTyp g a - t' <- compAbsTyp ((x,Vr x):g) t - return $ Prod b x a' t' - Abs _ _ _ -> return t - _ -> composOp (compAbsTyp g) t - - -checkPrintname :: SourceGrammar -> Maybe Term -> Check (Maybe Term) -checkPrintname gr (Just t) = do (t,_) <- checkLType gr [] t typeStr - return (Just t) -checkPrintname gr Nothing = return Nothing - --- | for grammars obtained otherwise than by parsing ---- update!! -checkReservedId :: Ident -> Check () -checkReservedId x - | isReservedWord (ident2bs x) = checkWarn (text "reserved word used as identifier:" <+> ppIdent x) - | otherwise = return () - --- auxiliaries - --- | linearization types and defaults -linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type) -linTypeOfType cnc m typ = do - let (cont,cat) = 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 (render (text "extending" $$ - nest 2 (ppTerm Unqualified 0 vars) $$ - text "with" $$ - nest 2 (ppTerm Unqualified 0 val))) $ - plusRecType vars val - return (Explicit,symb,rec) - lookLin (_,c) = checks [ --- rather: update with defLinType ? - checkErr (lookupLincat cnc m c) >>= computeLType cnc [] - ,return defLinType - ] diff --git a/src/GF/Compile/Coding.hs b/src/GF/Compile/Coding.hs deleted file mode 100644 index 49538bd35..000000000 --- a/src/GF/Compile/Coding.hs +++ /dev/null @@ -1,55 +0,0 @@ -module GF.Compile.Coding where - -import GF.Grammar.Grammar -import GF.Grammar.Macros -import GF.Text.Coding -import GF.Infra.Modules -import GF.Infra.Option -import GF.Data.Operations - -import Data.Char - -encodeStringsInModule :: SourceModule -> SourceModule -encodeStringsInModule = codeSourceModule (encodeUnicode UTF_8) - -decodeStringsInModule :: SourceModule -> SourceModule -decodeStringsInModule mo = codeSourceModule (decodeUnicode (flag optEncoding (flagsModule mo))) mo - -codeSourceModule :: (String -> String) -> SourceModule -> SourceModule -codeSourceModule co (id,mo) = (id,replaceJudgements mo (mapTree codj (jments mo))) - where - codj (c,info) = case info of - ResOper pty pt -> ResOper (fmap (codeTerm co) pty) (fmap (codeTerm co) pt) - ResOverload es tyts -> ResOverload es [(codeTerm co ty,codeTerm co t) | (ty,t) <- tyts] - CncCat pty pt mpr -> CncCat pty (fmap (codeTerm co) pt) (fmap (codeTerm co) mpr) - CncFun mty pt mpr -> CncFun mty (fmap (codeTerm co) pt) (fmap (codeTerm co) mpr) - _ -> info - -codeTerm :: (String -> String) -> Term -> Term -codeTerm co t = case t of - K s -> K (co s) - T ty cs -> T ty [(codp p,codeTerm co v) | (p,v) <- cs] - EPatt p -> EPatt (codp p) - _ -> composSafeOp (codeTerm co) t - where - codp p = case p of --- really: composOpPatt - PR rs -> PR [(l,codp p) | (l,p) <- rs] - PString s -> PString (co s) - PChars s -> PChars (co s) - PT x p -> PT x (codp p) - PAs x p -> PAs x (codp p) - PNeg p -> PNeg (codp p) - PRep p -> PRep (codp p) - PSeq p q -> PSeq (codp p) (codp q) - PAlt p q -> PAlt (codp p) (codp q) - _ -> p - --- | Run an encoding function on all string literals within the given string. -codeStringLiterals :: (String -> String) -> String -> String -codeStringLiterals _ [] = [] -codeStringLiterals co ('"':cs) = '"' : inStringLiteral cs - where inStringLiteral [] = error "codeStringLiterals: unterminated string literal" - inStringLiteral ('"':ds) = '"' : codeStringLiterals co ds - inStringLiteral ('\\':d:ds) = '\\' : co [d] ++ inStringLiteral ds - inStringLiteral (d:ds) = co [d] ++ inStringLiteral ds -codeStringLiterals co (c:cs) = c : codeStringLiterals co cs diff --git a/src/GF/Compile/Concrete/AppPredefined.hs b/src/GF/Compile/Concrete/AppPredefined.hs deleted file mode 100644 index c05127191..000000000 --- a/src/GF/Compile/Concrete/AppPredefined.hs +++ /dev/null @@ -1,158 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : AppPredefined --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/06 14:21:34 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.13 $ --- --- Predefined function type signatures and definitions. ------------------------------------------------------------------------------ - -module GF.Compile.Concrete.AppPredefined (isInPredefined, typPredefined, appPredefined - ) where - -import GF.Infra.Ident -import GF.Data.Operations -import GF.Grammar.Predef -import GF.Grammar.Grammar -import GF.Grammar.Macros -import GF.Grammar.Printer -import qualified Data.ByteString.Char8 as BS -import Text.PrettyPrint - --- 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 f - | f == cInt = return typePType - | f == cFloat = return typePType - | f == cErrorType = return typeType - | f == cInts = return $ mkFunType [typeInt] typePType - | f == cPBool = return typePType - | f == cError = return $ mkFunType [typeStr] typeError -- non-can. of empty set - | f == cPFalse = return $ typePBool - | f == cPTrue = return $ typePBool - | f == cDp = return $ mkFunType [typeInt,typeTok] typeTok - | f == cDrop = return $ mkFunType [typeInt,typeTok] typeTok - | f == cEqInt = return $ mkFunType [typeInt,typeInt] typePBool - | f == cLessInt = return $ mkFunType [typeInt,typeInt] typePBool - | f == cEqStr = return $ mkFunType [typeTok,typeTok] typePBool - | f == cLength = return $ mkFunType [typeTok] typeInt - | f == cOccur = return $ mkFunType [typeTok,typeTok] typePBool - | f == cOccurs = return $ mkFunType [typeTok,typeTok] typePBool - | f == cPlus = return $ mkFunType [typeInt,typeInt] (typeInt) ----- "read" -> (P : Type) -> Tok -> P - | f == cShow = return $ mkProd -- (P : PType) -> P -> Tok - [(Explicit,varP,typePType),(Explicit,identW,Vr varP)] typeStr [] - | f == cToStr = return $ mkProd -- (L : Type) -> L -> Str - [(Explicit,varL,typeType),(Explicit,identW,Vr varL)] typeStr [] - | f == cMapStr = return $ mkProd -- (L : Type) -> (Str -> Str) -> L -> L - [(Explicit,varL,typeType),(Explicit,identW,mkFunType [typeStr] typeStr),(Explicit,identW,Vr varL)] (Vr varL) [] - | f == cTake = return $ mkFunType [typeInt,typeTok] typeTok - | f == cTk = return $ mkFunType [typeInt,typeTok] typeTok - | otherwise = Bad (render (text "unknown in Predef:" <+> ppIdent f)) - -varL :: Ident -varL = identC (BS.pack "L") - -varP :: Ident -varP = identC (BS.pack "P") - -appPredefined :: Term -> Err (Term,Bool) -appPredefined t = case t of - App f x0 -> do - (x,_) <- appPredefined x0 - case f of - -- one-place functions - Q mod f | mod == cPredef -> - case x of - (K s) | f == cLength -> retb $ EInt $ toInteger $ length s - _ -> retb t - - -- two-place functions - App (Q mod f) z0 | mod == cPredef -> do - (z,_) <- appPredefined z0 - case (norm z, norm x) of - (EInt i, K s) | f == cDrop -> retb $ K (drop (fi i) s) - (EInt i, K s) | f == cTake -> retb $ K (take (fi i) s) - (EInt i, K s) | f == cTk -> retb $ K (take (max 0 (length s - fi i)) s) - (EInt i, K s) | f == cDp -> retb $ K (drop (max 0 (length s - fi i)) s) - (K s, K t) | f == cEqStr -> retb $ if s == t then predefTrue else predefFalse - (K s, K t) | f == cOccur -> retb $ if substring s t then predefTrue else predefFalse - (K s, K t) | f == cOccurs -> retb $ if any (flip elem t) s then predefTrue else predefFalse - (EInt i, EInt j) | f == cEqInt -> retb $ if i==j then predefTrue else predefFalse - (EInt i, EInt j) | f == cLessInt -> retb $ if i retb $ EInt $ i+j - (_, t) | f == cShow -> retb $ foldr C Empty $ map K $ words $ render (ppTerm Unqualified 0 t) - (_, K s) | f == cRead -> retb $ Cn (identC (BS.pack s)) --- because of K, only works for atomic tags - (_, t) | f == cToStr -> trm2str t >>= retb - _ -> retb t ---- prtBad "cannot compute predefined" t - - -- three-place functions - App (App (Q mod f) z0) y0 | mod == cPredef -> do - (y,_) <- appPredefined y0 - (z,_) <- appPredefined z0 - case (z, y, x) of - (ty,op,t) | f == cMapStr -> 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 (retc t,True) -- no further computing needed - retf t = return (retc t,False) -- must be computed further - retc t = case t of - K [] -> t - K s -> foldr1 C (map K (words s)) - _ -> t - norm t = case t of - Empty -> K [] - C u v -> case (norm u,norm v) of - (K x,K y) -> K (x +++ y) - _ -> t - _ -> t - fi = fromInteger - --- read makes variables into constants - -predefTrue = QC cPredef cPTrue -predefFalse = QC cPredef cPFalse - -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 - _ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t)) - --- simultaneous recursion on type and term: type arg is essential! --- But simplify the task by assuming records are type-annotated --- (this has been done in type checking) -mapStr :: Type -> Term -> Term -> Term -mapStr ty f t = case (ty,t) of - _ | elem ty [typeStr,typeTok] -> App f t - (_, R ts) -> R [(l,mapField v) | (l,v) <- ts] - (Table a b,T ti cs) -> T ti [(p,mapStr b f v) | (p,v) <- cs] - _ -> t - where - mapField (mty,te) = case mty of - Just ty -> (mty,mapStr ty f te) - _ -> (mty,te) diff --git a/src/GF/Compile/Concrete/Compute.hs b/src/GF/Compile/Concrete/Compute.hs deleted file mode 100644 index 9c016116b..000000000 --- a/src/GF/Compile/Concrete/Compute.hs +++ /dev/null @@ -1,456 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Compile.Concrete.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.Compile.Concrete.Compute (computeConcrete, computeTerm,computeConcreteRec) where - -import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Option -import GF.Infra.Modules -import GF.Data.Str -import GF.Grammar.Printer -import GF.Grammar.Predef -import GF.Grammar.Macros -import GF.Grammar.Lookup -import GF.Compile.Refresh -import GF.Grammar.PatternMatch -import GF.Grammar.Lockfield (isLockLabel,unlockRecord) ---- - -import GF.Compile.Concrete.AppPredefined - -import Data.List (nub,intersperse) -import Control.Monad (liftM2, liftM) -import Text.PrettyPrint - --- | 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 p c | p == cPredef -> return t - | otherwise -> look p c - - Vr x -> do - t' <- maybe (Bad (render (text "no value given to variable" <+> ppIdent x))) return $ lookup x g - case t' of - _ | t == t' -> return t - _ -> comp g t' - - -- Abs x@(IA _) b -> do - Abs _ _ _ | 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 b x a t -> do - a' <- comp g a - t' <- comp (ext x (Vr x) g) t - return $ Prod b x a' t' - - -- 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 mod f | mod == cPredef -> 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 (map snd 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 (Bad (render (text "no value for label" <+> ppLabel 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 - - S t v -> do - t' <- compTable g t - v' <- comp g v - t1 <- case t' of ----- V (RecType fs) _ -> uncurrySelect g fs t' v' ----- T (TComp (RecType fs)) _ -> uncurrySelect g fs t' v' - _ -> return $ S t' v' - compSelect g t1 - - -- 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 (d,aa) -> do - d' <- comp g d - aa' <- mapM (compInAlts g) aa - returnC (Alts (d',aa')) - - -- 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' - - ELin c r -> do - r' <- comp g r - unlockRecord c r' - - T _ _ -> compTable g t - V _ _ -> compTable g t - - -- 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' - - (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 - - 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' - _ -> Bad (render (text "pattern expected as value of" $$ nest 2 (ppPatt Unqualified 0 p))) - 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 - - compSelect g (S t' 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 _ [(PW,c)] -> comp g c --- an optimization - T _ [(PT _ PW,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 lookupR v' (zip vs [0 .. length vs - 1]) of - Just i -> comp g $ ts !! i - _ -> return $ S t' v' -- if v' is not canonical - T _ cc -> do - case matchPattern cc v' of - Ok (c,g') -> comp (g' ++ g) c - _ | isCan v' -> Bad (render (text "missing case" <+> ppTerm Unqualified 0 v' <+> text "in" <+> ppTerm Unqualified 0 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' - - --- needed to match records with and without type information - ---- todo: eliminate linear search in a list of records! - lookupR v vs = case v of - R rs -> lookup ([(x,y) | (x,(_,y)) <- rs]) - [([(x,y) | (x,(_,y)) <- rs],v) | (R rs,v) <- vs] - _ -> lookup v vs - - -- case-expand tables - -- if already expanded, don't expand again - compTable g t = case t of - 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' - V ty cs -> do - ty' <- comp g ty - -- if there are no variables, don't even go inside - cs' <- if (null g) then return cs else mapM (comp g) cs - return $ V ty' cs' - - T i cs -> do - pty0 <- getTableType i - ptyp <- comp g pty0 - case allParamValues gr ptyp of - Ok vs0 -> do - let vs = vs0 ---- [Val v ptyp i | (v,i) <- zip vs0 [0..]] - 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 - ps0 <- mapM (compPatternMacro . fst) cs - cs' <- mapM (compBranch g) (zip ps0 (map snd cs)) - ----- cs' <- mapM (compBranch g) cs - return $ T i cs' -- happens with variable types - _ -> comp g t - - 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 - - compInAlts g (v,c) = do - v' <- comp g v - c' <- comp g c - c2 <- case c' of - EPatt p -> liftM Strs $ getPatts p - _ -> return c' - return (v',c2) - where - getPatts p = case p of - PAlt a b -> liftM2 (++) (getPatts a) (getPatts b) - PString s -> return [K s] - PSeq a b -> do - as <- getPatts a - bs <- getPatts b - return [K (s ++ t) | K s <- as, K t <- bs] - _ -> fail (render (text "not valid pattern in pre expression" <+> ppPatt Unqualified 0 p)) - -{- ---- - uncurrySelect g fs t v = do - ts <- mapM (allParamValues gr . snd) fs - vs <- mapM (comp g) [P v r | r <- map fst fs] - return $ reorderSelect t fs ts vs - - reorderSelect t fs pss vs = case (t,fs,pss,vs) of - (V _ ts, f:fs1, ps:pss1, v:vs1) -> - S (V (snd f) - [reorderSelect (V (RecType fs1) t) fs1 pss1 vs1 | - t <- segments (length ts `div` length ps) ts]) v - (T (TComp _) cs, f:fs1, ps:pss1, v:vs1) -> - S (T (TComp (snd f)) - [(p,reorderSelect (T (TComp (RecType fs1)) c) fs1 pss1 vs1) | - (ep,c) <- zip ps (segments (length cs `div` length ps) cs), - let Ok p = term2patt ep]) v - _ -> t - - segments i xs = - let (x0,xs1) = splitAt i xs in x0 : takeWhile (not . null) (segments i xs1) --} - - --- | argument variables cannot be glued -checkNoArgVars :: Term -> Err Term -checkNoArgVars t = case t of - Vr (IA _ _) -> Bad $ glueErrorMsg $ ppTerm Unqualified 0 t - Vr (IAV _ _ _) -> Bad $ glueErrorMsg $ ppTerm Unqualified 0 t - _ -> composOp checkNoArgVars t - -glueErrorMsg s = - render (text "Cannot glue (+) term with run-time variable" <+> s <> char '.' $$ - text "Use Prelude.bind instead.") - -getArgType t = case t of - V ty _ -> return ty - T (TComp ty) _ -> return ty - _ -> Bad (render (text "cannot get argument type of table" $$ nest 2 (ppTerm Unqualified 0 t))) diff --git a/src/GF/Compile/Concrete/TypeCheck.hs b/src/GF/Compile/Concrete/TypeCheck.hs deleted file mode 100644 index 670f36625..000000000 --- a/src/GF/Compile/Concrete/TypeCheck.hs +++ /dev/null @@ -1,690 +0,0 @@ -{-# LANGUAGE PatternGuards #-} -module GF.Compile.Concrete.TypeCheck( checkLType, inferLType, computeLType, ppType ) where - -import GF.Infra.CheckM -import GF.Infra.Modules -import GF.Data.Operations - -import GF.Grammar -import GF.Grammar.Lookup -import GF.Grammar.Predef -import GF.Grammar.PatternMatch -import GF.Grammar.Lockfield (isLockLabel, lockRecType, unlockRecord) -import GF.Compile.Concrete.AppPredefined - -import Data.List -import Control.Monad -import Text.PrettyPrint - -computeLType :: SourceGrammar -> Context -> Type -> Check Type -computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t - where - comp g ty = case ty of - _ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed - | isPredefConstant ty -> return ty ---- shouldn't be needed - - Q m ident -> checkIn (text "module" <+> ppIdent m) $ do - ty' <- checkErr (lookupResDef gr m ident) - if ty' == ty then return ty else comp g ty' --- is this necessary to test? - - Vr ident -> checkLookup ident g -- never needed to compute! - - App f a -> do - f' <- comp g f - a' <- comp g a - case f' of - Abs b x t -> comp ((b,x,a'):g) t - _ -> return $ App f' a' - - Prod bt x a b -> do - a' <- comp g a - b' <- comp ((bt,x,Vr x) : g) b - return $ Prod bt x a' b' - - Abs bt x b -> do - b' <- comp ((bt,x,Vr x):g) b - return $ Abs bt x b' - - ExtR r s -> do - r' <- comp g r - s' <- comp g s - case (r',s') of - (RecType rs, RecType ss) -> checkErr (plusRecType r' s') >>= comp g - _ -> return $ ExtR r' s' - - RecType fs -> do - let fs' = sortRec fs - liftM RecType $ mapPairsM (comp g) fs' - - ELincat c t -> do - t' <- comp g t - checkErr $ lockRecType c t' ---- locking to be removed AR 20/6/2009 - - _ | ty == typeTok -> return typeStr - _ | isPredefConstant ty -> return ty - - _ -> composOp (comp g) ty - --- the underlying algorithms - -inferLType :: SourceGrammar -> Context -> Term -> Check (Term, Type) -inferLType gr g 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) >>= computeLType gr g - , - checkErr (lookupResDef gr m ident) >>= inferLType gr g - , - checkError (text "cannot infer type of constant" <+> ppTerm Unqualified 0 trm) - ] - - QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) - - QC m ident -> checks [ - termWith trm $ checkErr (lookupResType gr m ident) >>= computeLType gr g - , - checkErr (lookupResDef gr m ident) >>= inferLType gr g - , - checkError (text "cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm) - ] - - Vr ident -> termWith trm $ checkLookup ident g - - Typed e t -> do - t' <- computeLType gr g t - checkLType gr g e t' - return (e,t') - - App f a -> do - over <- getOverload gr g Nothing trm - case over of - Just trty -> return trty - _ -> do - (f',fty) <- inferLType gr g f - fty' <- computeLType gr g fty - case fty' of - Prod bt z arg val -> do - a' <- justCheck g a arg - ty <- if isWildIdent z - then return val - else substituteLType [(bt,z,a')] val - return (App f' a',ty) - _ -> checkError (text "A function type is expected for" <+> ppTerm Unqualified 0 f <+> text "instead of type" <+> ppType fty) - - S f x -> do - (f', fty) <- inferLType gr g f - case fty of - Table arg val -> do - x'<- justCheck g x arg - return (S f' x', val) - _ -> checkError (text "table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm)) - - P t i -> do - (t',ty) <- inferLType gr g t --- ?? - ty' <- computeLType gr g ty - let tr2 = P t' i - termWith tr2 $ case ty' of - RecType ts -> case lookup i ts of - Nothing -> checkError (text "unknown label" <+> ppLabel i <+> text "in" $$ nest 2 (ppTerm Unqualified 0 ty')) - Just x -> return x - _ -> checkError (text "record type expected for:" <+> ppTerm Unqualified 0 t $$ - text " instead of the inferred:" <+> ppTerm Unqualified 0 ty') - - R r -> do - let (ls,fs) = unzip r - fsts <- mapM inferM fs - let ts = [ty | (Just ty,_) <- fsts] - checkCond (text "cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 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 - checkLType gr g trm (Table arg val) - T (TComp arg) pts -> do - (_,val) <- checks $ map (inferCase (Just arg)) pts - checkLType gr g 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 - [] -> checkError (text "cannot infer table type of" <+> ppTerm Unqualified 0 trm) ----- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] - _ -> do - (arg,val) <- checks $ map (inferCase Nothing) pts' - checkLType gr g trm (Table arg val) - V arg pts -> do - (_,val) <- checks $ map (inferLType gr g) pts - return (trm, Table arg val) - - K s -> do - if elem ' ' s - then do - let ss = foldr C Empty (map K (words s)) - ----- removed irritating warning AR 24/5/2008 - ----- checkWarn ("token \"" ++ s ++ - ----- "\" converted to token list" ++ prt ss) - return (ss, typeStr) - else return (trm, typeStr) - - EInt i -> return (trm, typeInt) - - EFloat i -> return (trm, typeFloat) - - Empty -> return (trm, typeStr) - - C s1 s2 -> - check2 (flip (justCheck g) typeStr) C s1 s2 typeStr - - Glue s1 s2 -> - check2 (flip (justCheck g) typeStr) Glue s1 s2 typeStr ---- typeTok - ----- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007 - Strs (Cn c : ts) | c == cConflict -> do - checkWarn (text "unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts)) - inferLType gr g (head ts) - - Strs ts -> do - ts' <- mapM (\t -> justCheck g t typeStr) ts - return (Strs ts', typeStrs) - - Alts (t,aa) -> do - t' <- justCheck g t typeStr - aa' <- flip mapM aa (\ (c,v) -> do - c' <- justCheck g c typeStr - v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr] - return (c',v')) - return (Alts (t',aa'), typeStr) - - RecType r -> do - let (ls,ts) = unzip r - ts' <- mapM (flip (justCheck g) typeType) ts - return (RecType (zip ls ts'), typeType) - - ExtR r s -> do - (r',rT) <- inferLType gr g r - rT' <- computeLType gr g rT - (s',sT) <- inferLType gr g s - sT' <- computeLType gr g 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' - checkLType gr g trm' rt ---- return (trm', rt) - _ | rT' == typeType && sT' == typeType -> return (trm', typeType) - _ -> checkError (text "records or record types expected in" <+> ppTerm Unqualified 0 trm) - - Sort _ -> - termWith trm $ return typeType - - Prod bt x a b -> do - a' <- justCheck g a typeType - b' <- justCheck ((bt,x,a'):g) b typeType - return (Prod bt x a' b', typeType) - - Table p t -> do - p' <- justCheck g p typeType --- check p partype! - t' <- justCheck g t typeType - return $ (Table p' t', typeType) - - FV vs -> do - (_,ty) <- checks $ map (inferLType gr g) vs ---- checkIfComplexVariantType trm ty - checkLType gr g trm ty - - EPattType ty -> do - ty' <- justCheck g ty typeType - return (EPattType ty',typeType) - EPatt p -> do - ty <- inferPatt p - return (trm, EPattType ty) - - ELin c trm -> do - (trm',ty) <- inferLType gr g trm - ty' <- checkErr $ lockRecType c ty ---- lookup c; remove lock AR 20/6/2009 - return $ (ELin c trm', ty') - - _ -> checkError (text "cannot infer lintype of" <+> ppTerm Unqualified 0 trm) - - where - isPredef m = elem m [cPredef,cPredefAbs] - - justCheck g ty te = checkLType gr g ty te >>= return . fst - - -- for record fields, which may be typed - inferM (mty, t) = do - (t', ty') <- case mty of - Just ty -> checkLType gr g ty t - _ -> inferLType gr g t - return (Just ty',t') - - inferCase mty (patt,term) = do - arg <- maybe (inferPatt patt) return mty - cont <- pattContext gr g arg patt - (_,val) <- inferLType gr (reverse cont ++ g) term - 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 $ liftM valTypeCnc (lookupResType gr q c) - 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 - _ -> inferLType gr g (patt2term p) >>= return . snd - - --- type inference: Nothing, type checking: Just t --- the latter permits matching with value type -getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type)) -getOverload gr g mt ot = case appForm ot of - (f@(Q m c), ts) -> case lookupOverload gr m c of - Ok typs -> do - ttys <- mapM (inferLType gr g) ts - v <- matchOverload f typs ttys - return $ Just v - _ -> return Nothing - _ -> return Nothing - where - matchOverload f typs ttys = do - let (tts,tys) = unzip ttys - let vfs = lookupOverloadInstance tys typs - let matches = [vf | vf@((v,_),_) <- vfs, matchVal mt v] - - case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of - ([(val,fun)],_) -> return (mkApp fun tts, val) - ([],[(val,fun)]) -> do - checkWarn (text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot) - return (mkApp fun tts, val) - ([],[]) -> do - let showTypes ty = hsep (map ppType ty) - checkError $ text "no overload instance of" <+> ppTerm Unqualified 0 f $$ - text "for" $$ - nest 2 (showTypes tys) $$ - text "among" $$ - nest 2 (vcat [showTypes ty | (ty,_) <- typs]) $$ - maybe empty (\x -> text "with value type" <+> ppType x) mt - - (vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of - ([(val,fun)],_) -> do - return (mkApp fun tts, val) - ([],[(val,fun)]) -> do - checkWarn (text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot) - return (mkApp fun tts, val) - ------ unsafely exclude irritating warning AR 24/5/2008 ------ checkWarn $ "overloading of" +++ prt f +++ ------ "resolved by excluding partial applications:" ++++ ------ unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)] - - - _ -> checkError $ text "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+> - text "for" <+> hsep (map ppType tys) $$ - text "with alternatives" $$ - nest 2 (vcat [ppType ty | (ty,_) <- if null vfs1 then vfs2 else vfs2]) - - matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)] - - unlocked v = case v of - RecType fs -> RecType $ filter (not . isLockLabel . fst) fs - _ -> v - ---- TODO: accept subtypes - ---- TODO: use a trie - lookupOverloadInstance tys typs = - [((mkFunType rest val, t),isExact) | - let lt = length tys, - (ty,(val,t)) <- typs, length ty >= lt, - let (pre,rest) = splitAt lt ty, - let isExact = pre == tys, - isExact || map unlocked pre == map unlocked tys - ] - - noProds vfs = [(v,f) | (v,f) <- vfs, noProd v] - - noProd ty = case ty of - Prod _ _ _ _ -> False - _ -> True - -checkLType :: SourceGrammar -> Context -> Term -> Type -> Check (Term, Type) -checkLType gr g trm typ0 = do - - typ <- computeLType gr g typ0 - - case trm of - - Abs bt x c -> do - case typ of - Prod bt' z a b -> do - (c',b') <- if isWildIdent z - then checkLType gr ((bt,x,a):g) c b - else do b' <- checkIn (text "abs") $ substituteLType [(bt',z,Vr x)] b - checkLType gr ((bt,x,a):g) c b' - return $ (Abs bt x c', Prod bt' x a b') - _ -> checkError $ text "function type expected instead of" <+> ppType typ - - App f a -> do - over <- getOverload gr g (Just typ) trm - case over of - Just trty -> return trty - _ -> do - (trm',ty') <- inferLType gr g trm - termWith trm' $ checkEqLType gr g typ ty' trm' - - Q _ _ -> do - over <- getOverload gr g (Just typ) trm - case over of - Just trty -> return trty - _ -> do - (trm',ty') <- inferLType gr g trm - termWith trm' $ checkEqLType gr g typ ty' trm' - - T _ [] -> - checkError (text "found empty table in type" <+> ppTerm Unqualified 0 typ) - T _ cs -> case typ of - Table arg val -> do - case allParamValues gr arg of - Ok vs -> do - let ps0 = map fst cs - ps <- checkErr $ testOvershadow ps0 vs - if null ps - then return () - else checkWarn (text "patterns never reached:" $$ - nest 2 (vcat (map (ppPatt Unqualified 0) ps))) - _ -> return () -- happens with variable types - cs' <- mapM (checkCase arg val) cs - return (T (TTyped arg) cs', typ) - _ -> checkError $ text "table type expected for table instead of" $$ nest 2 (ppType 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 - - _ -> checkError (text "record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ)) - - ExtR r s -> case typ of - _ | typ == typeType -> do - trm' <- computeLType gr g trm - case trm' of - RecType _ -> termWith trm $ return typeType - ExtR (Vr _) (RecType _) -> termWith trm $ return typeType - -- ext t = t ** ... - _ -> checkError (text "invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm)) - RecType rr -> do - (r',ty,s') <- checks [ - do (r',ty) <- inferLType gr g r - return (r',ty,s) - , - do (s',ty) <- inferLType gr g s - return (s',ty,r) - ] - case ty of - RecType rr1 -> do - let (rr0,rr2) = recParts rr rr1 - r2 <- justCheck g r' rr0 - s2 <- justCheck g s' rr2 - return $ (ExtR r2 s2, typ) - _ -> checkError (text "record type expected in extension of" <+> ppTerm Unqualified 0 r $$ - text "but found" <+> ppTerm Unqualified 0 ty) - - ExtR ty ex -> do - r' <- justCheck g r ty - s' <- justCheck g s ex - return $ (ExtR r' s', typ) --- is this all? - - _ -> checkError (text "record extension not meaningful for" <+> ppTerm Unqualified 0 typ) - - FV vs -> do - ttys <- mapM (flip (checkLType gr g) typ) vs ---- checkIfComplexVariantType trm typ - return (FV (map fst ttys), typ) --- typ' ? - - S tab arg -> checks [ do - (tab',ty) <- inferLType gr g tab - ty' <- computeLType gr g ty - case ty' of - Table p t -> do - (arg',val) <- checkLType gr g arg p - checkEqLType gr g typ t trm - return (S tab' arg', t) - _ -> checkError (text "table type expected for applied table instead of" <+> ppType ty') - , do - (arg',ty) <- inferLType gr g arg - ty' <- computeLType gr g ty - (tab',_) <- checkLType gr g tab (Table ty' typ) - return (S tab' arg', typ) - ] - Let (x,(mty,def)) body -> case mty of - Just ty -> do - (def',ty') <- checkLType gr g def ty - body' <- justCheck ((Explicit,x,ty'):g) body typ - return (Let (x,(Just ty',def')) body', typ) - _ -> do - (def',ty) <- inferLType gr g def -- tries to infer type of local constant - checkLType gr g (Let (x,(Just ty,def')) body) typ - - ELin c tr -> do - tr1 <- checkErr $ unlockRecord c tr - checkLType gr g tr1 typ - - _ -> do - (trm',ty') <- inferLType gr g trm - termWith trm' $ checkEqLType gr g typ ty' trm' - where - justCheck g ty te = checkLType gr g ty te >>= return . fst - - 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 - checkEqLType gr g ty ty0 t - (t',ty') <- checkLType gr g t ty - return (l,(Just ty',t')) - Just (_,t) -> do - (t',ty') <- checkLType gr g t ty - return (l,(Just ty',t')) - _ -> checkError $ - if isLockLabel l - then let cat = drop 5 (showIdent (label2ident l)) - in ppTerm Unqualified 0 (R rms) <+> text "is not in the lincat of" <+> text cat <> - text "; try wrapping it with lin" <+> text cat - else text "cannot find value for label" <+> ppLabel l <+> text "in" <+> ppTerm Unqualified 0 (R rms) - - checkCase arg val (p,t) = do - cont <- pattContext gr g arg p - t' <- justCheck (reverse cont ++ g) t val - return (p,t') - -pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context -pattContext env g typ p = case p of - PV x -> return [(Explicit,x,typ)] - PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006 - t <- checkErr $ lookupResType env q c - let (cont,v) = typeFormCnc t - checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p) - (length cont == length ps) - checkEqLType env g typ v (patt2term p) - mapM (\((_,_,ty),p) -> pattContext env g ty p) (zip cont ps) >>= return . concat - PR r -> do - typ' <- computeLType env g 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 g)) pts >>= return . concat - _ -> checkError (text "record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ') - PT t p' -> do - checkEqLType env g typ t (patt2term p') - pattContext env g typ p' - - PAs x p -> do - g' <- pattContext env g typ p - return ((Explicit,x,typ):g') - - PAlt p' q -> do - g1 <- pattContext env g typ p' - g2 <- pattContext env g typ q - let pts = nub ([x | pt@(_,x,_) <- g1, notElem pt g2] ++ [x | pt@(_,x,_) <- g2, notElem pt g1]) - checkCond - (text "incompatible bindings of" <+> - fsep (map ppIdent pts) <+> - text "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts) - return g1 -- must be g1 == g2 - PSeq p q -> do - g1 <- pattContext env g typ p - g2 <- pattContext env g typ q - return $ g1 ++ g2 - PRep p' -> noBind typeStr p' - PNeg p' -> noBind typ p' - - _ -> return [] ---- check types! - where - noBind typ p' = do - co <- pattContext env g typ p' - if not (null co) - then checkWarn (text "no variable bound inside pattern" <+> ppPatt Unqualified 0 p) - >> return [] - else return [] - -checkEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check Type -checkEqLType gr g t u trm = do - (b,t',u',s) <- checkIfEqLType gr g t u trm - case b of - True -> return t' - False -> checkError $ text s <+> text "type of" <+> ppTerm Unqualified 0 trm $$ - text "expected:" <+> ppType t $$ - text "inferred:" <+> ppType u - -checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String) -checkIfEqLType gr g t u trm = do - t' <- computeLType gr g t - u' <- computeLType gr g 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 $ text "missing lock field" <+> fsep (map ppLabel 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 - (_,u) | u == typeError -> 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 - (t,u) | Just m <- isTypeInts t, Just n <- isTypeInts t -> m >= n - | Just _ <- isTypeInts t, u == typeInt -> True ---- check size! - | t == typeInt, Just _ <- isTypeInts u -> True ---- why this ???? AR 11/12/2005 - - ---- this should be made in Rename - (Q m a, Q n b) | a == b -> elem m (allExtendsPlus gr n) - || elem n (allExtendsPlus gr m) - || m == n --- for Predef - (QC m a, QC n b) | a == b -> elem m (allExtendsPlus gr n) - || elem n (allExtendsPlus gr m) - (QC m a, Q n b) | a == b -> elem m (allExtendsPlus gr n) - || elem n (allExtendsPlus gr m) - (Q m a, QC n b) | a == b -> elem m (allExtendsPlus gr n) - || elem n (allExtendsPlus gr 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 $ render (text "missing record fields:" <+> fsep (punctuate comma (map ppLabel 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] - --- auxiliaries - --- | 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 [(x,t) | (_,x,t) <- g] - _ -> composOp (substituteLType g) t - -termWith :: Term -> Check Type -> Check (Term, Type) -termWith t ct = do - ty <- ct - return (t,ty) - --- | 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) - --- printing a type with a lock field lock_C as C -ppType :: Type -> Doc -ppType ty = - case ty of - RecType fs -> case filter isLockLabel $ map fst fs of - [lock] -> text (drop 5 (showIdent (label2ident lock))) - _ -> ppTerm Unqualified 0 ty - Prod _ x a b -> ppType a <+> text "->" <+> ppType b - _ -> ppTerm Unqualified 0 ty - -checkLookup :: Ident -> Context -> Check Type -checkLookup x g = - case [ty | (b,y,ty) <- g, x == y] of - [] -> checkError (text "unknown variable" <+> ppIdent x) - (ty:_) -> return ty diff --git a/src/GF/Compile/Export.hs b/src/GF/Compile/Export.hs deleted file mode 100644 index d03eb947e..000000000 --- a/src/GF/Compile/Export.hs +++ /dev/null @@ -1,64 +0,0 @@ -module GF.Compile.Export where - -import PGF.CId -import PGF.Data (PGF(..)) -import GF.Compile.GFCCtoHaskell -import GF.Compile.GFCCtoProlog -import GF.Compile.GFCCtoJS -import GF.Compile.PGFPretty -import GF.Infra.Option -import GF.Speech.CFG -import GF.Speech.PGFToCFG -import GF.Speech.SRGS_ABNF -import GF.Speech.SRGS_XML -import GF.Speech.JSGF -import GF.Speech.GSL -import GF.Speech.SRG -import GF.Speech.VoiceXML -import GF.Speech.SLF -import GF.Speech.PrRegExp - -import Data.Maybe -import System.FilePath - --- top-level access to code generation - -exportPGF :: Options - -> OutputFormat - -> PGF - -> [(FilePath,String)] -- ^ List of recommended file names and contents. -exportPGF opts fmt pgf = - case fmt of - FmtPGFPretty -> multi "txt" prPGFPretty - FmtPMCFGPretty -> single "pmcfg" prPMCFGPretty - FmtJavaScript -> multi "js" pgf2js - FmtHaskell -> multi "hs" (grammar2haskell opts name) - FmtProlog -> multi "pl" grammar2prolog - FmtProlog_Abs -> multi "pl" grammar2prolog_abs - FmtBNF -> single "bnf" bnfPrinter - FmtEBNF -> single "ebnf" (ebnfPrinter opts) - FmtSRGS_XML -> single "grxml" (srgsXmlPrinter opts) - FmtSRGS_XML_NonRec -> single "grxml" (srgsXmlNonRecursivePrinter opts) - FmtSRGS_ABNF -> single "gram" (srgsAbnfPrinter opts) - FmtSRGS_ABNF_NonRec -> single "gram" (srgsAbnfNonRecursivePrinter opts) - FmtJSGF -> single "jsgf" (jsgfPrinter opts) - FmtGSL -> single "gsl" (gslPrinter opts) - FmtVoiceXML -> single "vxml" grammar2vxml - FmtSLF -> single "slf" slfPrinter - FmtRegExp -> single "rexp" regexpPrinter - FmtFA -> single "dot" slfGraphvizPrinter - where - name = fromMaybe (showCId (absname pgf)) (flag optName opts) - - multi :: String -> (PGF -> String) -> [(FilePath,String)] - multi ext pr = [(name <.> ext, pr pgf)] - - single :: String -> (PGF -> CId -> String) -> [(FilePath,String)] - single ext pr = [(showCId cnc <.> ext, pr pgf cnc) | cnc <- cncnames pgf] - --- | Get the name of the concrete syntax to generate output from. --- FIXME: there should be an option to change this. -outputConcr :: PGF -> CId -outputConcr pgf = case cncnames pgf of - [] -> error "No concrete syntax." - cnc:_ -> cnc diff --git a/src/GF/Compile/GFCCtoHaskell.hs b/src/GF/Compile/GFCCtoHaskell.hs deleted file mode 100644 index d44d6705c..000000000 --- a/src/GF/Compile/GFCCtoHaskell.hs +++ /dev/null @@ -1,230 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GFCCtoHaskell --- Maintainer : Aarne Ranta --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/17 12:39:07 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- to write a GF abstract grammar into a Haskell module with translations from --- data objects into GF trees. Example: GSyntax for Agda. --- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004 ------------------------------------------------------------------------------ - -module GF.Compile.GFCCtoHaskell (grammar2haskell) where - -import PGF.CId -import PGF.Data -import PGF.Macros - -import GF.Data.Operations -import GF.Infra.Option -import GF.Text.UTF8 - -import Data.List --(isPrefixOf, find, intersperse) -import qualified Data.Map as Map - -type Prefix = String -> String - --- | the main function -grammar2haskell :: Options - -> String -- ^ Module name. - -> PGF - -> String -grammar2haskell opts name gr = encodeUTF8 $ foldr (++++) [] $ - pragmas ++ haskPreamble name ++ [types, gfinstances gId lexical gr'] - where gr' = hSkeleton gr - gadt = haskellOption opts HaskellGADT - lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat - gId | haskellOption opts HaskellNoPrefix = id - | otherwise = ("G"++) - pragmas | gadt = ["{-# OPTIONS_GHC -fglasgow-exts #-}"] - | otherwise = [] - types | gadt = datatypesGADT gId lexical gr' - | otherwise = datatypes gId lexical gr' - -haskPreamble name = - [ - "module " ++ name ++ " where", - "", - "import PGF", - "----------------------------------------------------", - "-- automatic translation from GF to Haskell", - "----------------------------------------------------", - "", - "class Gf a where", - " gf :: a -> Tree", - " fg :: Tree -> a", - "", - predefInst "GString" "String" "unStr" "mkStr", - "", - predefInst "GInt" "Integer" "unInt" "mkInt", - "", - predefInst "GFloat" "Double" "unDouble" "mkDouble", - "", - "----------------------------------------------------", - "-- below this line machine-generated", - "----------------------------------------------------", - "" - ] - -predefInst gtyp typ destr consr = - "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++ - "instance Gf" +++ gtyp +++ "where" ++++ - " gf (" ++ gtyp +++ "x) =" +++ consr +++ "x" ++++ - " fg t =" ++++ - " case "++destr++" t of" ++++ - " Just x -> " +++ gtyp +++ "x" ++++ - " Nothing -> error (\"no" +++ gtyp +++ "\" ++ show t)" - -type OIdent = String - -type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] - -datatypes :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String -datatypes gId lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId lexical)) . snd - -gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String -gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g - - -hDatatype :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String -hDatatype _ _ ("Cn",_) = "" --- -hDatatype _ _ (cat,[]) = "" -hDatatype gId _ (cat,rules) | isListCat (cat,rules) = - "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" - +++ "deriving Show" -hDatatype gId lexical (cat,rules) = - "data" +++ gId cat +++ "=" ++ - (if length rules == 1 then "" else "\n ") +++ - foldr1 (\x y -> x ++ "\n |" +++ y) constructors ++++ - " deriving Show" - where - constructors = [gId f +++ foldr (+++) "" (map (gId) xx) | (f,xx) <- nonLexicalRules (lexical cat) rules] - ++ if lexical cat then [lexicalConstructor cat +++ "String"] else [] - -nonLexicalRules :: Bool -> [(OIdent, [OIdent])] -> [(OIdent, [OIdent])] -nonLexicalRules False rules = rules -nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)] - -lexicalConstructor :: OIdent -> String -lexicalConstructor cat = "Lex" ++ cat - --- GADT version of data types -datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String -datatypesGADT gId lexical (_,skel) = - unlines (concatMap (hCatTypeGADT gId) skel) - +++++ - "data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT gId lexical) skel) - -hCatTypeGADT :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String] -hCatTypeGADT gId (cat,rules) - = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_", - "data"+++gId cat++"_"] - -hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String] -hDatatypeGADT gId lexical (cat, rules) - | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t] - | otherwise = - [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t - | (f,args) <- nonLexicalRules (lexical cat) rules ] - ++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else [] - where t = "Tree" +++ gId cat ++ "_" - -gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String -gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs - -----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004 -hInstance _ _ m (cat,[]) = "" -hInstance gId lexical 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) <- nonLexicalRules (lexical cat) rules] - ++ if lexical cat then [" gf (" ++ lexicalConstructor cat +++ "x) = mkApp (mkCId x) []"] else []) - 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 = "mkApp (mkCId \"" ++ f ++ "\")" +++ - "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" - - -----fInstance m ("Cn",_) = "" --- -fInstance _ _ m (cat,[]) = "" -fInstance gId lexical m (cat,rules) = - " fg t =" ++++ - " case unApp t of" ++++ - unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++ - (if lexical cat then " (i,[]) -> " ++ lexicalConstructor cat +++ "(prCId i)" else "") ++++ - " _ -> error (\"no" +++ cat ++ " \" ++ show t)" - where - mkInst f xx = - " Just (i," ++ - "[" ++ prTList "," xx' ++ "])" +++ - "| i == mkCId \"" ++ f ++ "\" ->" +++ 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 :: PGF -> (String,HSkeleton) -hSkeleton gr = - (showCId (absname gr), - [(showCId c, [(showCId f, map showCId 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 - jty (f,(ty,_,_)) = (f,catSkeleton ty) - -updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton -updateSkeleton cat skel rule = - case skel of - (cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr - (cat0,rules):rr -> (cat0, rules) : updateSkeleton cat rr rule - -isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool -isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2 - && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs - where c = elemCat cat - fs = map fst rules - --- | Gets the element category of a list category. -elemCat :: OIdent -> OIdent -elemCat = drop 4 - -isBaseFun :: OIdent -> Bool -isBaseFun f = "Base" `isPrefixOf` f - -isConsFun :: OIdent -> Bool -isConsFun f = "Cons" `isPrefixOf` f - -baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int -baseSize (_,rules) = length bs - where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules diff --git a/src/GF/Compile/GFCCtoJS.hs b/src/GF/Compile/GFCCtoJS.hs deleted file mode 100644 index 312701e3b..000000000 --- a/src/GF/Compile/GFCCtoJS.hs +++ /dev/null @@ -1,138 +0,0 @@ -module GF.Compile.GFCCtoJS (pgf2js) where - -import PGF.CId -import PGF.Data hiding (mkStr) -import qualified PGF.Macros as M -import qualified GF.JavaScript.AbsJS as JS -import qualified GF.JavaScript.PrintJS as JS - -import GF.Text.UTF8 -import GF.Data.ErrM -import GF.Infra.Option - -import Control.Monad (mplus) -import Data.Array.Unboxed (UArray) -import qualified Data.Array.IArray as Array -import Data.Maybe (fromMaybe) -import Data.Map (Map) -import qualified Data.Set as Set -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap - -pgf2js :: PGF -> String -pgf2js pgf = - encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]] - where - n = showCId $ absname pgf - as = abstract pgf - cs = Map.assocs (concretes pgf) - start = showCId $ M.lookStartCat pgf - grammar = new "GFGrammar" [js_abstract, js_concrete] - js_abstract = abstract2js start as - js_concrete = JS.EObj $ map (concrete2js start n) cs - -abstract2js :: String -> Abstr -> JS.Expr -abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))] - -absdef2js :: (CId,(Type,Int,[Equation])) -> JS.Property -absdef2js (f,(typ,_,_)) = - let (args,cat) = M.catSkeleton typ in - JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)]) - -concrete2js :: String -> String -> (CId,Concr) -> JS.Property -concrete2js start n (c, cnc) = - JS.Prop l (new "GFConcrete" ([flags,(JS.EObj $ ((map (cncdef2js n (showCId c)) ds) ++ litslins))] ++ - maybe [] (parser2js start) (parser cnc))) - where - flags = mapToJSObj JS.EStr $ cflags cnc - l = JS.IdentPropName (JS.Ident (showCId c)) - ds = concatMap Map.assocs [lins cnc, opers cnc, 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,Term) -> JS.Property -cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)]) - -term2js :: String -> String -> Term -> JS.Expr -term2js n l t = f t - where - f t = - case t of - R xs -> new "Arr" (map f xs) - P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y] - S xs -> mkSeq (map f xs) - K t -> tokn2js t - V i -> JS.EIndex (JS.EVar children) (JS.EInt i) - C i -> new "Int" [JS.EInt i] - F 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 (showCId f), JS.EVar children] - FV xs -> new "Variants" (map f xs) - W str x -> new "Suffix" [JS.EStr str, f x] - TM _ -> new "Meta" [] - -tokn2js :: Tokn -> JS.Expr -tokn2js (KS s) = mkStr s -tokn2js (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 -> ParserInfo -> [JS.Expr] -parser2js start p = [new "Parser" [JS.EStr start, - JS.EArray $ [frule2js p cat prod | (cat,set) <- IntMap.toList (productions p), prod <- Set.toList set], - JS.EObj $ map cats (Map.assocs (startCats p))]] - where - cats (c,is) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EArray (map JS.EInt is)) - -frule2js :: ParserInfo -> FCat -> Production -> JS.Expr -frule2js p res (FApply funid args) = new "Rule" [JS.EInt res, name2js (f,ps), JS.EArray (map JS.EInt args), lins2js p lins] - where - FFun f ps lins = functions p Array.! funid -frule2js p res (FCoerce arg) = new "Rule" [JS.EInt res, daughter 0, JS.EArray [JS.EInt arg], JS.EArray [JS.EArray [sym2js (FSymCat 0 i)] | i <- [0..catLinArity arg-1]]] - where - catLinArity :: FCat -> Int - catLinArity c = maximum (1:[Array.rangeSize (Array.bounds rhs) | (FFun _ _ rhs, _) <- topdownRules c]) - - topdownRules cat = f cat [] - where - f cat rules = maybe rules (Set.fold g rules) (IntMap.lookup cat (productions p)) - - g (FApply funid args) rules = (functions p Array.! funid,args) : rules - g (FCoerce cat) rules = f cat rules - - -name2js :: (CId,[Profile]) -> JS.Expr -name2js (f,ps) = new "FunApp" $ [JS.EStr $ showCId f, JS.EArray (map fromProfile ps)] - where - fromProfile :: Profile -> JS.Expr - fromProfile [] = new "MetaVar" [] - fromProfile [x] = daughter x - fromProfile args = new "Unify" [JS.EArray (map daughter args)] - -daughter i = new "Arg" [JS.EInt i] - -lins2js :: ParserInfo -> UArray FIndex SeqId -> JS.Expr -lins2js p ls = JS.EArray [JS.EArray [sym2js s | s <- Array.elems (sequences p Array.! seqid)] | seqid <- Array.elems ls] - -sym2js :: FSymbol -> JS.Expr -sym2js (FSymCat n l) = new "ArgProj" [JS.EInt n, JS.EInt l] -sym2js (FSymLit n l) = new "ArgProj" [JS.EInt n, JS.EInt l] -sym2js (FSymKS [t]) = new "Terminal" [JS.EStr t] - -new :: String -> [JS.Expr] -> JS.Expr -new f xs = JS.ENew (JS.Ident f) xs - -mapToJSObj :: (a -> JS.Expr) -> Map CId a -> JS.Expr -mapToJSObj f m = JS.EObj [ JS.Prop (JS.IdentPropName (JS.Ident (showCId k))) (f v) | (k,v) <- Map.toList m ] diff --git a/src/GF/Compile/GFCCtoProlog.hs b/src/GF/Compile/GFCCtoProlog.hs deleted file mode 100644 index 702d4afe5..000000000 --- a/src/GF/Compile/GFCCtoProlog.hs +++ /dev/null @@ -1,279 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GFCCtoProlog --- Maintainer : Peter Ljunglöf --- Stability : (stable) --- Portability : (portable) --- --- to write a GF grammar into a Prolog module ------------------------------------------------------------------------------ - -module GF.Compile.GFCCtoProlog (grammar2prolog, grammar2prolog_abs) where - -import PGF.CId -import PGF.Data -import PGF.Macros - -import GF.Data.Operations -import GF.Text.UTF8 - -import qualified Data.Map as Map -import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper, ord) -import Data.List (isPrefixOf,mapAccumL) - -grammar2prolog, grammar2prolog_abs :: PGF -> String --- Most prologs have problems with UTF8 encodings, so we skip that: -grammar2prolog = {- encodeUTF8 . -} foldr (++++) [] . pgf2clauses -grammar2prolog_abs = {- encodeUTF8 . -} foldr (++++) [] . pgf2clauses_abs - - -pgf2clauses :: PGF -> [String] -pgf2clauses (PGF absname cncnames gflags abstract concretes) = - [":- " ++ plFact "module" [plp absname, "[]"]] ++ - clauseHeader "%% concrete(?Module)" - [plFact "concrete" [plp cncname] | cncname <- cncnames] ++ - clauseHeader "%% flag(?Flag, ?Value): global flags" - (map (plpFact2 "flag") (Map.assocs gflags)) ++ - plAbstract (absname, abstract) ++ - concatMap plConcrete (Map.assocs concretes) - -pgf2clauses_abs :: PGF -> [String] -pgf2clauses_abs (PGF absname _cncnames gflags abstract _concretes) = - [":- " ++ plFact "module" [plp absname, "[]"]] ++ - clauseHeader "%% flag(?Flag, ?Value): global flags" - (map (plpFact2 "flag") (Map.assocs gflags)) ++ - plAbstract (absname, abstract) - -clauseHeader :: String -> [String] -> [String] -clauseHeader hdr [] = [] -clauseHeader hdr clauses = "":hdr:clauses - - ----------------------------------------------------------------------- --- abstract syntax - -plAbstract :: (CId, Abstr) -> [String] -plAbstract (name, Abstr aflags funs cats _catfuns) = - ["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%", - "%% abstract module: " ++ plp name] ++ - clauseHeader "%% absflag(?Flag, ?Value): flags for abstract syntax" - (map (plpFact2 "absflag") (Map.assocs aflags)) ++ - clauseHeader "%% cat(?Type, ?[X:Type,...])" - (map plCat (Map.assocs cats)) ++ - clauseHeader "%% fun(?Fun, ?Type, ?[X:Type,...])" - (map plFun (Map.assocs funs)) ++ - clauseHeader "%% def(?Fun, ?Expr)" - (concatMap plFundef (Map.assocs funs)) - -plCat :: (CId, [Hypo]) -> String -plCat (cat, hypos) = plFact "cat" (plTypeWithHypos typ) - where ((_,subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos - args = reverse [EFun x | (_,x) <- subst] - typ = DTyp hypos' cat args - -plFun :: (CId, (Type, Int, [Equation])) -> String -plFun (fun, (typ,_,_)) = plFact "fun" (plp fun : plTypeWithHypos typ') - where typ' = snd $ alphaConvert emptyEnv typ - -plTypeWithHypos :: Type -> [String] -plTypeWithHypos (DTyp hypos cat args) = [plTerm (plp cat) (map plp args), plList (map (\(_,x,ty) -> plOper ":" (plp x) (plp ty)) hypos)] - -plFundef :: (CId, (Type,Int,[Equation])) -> [String] -plFundef (fun, (_,_,[])) = [] -plFundef (fun, (_,_,eqs)) = [plFact "def" [plp fun, plp fundef']] - where fundef' = snd $ alphaConvert emptyEnv eqs - - ----------------------------------------------------------------------- --- concrete syntax - -plConcrete :: (CId, Concr) -> [String] -plConcrete (cncname, Concr cflags lins opers lincats lindefs - _printnames _paramlincats _parser) = - ["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%", - "%% concrete module: " ++ plp cncname] ++ - clauseHeader "%% cncflag(?Flag, ?Value): flags for concrete syntax" - (map (mod . plpFact2 "cncflag") (Map.assocs cflags)) ++ - clauseHeader "%% lincat(?Cat, ?Linearization type)" - (map (mod . plpFact2 "lincat") (Map.assocs lincats)) ++ - clauseHeader "%% lindef(?Cat, ?Linearization default)" - (map (mod . plpFact2 "lindef") (Map.assocs lindefs)) ++ - clauseHeader "%% lin(?Fun, ?Linearization)" - (map (mod . plpFact2 "lin") (Map.assocs lins)) ++ - clauseHeader "%% oper(?Oper, ?Linearization)" - (map (mod . plpFact2 "oper") (Map.assocs opers)) - where mod clause = plp cncname ++ ": " ++ clause - - ----------------------------------------------------------------------- --- prolog-printing pgf datatypes - -instance PLPrint Type where - plp (DTyp hypos cat args) | null hypos = result - | otherwise = plOper " -> " (plList (map (\(_,x,ty) -> plOper ":" (plp x) (plp ty)) hypos)) result - where result = plTerm (plp cat) (map plp args) - -instance PLPrint Expr where - plp (EFun x) = plp x - plp (EAbs _ x e)= plOper "^" (plp x) (plp e) - plp (EApp e e') = plOper " * " (plp e) (plp e') - plp (ELit lit) = plp lit - plp (EMeta n) = "Meta_" ++ show n - -instance PLPrint Patt where - plp (PVar x) = plp x - plp (PApp f ps) = plOper " * " (plp f) (plp ps) - plp (PLit lit) = plp lit - -instance PLPrint Equation where - plp (Equ patterns result) = plOper ":" (plp patterns) (plp result) - -instance PLPrint Term where - plp (S terms) = plTerm "s" [plp terms] - plp (C n) = plTerm "c" [show n] - plp (K tokn) = plTerm "k" [plp tokn] - plp (FV trms) = plTerm "fv" [plp trms] - plp (P t1 t2) = plTerm "p" [plp t1, plp t2] - plp (W s trm) = plTerm "w" [plp s, plp trm] - plp (R terms) = plTerm "r" [plp terms] - plp (F oper) = plTerm "f" [plp oper] - plp (V n) = plTerm "v" [show n] - plp (TM str) = plTerm "tm" [plp str] - -{-- more prolog-like syntax for PGF terms, but also more difficult to handle: -instance PLPrint Term where - plp (S terms) = plp terms - plp (C n) = show n - plp (K token) = plp token - plp (FV terms) = prCurlyList (map plp terms) - plp (P t1 t2) = plOper "/" (plp t1) (plp t2) - plp (W s trm) = plOper "+" (plp s) (plp trm) - plp (R terms) = plTerm "r" (map plp terms) - plp (F oper) = plTerm "f" [plp oper] - plp (V n) = plTerm "arg" [show n] - plp (TM str) = plTerm "meta" [plp str] ---} - -instance PLPrint CId where - plp cid | isLogicalVariable str || - cid == wildCId = plVar str - | otherwise = plAtom str - where str = showCId cid - -instance PLPrint Literal where - plp (LStr s) = plp s - plp (LInt n) = plp (show n) - plp (LFlt f) = plp (show f) - -instance PLPrint Tokn where - plp (KS tokn) = plp tokn - plp (KP strs alts) = plTerm "kp" [plp strs, plList [plOper "/" (plp ss1) (plp ss2) | - Alt ss1 ss2 <- alts]] - ----------------------------------------------------------------------- --- basic prolog-printing - -class PLPrint a where - plp :: a -> String - plps :: [a] -> String - plps = plList . map plp - -instance PLPrint Char where - plp c = plAtom [c] - plps s = plAtom s - -instance PLPrint a => PLPrint [a] where - plp = plps - -plpFact2 :: (PLPrint a, PLPrint b) => String -> (a, b) -> String -plpFact2 fun (arg1, arg2) = plFact fun [plp arg1, plp arg2] - -plFact :: String -> [String] -> String -plFact fun args = plTerm fun args ++ "." - -plTerm :: String -> [String] -> String -plTerm fun args = plAtom fun ++ prParenth (prTList ", " args) - -plList :: [String] -> String -plList = prBracket . prTList "," - -plOper :: String -> String -> String -> String -plOper op a b = prParenth (a ++ op ++ b) - -plVar :: String -> String -plVar = varPrefix . concatMap changeNonAlphaNum - where varPrefix var@(c:_) | isAsciiUpper c || c=='_' = var - | otherwise = "_" ++ var - changeNonAlphaNum c | isAlphaNumUnderscore c = [c] - | otherwise = "_" ++ show (ord c) ++ "_" - -plAtom :: String -> String -plAtom "" = "''" -plAtom atom@(c:cs) | isAsciiLower c && all isAlphaNumUnderscore cs - || c == '\'' && cs /= "" && last cs == '\'' = atom - | otherwise = "'" ++ concatMap changeQuote atom ++ "'" - where changeQuote '\'' = "\\'" - changeQuote c = [c] - -isAlphaNumUnderscore :: Char -> Bool -isAlphaNumUnderscore c = isAlphaNum c || c == '_' - - ----------------------------------------------------------------------- --- prolog variables - -createLogicalVariable :: Int -> CId -createLogicalVariable n = mkCId (logicalVariablePrefix ++ show n) - -isLogicalVariable :: String -> Bool -isLogicalVariable = isPrefixOf logicalVariablePrefix - -logicalVariablePrefix :: String -logicalVariablePrefix = "X" - ----------------------------------------------------------------------- --- alpha convert variables to (unique) logical variables --- * this is needed if we want to translate variables to Prolog variables --- * used for abstract syntax, not concrete --- * not (yet?) used for variables bound in pattern equations - -type ConvertEnv = (Int, [(CId,CId)]) - -emptyEnv :: ConvertEnv -emptyEnv = (0, []) - -class AlphaConvert a where - alphaConvert :: ConvertEnv -> a -> (ConvertEnv, a) - -instance AlphaConvert a => AlphaConvert [a] where - alphaConvert env [] = (env, []) - alphaConvert env (a:as) = (env'', a':as') - where (env', a') = alphaConvert env a - (env'', as') = alphaConvert env' as - -instance AlphaConvert Type where - alphaConvert env@(_,subst) (DTyp hypos cat args) - = ((ctr,subst), DTyp hypos' cat args') - where (env', hypos') = mapAccumL alphaConvertHypo env hypos - ((ctr,_), args') = alphaConvert env' args - -alphaConvertHypo env (b,x,typ) = ((ctr+1,(x,x'):subst), (b,x',typ')) - where ((ctr,subst), typ') = alphaConvert env typ - x' = createLogicalVariable ctr - -instance AlphaConvert Expr where - alphaConvert (ctr,subst) (EAbs b x e) = ((ctr',subst), EAbs b x' e') - where ((ctr',_), e') = alphaConvert (ctr+1,(x,x'):subst) e - x' = createLogicalVariable ctr - alphaConvert env (EApp e1 e2) = (env'', EApp e1' e2') - where (env', e1') = alphaConvert env e1 - (env'', e2') = alphaConvert env' e2 - alphaConvert env expr@(EFun i) = (env, maybe expr EFun (lookup i (snd env))) - alphaConvert env expr = (env, expr) - --- pattern variables are not alpha converted --- (but they probably should be...) -instance AlphaConvert Equation where - alphaConvert env@(_,subst) (Equ patterns result) - = ((ctr,subst), Equ patterns result') - where ((ctr,_), result') = alphaConvert env result diff --git a/src/GF/Compile/GenerateFCFG.hs b/src/GF/Compile/GenerateFCFG.hs deleted file mode 100644 index 52e95f686..000000000 --- a/src/GF/Compile/GenerateFCFG.hs +++ /dev/null @@ -1,568 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- Converting SimpleGFC grammars to fast nonerasing MCFG grammar. --- --- the resulting grammars might be /very large/ --- --- the conversion is only equivalent if the GFC grammar has a context-free backbone. ------------------------------------------------------------------------------ - - -module GF.Compile.GenerateFCFG - (convertConcrete) where - -import PGF.CId -import PGF.Data -import PGF.Macros --hiding (prt) -import PGF.Parsing.FCFG.Utilities - -import GF.Data.BacktrackM -import GF.Data.SortedList -import GF.Data.Utilities (updateNthM, sortNub) - -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import qualified Data.Set as Set -import qualified Data.List as List -import qualified Data.ByteString.Char8 as BS -import Data.Array.IArray -import Data.Maybe -import Control.Monad - ----------------------------------------------------------------------- --- main conversion function - -convertConcrete :: Abstr -> Concr -> ParserInfo -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,Int,[Equation]))] -> TermMap -> TermMap -> ([(CId,(Type,Int,[Equation]))],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,a,e)) | (f,(ty,a,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),0,[])) | 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,0,[])) | 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 " ++ showCId 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 = mkCId "_Var" - - catName :: (Int,CId) -> CId - catName (0,c) = c - catName (n,c) = mkCId ("_" ++ show n ++ showCId c) - - funName :: (Int,CId) -> CId - funName (n,c) = mkCId ("__" ++ show n ++ showCId c) - - varFunName :: CId -> CId - varFunName c = mkCId ("_Var_" ++ showCId c) - --- replaces __NCat with _B and _Var_Cat with _. --- the temporary names are just there to avoid name collisions. -fixHoasFuns :: ParserInfo -> ParserInfo -fixHoasFuns pinfo = pinfo{functions=mkArray [FFun (fixName n) prof lins | FFun n prof lins <- elems (functions pinfo)]} - where fixName (CId n) | BS.pack "__" `BS.isPrefixOf` n = (mkCId "_B") - | BS.pack "_Var_" `BS.isPrefixOf` n = wildCId - fixName n = n - -convert :: [(CId,(Type,Int,[Equation]))] -> TermMap -> TermMap -> ParserInfo -convert abs_defs cnc_defs cat_defs = getParserInfo (loop grammarEnv) - where - srules = [ - (XRule id args res (map findLinType args) (findLinType res) term) | - (id, (ty,_,_)) <- abs_defs, let (args,res) = catSkeleton ty, - term <- maybeToList (Map.lookup id cnc_defs)] - - findLinType id = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs) - - (xrulesMap,grammarEnv) = List.foldl' helper (Map.empty,emptyFFunsEnv) srules - where - helper (xrulesMap,grammarEnv) rule@(XRule id abs_args abs_res cnc_args cnc_res term) = - let xrulesMap' = Map.insertWith (++) abs_res [rule] xrulesMap - grammarEnv' = List.foldl' (\env selector -> convertRule cnc_defs selector rule env) - grammarEnv - (mkSingletonSelectors cnc_defs cnc_res) - in xrulesMap' `seq` grammarEnv' `seq` (xrulesMap',grammarEnv') - - loop grammarEnv = - let (todo, grammarEnv') = takeToDoRules xrulesMap grammarEnv - in case todo of - [] -> grammarEnv' - _ -> loop $! List.foldl' (\env (srules,selector) -> - List.foldl' (\env srule -> convertRule cnc_defs selector srule env) env srules) grammarEnv' todo - -convertRule :: TermMap -> TermSelector -> XRule -> GrammarEnv -> GrammarEnv -convertRule cnc_defs selector (XRule fun args cat ctypes ctype term) grammarEnv = - foldBM addRule - grammarEnv - (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..]) - - (env3,newLinRec) = List.mapAccumL (translateLin idxArgs linRec) env2 (case newCat' of {PFCat _ rcs _ -> rcs}) - - (_,newProfile) = List.mapAccumL accumProf 0 newArgs' - where - accumProf nr (PFCat _ [] _,_ ) = (nr, [] ) - accumProf nr (_ ,xpaths) = (nr+cnt+1, [nr..nr+cnt]) - where cnt = length xpaths - - (env4,funid) = addFFun env3 (FFun fun newProfile (mkArray newLinRec)) - - in addProduction env4 newCat (FApply funid newArgs) - -translateLin idxArgs [] grammarEnv lbl' = error "translateLin" -translateLin idxArgs ((lbl,syms) : lins) grammarEnv lbl' - | lbl' == lbl = addFSeq grammarEnv (lbl,map instSym syms) - | otherwise = translateLin idxArgs lins grammarEnv lbl' - where - instSym = either (\(lbl, nr, xnr) -> instCat lbl nr xnr 0 idxArgs) - (\t -> case t of - KS s -> FSymKS [s] - KP strs vars -> FSymKP strs vars) - instCat lbl nr xnr nr' ((idx,xargs):idxArgs) - | nr == idx = let (fcat, PFCat _ rcs _) = xargs !! xnr - in FSymCat (nr'+xnr) (index lbl rcs 0) - | 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 FPath = [FIndex] -type Env = (ProtoFCat, [(ProtoFCat,[FPath])], Term, [Term]) -type LinRec = [(FPath, [Either (FPath, FIndex, Int) Tokn])] - -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,Right (KS str) : lin) : lins) -convertTerm cnc_defs selector (K (KP strs vars))((lbl_path,lin) : lins) = - do projectHead lbl_path - toks <- member (strs:[strs' | Alt strs' _ <- vars]) - return ((lbl_path, map (Right . KS) toks ++ lin) : lins) -convertTerm cnc_defs selector (F id) lins = case Map.lookup id cnc_defs of - Just term -> convertTerm cnc_defs selector term lins - Nothing -> mzero -convertTerm cnc_defs selector (W s t) ((lbl_path,lin) : lins) = do - ss <- case t of - R ss -> return ss - F f -> case Map.lookup f cnc_defs of - Just (R ss) -> return ss - _ -> mzero - 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, Left (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 (F id) = case Map.lookup id cnc_defs of - Just term -> evalTerm cnc_defs path term - Nothing -> mzero -evalTerm cnc_defs path x = error ("evalTerm ("++show x++")") - -unifyPType :: FIndex -> FPath -> Term -> CnvMonad FIndex -unifyPType nr path (C max_index) = - do (_, args, _, _) <- get - 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 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) - - ----------------------------------------------------------------------- --- GrammarEnv - - -data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int FCatSet FSeqSet FFunSet (IntMap.IntMap (Set.Set Production)) -type FCatSet = Map.Map CId (Map.Map [FPath] (Map.Map [(FPath,FIndex)] (Either FCat FCat))) -type FSeqSet = Map.Map FSeq SeqId -type FFunSet = Map.Map FFun FunId - -data ProtoFCat = PFCat CId [FPath] [(FPath,FIndex)] - -protoFCat :: CId -> ProtoFCat -protoFCat cat = PFCat cat [] [] - -emptyFFunsEnv = GrammarEnv 0 initFCatSet Map.empty Map.empty IntMap.empty - where - initFCatSet = (ins fcatString (mkCId "String") [[0]] [] $ - ins fcatInt (mkCId "Int") [[0]] [] $ - ins fcatFloat (mkCId "Float") [[0]] [] $ - ins fcatVar (mkCId "_Var") [[0]] [] $ - Map.empty) - - ins fcat cat rcs tcs catSet = - Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs right_fcat) rcs tmap_s) cat rmap_s catSet - where - right_fcat = Right fcat - tmap_s = Map.singleton tcs right_fcat - rmap_s = Map.singleton rcs tmap_s - -addProduction :: GrammarEnv -> FCat -> Production -> GrammarEnv -addProduction (GrammarEnv last_id catSet seqSet funSet prodSet) cat p = - GrammarEnv last_id catSet seqSet funSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet) - -addFSeq :: GrammarEnv -> (FPath,[FSymbol]) -> (GrammarEnv,SeqId) -addFSeq env@(GrammarEnv last_id catSet seqSet funSet prodSet) (_,lst) = - case Map.lookup seq seqSet of - Just id -> (env,id) - Nothing -> let !last_seq = Map.size seqSet - in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet prodSet,last_seq) - where - seq = mkArray lst - -addFFun :: GrammarEnv -> FFun -> (GrammarEnv,FunId) -addFFun env@(GrammarEnv last_id catSet seqSet funSet prodSet) fun = - case Map.lookup fun funSet of - Just id -> (env,id) - Nothing -> let !last_funid = Map.size funSet - in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) prodSet,last_funid) - -getParserInfo :: GrammarEnv -> ParserInfo -getParserInfo (GrammarEnv last_id catSet seqSet funSet prodSet) = - ParserInfo { functions = mkArray funSet - , sequences = mkArray seqSet - , productions0= prodSet - , productions = prodSet - , startCats = Map.map getFCatList catSet - , totalCats = last_id+1 - } - where - mkArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] - - getFCatList rcs = Map.fold (\tcs lst -> Map.fold (\x lst -> either id id x : lst) lst tcs) [] rcs - - -genFCatHead :: GrammarEnv -> ProtoFCat -> (GrammarEnv, FCat) -genFCatHead env@(GrammarEnv last_id catSet seqSet funSet prodSet) (PFCat cat rcs tcs) = - case Map.lookup cat catSet >>= Map.lookup rcs >>= Map.lookup tcs of - Just (Left fcat) -> (GrammarEnv last_id (ins fcat) seqSet funSet prodSet, fcat) - Just (Right fcat) -> (env, fcat) - Nothing -> let fcat = last_id+1 - in (GrammarEnv fcat (ins fcat) seqSet funSet prodSet, fcat) - where - ins fcat = Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs right_fcat) rcs tmap_s) cat rmap_s catSet - where - right_fcat = Right fcat - tmap_s = Map.singleton tcs right_fcat - rmap_s = Map.singleton rcs tmap_s - -genFCatArg :: TermMap -> Term -> GrammarEnv -> ProtoFCat -> (GrammarEnv, FCat) -genFCatArg cnc_defs ctype env@(GrammarEnv last_id catSet seqSet funSet prodSet) (PFCat cat rcs tcs) = - case Map.lookup cat catSet >>= 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,prodSet1) - = foldBM (\tcs st (either_fcat,last_id,tmap,prodSet) -> - let (last_id1,tmap1,fcat_arg) = addArg tcs last_id tmap - p = FCoerce fcat_arg - prodSet1 = IntMap.insertWith Set.union fcat (Set.singleton p) prodSet - in if st - then (Right fcat, last_id1,tmap1,prodSet1) - else (either_fcat,last_id, tmap ,prodSet )) - (Left fcat,fcat,Map.insert tcs either_fcat tmap,prodSet) - (gen_tcs ctype [] []) - False - rmap1 = Map.singleton rcs tmap1 - in (GrammarEnv last_id1 (Map.insertWith (\_ -> Map.insert rcs tmap1) cat rmap1 catSet) seqSet funSet prodSet1, 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 (C max_index) path acc = - case List.lookup path tcs of - Just index -> return $! addConstraint path index acc - Nothing -> do put 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: "++showCId 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 -> GrammarEnv -> ([([XRule], TermSelector)], GrammarEnv) -takeToDoRules xrulesMap (GrammarEnv last_id catSet seqSet funSet prodSet) = - (todo,GrammarEnv last_id catSet' seqSet funSet prodSet) - where - (todo,catSet') = - 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)) [] catSet - - ------------------------------------------------------------- --- 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 (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: "++showCId 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) <- get - return (ctypes !! nr) - -restrictArg :: FIndex -> FPath -> FIndex -> CnvMonad () -restrictArg nr path index = do - (head, args, ctype, ctypes) <- get - args' <- updateNthM (\(xcat,xs) -> do xcat <- restrictProtoFCat path index xcat - return (xcat,xs) ) nr args - put (head, args', ctype, ctypes) - -projectArg :: FIndex -> FPath -> CnvMonad Int -projectArg nr path = do - (head, args, ctype, ctypes) <- get - (xnr,args') <- updateArgs nr args - put (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, _) <- get - return ctype - -restrictHead :: FPath -> FIndex -> CnvMonad () -restrictHead path term - = do (head, args, ctype, ctypes) <- get - head' <- restrictProtoFCat path term head - put (head', args, ctype, ctypes) - -projectHead :: FPath -> CnvMonad () -projectHead path - = do (head, args, ctype, ctypes) <- get - head' <- projectProtoFCat path head - put (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 - -mkArray lst = listArray (0,length lst-1) lst diff --git a/src/GF/Compile/GeneratePMCFG.hs b/src/GF/Compile/GeneratePMCFG.hs deleted file mode 100644 index 458cf3f5c..000000000 --- a/src/GF/Compile/GeneratePMCFG.hs +++ /dev/null @@ -1,510 +0,0 @@ -{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses #-} ----------------------------------------------------------------------- --- | --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- Convert PGF grammar to PMCFG grammar. --- ------------------------------------------------------------------------------ - -module GF.Compile.GeneratePMCFG - (convertConcrete) where - -import PGF.CId -import PGF.Data -import PGF.Macros - -import GF.Infra.Option -import GF.Data.BacktrackM -import GF.Data.Utilities (updateNthM, updateNth, sortNub) - -import System.IO -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.List as List -import qualified Data.IntMap as IntMap -import qualified Data.ByteString.Char8 as BS -import Data.Array.IArray -import Data.Maybe -import Control.Monad -import Control.Exception - ----------------------------------------------------------------------- --- main conversion function - - -convertConcrete :: Options -> Abstr -> CId -> Concr -> IO ParserInfo -convertConcrete opts abs lang cnc = do - let env0 = emptyGrammarEnv cnc_defs cat_defs - when (flag optProf opts) $ do - profileGrammar lang cnc_defs env0 pfrules - let env1 = expandHOAS abs_defs cnc_defs cat_defs lin_defs env0 - env2 = List.foldl' (convertRule cnc_defs) env1 pfrules - return $ getParserInfo env2 - where - abs_defs = Map.assocs (funs abs) - cnc_defs = Map.union (opers cnc) (lins cnc) -- "union big+small most efficient" - cat_defs = Map.insert cidVar (S []) (lincats cnc) - lin_defs = lindefs cnc - - pfrules = [ - (PFRule id args (0,res) (map findLinType args) (findLinType (0,res)) term) | - (id, (ty,_,_)) <- abs_defs, let (args,res) = typeSkeleton ty, - term <- maybeToList (Map.lookup id cnc_defs)] - - findLinType (_,id) = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs) - -profileGrammar lang cnc_defs (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfrules = do - hPutStrLn stderr "" - hPutStrLn stderr ("Language: " ++ show lang) - hPutStrLn stderr "" - hPutStrLn stderr "Categories Count" - hPutStrLn stderr "--------------------------------" - case IntMap.lookup 0 catSet of - Just cats -> mapM_ profileCat (Map.toList cats) - Nothing -> return () - hPutStrLn stderr "--------------------------------" - hPutStrLn stderr "" - hPutStrLn stderr "Rules Count" - hPutStrLn stderr "--------------------------------" - mapM_ profileRule pfrules - hPutStrLn stderr "--------------------------------" - where - profileCat (cid,(fcat1,fcat2,_)) = do - hPutStrLn stderr (lformat 23 cid ++ rformat 9 (fcat2-fcat1+1)) - - profileRule (PFRule fun args res ctypes ctype term) = do - let pargs = zipWith (protoFCat cnc_defs) args ctypes - hPutStrLn stderr (lformat 23 fun ++ rformat 9 (product [length xs | PFCat _ _ _ tcs <- pargs, (_,xs) <- tcs])) - - lformat :: Show a => Int -> a -> String - lformat n x = s ++ replicate (n-length s) ' ' - where - s = show x - - rformat :: Show a => Int -> a -> String - rformat n x = replicate (n-length s) ' ' ++ s - where - s = show x - -brk :: (GrammarEnv -> GrammarEnv) -> (GrammarEnv -> GrammarEnv) -brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = - case f (GrammarEnv last_id catSet seqSet funSet crcSet IntMap.empty) of - (GrammarEnv last_id catSet seqSet funSet crcSet topdown1) -> IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) topdown1 - where - optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | FApply funid args <- Set.toList ps]) - where - ff :: FunId -> [[FCat]] -> GrammarEnv -> GrammarEnv - ff funid xs env - | product (map Set.size ys) == count = - case List.mapAccumL (\env c -> addFCoercion env (Set.toList c)) env ys of - (env,args) -> addProduction env cat (FApply funid args) - | otherwise = List.foldl (\env args -> addProduction env cat (FApply funid args)) env xs - where - count = length xs - ys = foldr (zipWith Set.insert) (repeat Set.empty) xs - -convertRule :: TermMap -> GrammarEnv -> ProtoFRule -> GrammarEnv -convertRule cnc_defs grammarEnv (PFRule fun args res ctypes ctype term) = - let pres = protoFCat cnc_defs res ctype - pargs = zipWith (protoFCat cnc_defs) args ctypes - - b = runBranchM (convertTerm cnc_defs [] ctype term) (pargs,[]) - (grammarEnv1,b1) = addSequences' grammarEnv b - grammarEnv2 = brk (\grammarEnv -> foldBM addRule - grammarEnv - (go' b1 [] []) - (pres,pargs) ) grammarEnv1 - in grammarEnv2 - where - addRule lins (newCat', newArgs') env0 = - let [newCat] = getFCats env0 newCat' - (env1, newArgs) = List.mapAccumL (\env -> addFCoercion env . getFCats env) env0 newArgs' - - (env2,funid) = addFFun env1 (FFun fun [[n] | n <- [0..length newArgs-1]] (mkArray lins)) - - in addProduction env2 newCat (FApply funid newArgs) - ----------------------------------------------------------------------- --- Branch monad - -newtype BranchM a = BM (forall b . (a -> ([ProtoFCat],[FSymbol]) -> Branch b) -> ([ProtoFCat],[FSymbol]) -> Branch b) - -instance Monad BranchM where - return a = BM (\c s -> c a s) - BM m >>= k = BM (\c s -> m (\a s -> unBM (k a) c s) s) - where unBM (BM m) = m - -instance MonadState ([ProtoFCat],[FSymbol]) BranchM where - get = BM (\c s -> c s s) - put s = BM (\c _ -> c () s) - -instance Functor BranchM where - fmap f (BM m) = BM (\c s -> m (c . f) s) - -runBranchM :: BranchM (Value a) -> ([ProtoFCat],[FSymbol]) -> Branch a -runBranchM (BM m) s = m (\v s -> Return v) s - -variants :: [a] -> BranchM a -variants xs = BM (\c s -> Variant (go xs c s)) - where - go [] c s = [] - go (x:xs) c s = c x s : go xs c s - -choices :: Int -> FPath -> BranchM FIndex -choices nr path = BM (\c s -> let (args,_) = s - PFCat _ _ _ tcs = args !! nr - in case fromMaybe (error "evalTerm: wrong path") (lookup path tcs) of - [index] -> c index s - indices -> Case nr path (go indices c s)) - where - go [] c s = [] - go (i:is) c s = (c i (updateEnv i s)) : go is c s - - updateEnv index (args,seq) = (updateNth (restrictArg path index) nr args,seq) - - restrictArg path index (PFCat n cat rcs tcs) = PFCat n cat rcs (addConstraint path index tcs) - - addConstraint path0 index0 [] = error "restrictProtoFCat: unknown path" - addConstraint path0 index0 (c@(path,indices) : tcs) - | path0 == path = ((path,[index0]) : tcs) - | otherwise = c : addConstraint path0 index0 tcs - -mkRecord :: [BranchM (Value a)] -> BranchM (Value a) -mkRecord xs = BM (\c -> go xs (c . Rec)) - where - go [] c s = c [] s - go (BM m:fs) c s = go fs (\bs s -> c (m (\v s -> Return v) s : bs) s) s - --- cutBranch :: BranchM (Value a) -> BranchM (Branch a) --- cutBranch (BM m) = BM (\c e -> c (m (\v e -> Return v) e) e) - - ----------------------------------------------------------------------- --- term conversion - -type CnvMonad a = BranchM a - -type FPath = [FIndex] -data ProtoFCat = PFCat Int CId [FPath] [(FPath,[FIndex])] -type Env = (ProtoFCat, [ProtoFCat]) -data ProtoFRule = PFRule CId {- function -} - [(Int,CId)] {- argument types: context size and category -} - (Int,CId) {- result type : context size (always 0) and category -} - [Term] {- argument lin-types representation -} - Term {- result lin-type representation -} - Term {- body -} -type TermMap = Map.Map CId Term - - -protoFCat :: TermMap -> (Int,CId) -> Term -> ProtoFCat -protoFCat cnc_defs (n,cat) ctype = - let (rcs,tcs) = loop [] [] [] ctype' - in PFCat n cat rcs tcs - where - ctype' -- extend the high-order linearization type - | n > 0 = case ctype of - R xs -> R (xs ++ replicate n (S [])) - _ -> error $ "Not a record: " ++ show ctype - | otherwise = ctype - - loop path rcs tcs (R record) = List.foldl' (\(rcs,tcs) (index,term) -> loop (index:path) rcs tcs term) (rcs,tcs) (zip [0..] record) - loop path rcs tcs (C i) = ( rcs,(path,[0..i]):tcs) - loop path rcs tcs (S _) = (path:rcs, tcs) - loop path rcs tcs (F id) = case Map.lookup id cnc_defs of - Just term -> loop path rcs tcs term - Nothing -> error ("unknown identifier: "++show id) - -data Branch a - = Case Int FPath [Branch a] - | Variant [Branch a] - | Return (Value a) - -data Value a - = Rec [Branch a] - | Str a - | Con FIndex - - -go' :: Branch SeqId -> FPath -> [SeqId] -> BacktrackM Env [SeqId] -go' (Case nr path_ bs) path ss = do (index,b) <- member (zip [0..] bs) - restrictArg nr path_ index - go' b path ss -go' (Variant bs) path ss = do b <- member bs - go' b path ss -go' (Return v) path ss = go v path ss - -go :: Value SeqId -> FPath -> [SeqId] -> BacktrackM Env [SeqId] -go (Rec xs) path ss = foldM (\ss (lbl,b) -> go' b (lbl:path) ss) ss (zip [0..] xs) -go (Str seqid) path ss = return (seqid : ss) -go (Con i) path ss = restrictHead path i >> return ss - -addSequences' :: GrammarEnv -> Branch [FSymbol] -> (GrammarEnv, Branch SeqId) -addSequences' env (Case nr path bs) = let (env1,bs1) = List.mapAccumL addSequences' env bs - in (env1,Case nr path bs1) -addSequences' env (Variant bs) = let (env1,bs1) = List.mapAccumL addSequences' env bs - in (env1,Variant bs1) -addSequences' env (Return v) = let (env1,v1) = addSequences env v - in (env1,Return v1) - -addSequences :: GrammarEnv -> Value [FSymbol] -> (GrammarEnv, Value SeqId) -addSequences env (Rec vs) = let (env1,vs1) = List.mapAccumL addSequences' env vs - in (env1,Rec vs1) -addSequences env (Str lin) = let (env1,seqid) = addFSeq env (optimizeLin lin) - in (env1,Str seqid) -addSequences env (Con i) = (env,Con i) - - -optimizeLin [] = [] -optimizeLin lin@(FSymKS _ : _) = - let (ts,lin') = getRest lin - in FSymKS ts : optimizeLin lin' - where - getRest (FSymKS ts : lin) = let (ts1,lin') = getRest lin - in (ts++ts1,lin') - getRest lin = ([],lin) -optimizeLin (sym : lin) = sym : optimizeLin lin - - -convertTerm :: TermMap -> FPath -> Term -> Term -> CnvMonad (Value [FSymbol]) -convertTerm cnc_defs sel ctype (V nr) = convertArg ctype nr (reverse sel) -convertTerm cnc_defs sel ctype (C nr) = convertCon ctype nr (reverse sel) -convertTerm cnc_defs sel ctype (R record) = convertRec cnc_defs sel ctype record -convertTerm cnc_defs sel ctype (P term p) = do nr <- evalTerm cnc_defs [] p - convertTerm cnc_defs (nr:sel) ctype term -convertTerm cnc_defs sel ctype (FV vars) = do term <- variants vars - convertTerm cnc_defs sel ctype term -convertTerm cnc_defs sel ctype (S ts) = do vs <- mapM (convertTerm cnc_defs sel ctype) ts - return (Str (concat [s | Str s <- vs])) -convertTerm cnc_defs sel ctype (K (KS t)) = return (Str [FSymKS [t]]) -convertTerm cnc_defs sel ctype (K (KP s v))=return (Str [FSymKP s v]) -convertTerm cnc_defs sel ctype (F id) = case Map.lookup id cnc_defs of - Just term -> convertTerm cnc_defs sel ctype term - Nothing -> error ("unknown id " ++ showCId id) -convertTerm cnc_defs sel ctype (W s t) = do - ss <- case t of - R ss -> return ss - F f -> case Map.lookup f cnc_defs of - Just (R ss) -> return ss - _ -> error ("unknown id " ++ showCId f) - convertRec cnc_defs sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss] -convertTerm cnc_defs sel ctype x = error ("convertTerm ("++show x++")") - -convertArg :: Term -> Int -> FPath -> CnvMonad (Value [FSymbol]) -convertArg (R ctypes) nr path = do - mkRecord (zipWith (\lbl ctype -> convertArg ctype nr (lbl:path)) [0..] ctypes) -convertArg (C max) nr path = do - index <- choices nr path - return (Con index) -convertArg (S _) nr path = do - (args,_) <- get - let PFCat _ cat rcs tcs = args !! nr - l = index path rcs 0 - sym | isLiteralCat cat = FSymLit nr l - | otherwise = FSymCat nr l - return (Str [sym]) - where - index lbl' (lbl:lbls) idx - | lbl' == lbl = idx - | otherwise = index lbl' lbls $! (idx+1) - -convertCon (C max) index [] = return (Con index) -convertCon x _ _ = fail $ "SimpleToFCFG.convertCon: " ++ show x - -convertRec cnc_defs [] (R ctypes) record = do - mkRecord (zipWith (convertTerm cnc_defs []) ctypes record) -convertRec cnc_defs (index:sub_sel) ctype record = - convertTerm cnc_defs sub_sel ctype (record !! index) - - ------------------------------------------------------------- --- eval a term to ground terms - -evalTerm :: TermMap -> FPath -> Term -> CnvMonad FIndex -evalTerm cnc_defs path (V nr) = choices nr (reverse path) -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) = variants terms >>= evalTerm cnc_defs path -evalTerm cnc_defs path (F id) = case Map.lookup id cnc_defs of - Just term -> evalTerm cnc_defs path term - Nothing -> error ("unknown id " ++ showCId id) -evalTerm cnc_defs path x = error ("evalTerm ("++show x++")") - - ----------------------------------------------------------------------- --- GrammarEnv - -data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet CoerceSet (IntMap.IntMap (Set.Set Production)) -type CatSet = IntMap.IntMap (Map.Map CId (FCat,FCat,[Int])) -type SeqSet = Map.Map FSeq SeqId -type FunSet = Map.Map FFun FunId -type CoerceSet= Map.Map [FCat] FCat - -emptyGrammarEnv cnc_defs lincats = - let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats - in GrammarEnv last_id (IntMap.singleton 0 catSet) Map.empty Map.empty Map.empty IntMap.empty - where - computeCatRange index cat ctype - | cat == cidString = (index, (fcatString,fcatString,[])) - | cat == cidInt = (index, (fcatInt, fcatInt, [])) - | cat == cidFloat = (index, (fcatFloat, fcatFloat, [])) - | cat == cidVar = (index, (fcatVar, fcatVar, [])) - | otherwise = (index+size,(index,index+size-1,poly)) - where - (size,poly) = getMultipliers 1 [] ctype - - getMultipliers m ms (R record) = foldl (\(m,ms) t -> getMultipliers m ms t) (m,ms) record - getMultipliers m ms (S _) = (m,ms) - getMultipliers m ms (C max_index) = (m*(max_index+1),m : ms) - getMultipliers m ms (F id) = case Map.lookup id cnc_defs of - Just term -> getMultipliers m ms term - Nothing -> error ("unknown identifier: "++showCId id) - -expandHOAS abs_defs cnc_defs lincats lindefs env = - foldl add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) hoCats - where - hoTypes :: [(Int,CId)] - hoTypes = sortNub [(n,c) | (_,(ty,_,_)) <- abs_defs - , (n,c) <- fst (typeSkeleton ty), n > 0] - - hoCats :: [CId] - hoCats = sortNub [c | (_,(ty,_,_)) <- abs_defs - , h <- case ty of {DTyp hyps val _ -> hyps} - , let ty = typeOfHypo h - , c <- fst (catSkeleton ty)] - - -- add a range of PMCFG categories for each GF high-order category - add_hoCat env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,cat) = - case IntMap.lookup 0 catSet >>= Map.lookup cat of - Just (start,end,ms) -> let !catSet' = IntMap.insertWith Map.union n (Map.singleton cat (last_id,last_id+(end-start),ms)) catSet - !last_id' = last_id+(end-start)+1 - in (GrammarEnv last_id' catSet' seqSet funSet crcSet prodSet) - Nothing -> env - - -- add one PMCFG function for each high-order type: _B : Cat -> Var -> ... -> Var -> HoCat - add_hoFun env (n,cat) = - let linRec = reverse $ - [[FSymCat 0 i] | (l,i) <- case arg of {PFCat _ _ rcs _ -> zip rcs [0..]}] ++ - [[FSymLit i 0] | i <- [1..n]] - (env1,lins) = List.mapAccumL addFSeq env linRec - newLinRec = mkArray lins - - (env2,funid) = addFFun env1 (FFun _B [[i] | i <- [0..n]] newLinRec) - - env3 = foldl (\env (arg,res) -> addProduction env res (FApply funid (arg : replicate n fcatVar))) - env2 - (zip (getFCats env2 arg) (getFCats env2 res)) - in env3 - where - (arg,res) = case Map.lookup cat lincats of - Nothing -> error $ "No lincat for " ++ showCId cat - Just ctype -> (protoFCat cnc_defs (0,cat) ctype, protoFCat cnc_defs (n,cat) ctype) - - -- add one PMCFG function for each high-order category: _V : Var -> Cat - add_varFun env cat = - convertRule cnc_defs env (PFRule _V [(0,cidVar)] (0,cat) [arg] res lindef) - where - lindef = - case Map.lookup cat lindefs of - Nothing -> error $ "No lindef for " ++ showCId cat - Just def -> def - - arg = - case Map.lookup cidVar lincats of - Nothing -> error $ "No lincat for " ++ showCId cat - Just ctype -> ctype - - res = - case Map.lookup cat lincats of - Nothing -> error $ "No lincat for " ++ showCId cat - Just ctype -> ctype - - _B = mkCId "_B" - _V = mkCId "_V" - -addProduction :: GrammarEnv -> FCat -> Production -> GrammarEnv -addProduction (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) cat p = - GrammarEnv last_id catSet seqSet funSet crcSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet) - -addFSeq :: GrammarEnv -> [FSymbol] -> (GrammarEnv,SeqId) -addFSeq env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) lst = - case Map.lookup seq seqSet of - Just id -> (env,id) - Nothing -> let !last_seq = Map.size seqSet - in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet crcSet prodSet,last_seq) - where - seq = mkArray lst - -addFFun :: GrammarEnv -> FFun -> (GrammarEnv,FunId) -addFFun env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) fun = - case Map.lookup fun funSet of - Just id -> (env,id) - Nothing -> let !last_funid = Map.size funSet - in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) crcSet prodSet,last_funid) - -addFCoercion :: GrammarEnv -> [FCat] -> (GrammarEnv,FCat) -addFCoercion env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) sub_fcats = - case sub_fcats of - [fcat] -> (env,fcat) - _ -> case Map.lookup sub_fcats crcSet of - Just fcat -> (env,fcat) - Nothing -> let !fcat = last_id+1 - in (GrammarEnv fcat catSet seqSet funSet (Map.insert sub_fcats fcat crcSet) prodSet,fcat) - -getParserInfo :: GrammarEnv -> ParserInfo -getParserInfo (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = - ParserInfo { functions = mkArray funSet - , sequences = mkArray seqSet - , productions0= productions0 - , productions = filterProductions productions0 - , startCats = maybe Map.empty (Map.map (\(start,end,_) -> range (start,end))) (IntMap.lookup 0 catSet) - , totalCats = last_id+1 - } - where - mkArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] - - productions0 = IntMap.union prodSet coercions - coercions = IntMap.fromList [(fcat,Set.fromList (map FCoerce sub_fcats)) | (sub_fcats,fcat) <- Map.toList crcSet] - -getFCats :: GrammarEnv -> ProtoFCat -> [FCat] -getFCats (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat rcs tcs) = - case IntMap.lookup n catSet >>= Map.lookup cat of - Just (start,end,ms) -> reverse (solutions (variants ms tcs start) ()) - where - variants _ [] fcat = return fcat - variants (m:ms) ((_,indices) : tcs) fcat = do index <- member indices - variants ms tcs ((m*index) + fcat) - - ------------------------------------------------------------- --- updating the MCF rule - -restrictArg :: FIndex -> FPath -> FIndex -> BacktrackM Env () -restrictArg nr path index = do - (head, args) <- get - args' <- updateNthM (restrictProtoFCat path index) nr args - put (head, args') - -restrictHead :: FPath -> FIndex -> BacktrackM Env () -restrictHead path term - = do (head, args) <- get - head' <- restrictProtoFCat path term head - put (head', args) - -restrictProtoFCat :: FPath -> FIndex -> ProtoFCat -> BacktrackM Env ProtoFCat -restrictProtoFCat path0 index0 (PFCat n cat rcs tcs) = do - tcs <- addConstraint tcs - return (PFCat n cat rcs tcs) - where - addConstraint [] = error "restrictProtoFCat: unknown path" - addConstraint (c@(path,indices) : tcs) - | path0 == path = guard (index0 `elem` indices) >> - return ((path,[index0]) : tcs) - | otherwise = liftM (c:) (addConstraint tcs) - -mkArray lst = listArray (0,length lst-1) lst diff --git a/src/GF/Compile/GeneratePMCFGOld.hs b/src/GF/Compile/GeneratePMCFGOld.hs deleted file mode 100644 index 244ed68fe..000000000 --- a/src/GF/Compile/GeneratePMCFGOld.hs +++ /dev/null @@ -1,374 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP #-} ----------------------------------------------------------------------- --- | --- 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.Compile.GeneratePMCFG - (convertConcrete) where - -import PGF.CId -import PGF.Data -import PGF.Macros --hiding (prt) - -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 qualified Data.IntMap as IntMap -import qualified Data.ByteString.Char8 as BS -import Data.Array.IArray -import Data.Maybe -import Control.Monad -import Debug.Trace - ----------------------------------------------------------------------- --- main conversion function - -convertConcrete :: Abstr -> Concr -> ParserInfo -convertConcrete abs cnc = 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 - -convert :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> ParserInfo -convert abs_defs cnc_defs cat_defs = - let env = expandHOAS abs_defs cnc_defs cat_defs (emptyGrammarEnv cnc_defs cat_defs) - in getParserInfo (List.foldl' (convertRule cnc_defs) env xrules) - where - xrules = [ - (XRule id args (0,res) (map findLinType args) (findLinType (0,res)) term) | - (id, (ty,_)) <- abs_defs, let (args,res) = typeSkeleton ty, - term <- maybeToList (Map.lookup id cnc_defs)] - - findLinType (_,id) = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs) - -brk :: (GrammarEnv -> GrammarEnv) -> (GrammarEnv -> GrammarEnv) -brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = - case f (GrammarEnv last_id catSet seqSet funSet crcSet IntMap.empty) of - (GrammarEnv last_id catSet seqSet funSet crcSet topdown1) -> IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) topdown1 - where - optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | FApply funid args <- Set.toList ps]) - where - ff :: FunId -> [[FCat]] -> GrammarEnv -> GrammarEnv - ff funid xs env - | product (map Set.size ys) == count = - case List.mapAccumL (\env c -> addFCoercion env (Set.toList c)) env ys of - (env,args) -> addProduction env cat (FApply funid args) - | otherwise = List.foldl (\env args -> addProduction env cat (FApply funid args)) env xs - where - count = length xs - ys = foldr (zipWith Set.insert) (repeat Set.empty) xs - -convertRule :: TermMap -> GrammarEnv -> XRule -> GrammarEnv -convertRule cnc_defs grammarEnv (XRule fun args res ctypes ctype term) = - brk (\grammarEnv -> foldBM addRule - grammarEnv - (convertTerm cnc_defs [] ctype term [([],[])]) - (protoFCat cnc_defs res ctype, zipWith (protoFCat cnc_defs) args ctypes)) grammarEnv - where - addRule linRec (newCat', newArgs') env0 = - let [newCat] = getFCats env0 newCat' - (env1, newArgs) = List.mapAccumL (\env -> addFCoercion env . getFCats env) env0 newArgs' - - (env2,lins) = List.mapAccumL addFSeq env1 linRec - newLinRec = mkArray lins - - (env3,funid) = addFFun env2 (FFun fun [[n] | n <- [0..length newArgs-1]] newLinRec) - - in addProduction env3 newCat (FApply funid newArgs) - ----------------------------------------------------------------------- --- term conversion - -type CnvMonad a = BacktrackM Env a - -type FPath = [FIndex] -data ProtoFCat = PFCat Int CId [FPath] [(FPath,[FIndex])] -type Env = (ProtoFCat, [ProtoFCat]) -type LinRec = [(FPath, [FSymbol])] -data XRule = XRule CId {- function -} - [(Int,CId)] {- argument types: context size and category -} - (Int,CId) {- result type : context size (always 0) and category -} - [Term] {- argument lin-types representation -} - Term {- result lin-type representation -} - Term {- body -} - -protoFCat :: TermMap -> (Int,CId) -> Term -> ProtoFCat -protoFCat cnc_defs (n,cat) ctype = - let (rcs,tcs) = loop [] [] [] ctype' - in PFCat n cat rcs tcs - where - ctype' -- extend the high-order linearization type - | n > 0 = case ctype of - R xs -> R (xs ++ replicate n (S [])) - _ -> error $ "Not a record: " ++ show ctype - | otherwise = ctype - - loop path rcs tcs (R record) = List.foldl' (\(rcs,tcs) (index,term) -> loop (index:path) rcs tcs term) (rcs,tcs) (zip [0..] record) - loop path rcs tcs (C i) = ( rcs,(path,[0..i]):tcs) - loop path rcs tcs (S _) = (path:rcs, tcs) - loop path rcs tcs (F id) = case Map.lookup id cnc_defs of - Just term -> loop path rcs tcs term - Nothing -> error ("unknown identifier: "++show id) - -type TermMap = Map.Map CId Term - -convertTerm :: TermMap -> FPath -> Term -> Term -> LinRec -> CnvMonad LinRec -convertTerm cnc_defs sel ctype (V nr) ((lbl_path,lin) : lins) = convertArg ctype nr (reverse sel) lbl_path lin lins -convertTerm cnc_defs sel ctype (C nr) ((lbl_path,lin) : lins) = convertCon ctype nr (reverse sel) lbl_path lin lins -convertTerm cnc_defs sel ctype (R record) ((lbl_path,lin) : lins) = convertRec cnc_defs sel ctype record lbl_path lin lins -convertTerm cnc_defs sel ctype (P term p) lins = do nr <- evalTerm cnc_defs [] p - convertTerm cnc_defs (nr:sel) ctype term lins -convertTerm cnc_defs sel ctype (FV vars) lins = do term <- member vars - convertTerm cnc_defs sel ctype term lins -convertTerm cnc_defs sel ctype (S ts) lins = foldM (\lins t -> convertTerm cnc_defs sel ctype t lins) lins (reverse ts) ---convertTerm cnc_defs sel ctype (K t) ((lbl_path,lin) : lins) = return ((lbl_path,FSymTok t : lin) : lins) -convertTerm cnc_defs sel ctype (K (KS t)) ((lbl_path,lin) : lins) = return ((lbl_path,FSymTok (KS t) : lin) : lins) -convertTerm cnc_defs sel ctype (K (KP strs vars))((lbl_path,lin) : lins) = - do toks <- member (strs:[strs' | Alt strs' _ <- vars]) - return ((lbl_path, map (FSymTok . KS) toks ++ lin) : lins) -convertTerm cnc_defs sel ctype (F id) lins = case Map.lookup id cnc_defs of - Just term -> convertTerm cnc_defs sel ctype term lins - Nothing -> mzero -convertTerm cnc_defs sel ctype (W s t) ((lbl_path,lin) : lins) = do - ss <- case t of - R ss -> return ss - F f -> case Map.lookup f cnc_defs of - Just (R ss) -> return ss - _ -> mzero - convertRec cnc_defs sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss] lbl_path lin lins -convertTerm cnc_defs sel ctype x lins = error ("convertTerm ("++show x++")") - - -convertArg (R record) nr path lbl_path lin lins = - foldM (\lins (lbl, ctype) -> convertArg ctype nr (lbl:path) (lbl:lbl_path) lin lins) lins (zip [0..] record) -convertArg (C max) nr path lbl_path lin lins = do - index <- member [0..max] - restrictHead lbl_path index - restrictArg nr path index - return lins -convertArg (S _) nr path lbl_path lin lins = do - (_, args) <- get - let PFCat _ cat rcs tcs = args !! nr - l = index path rcs 0 - sym | isLiteralCat cat = FSymLit nr l - | otherwise = FSymCat nr l - return ((lbl_path, sym : lin) : lins) - where - index lbl' (lbl:lbls) idx - | lbl' == lbl = idx - | otherwise = index lbl' lbls $! (idx+1) - - -convertCon (C max) index [] lbl_path lin lins = do - guard (index <= max) - restrictHead lbl_path index - return lins -convertCon x _ _ _ _ _ = error $ "SimpleToFCFG,convertCon: " ++ show x - -convertRec cnc_defs [] (R ctypes) record lbl_path lin lins = - foldM (\lins (index,ctype,val) -> convertTerm cnc_defs [] ctype val ((index:lbl_path,lin) : lins)) - lins - (zip3 [0..] ctypes record) -convertRec cnc_defs (index:sub_sel) ctype record lbl_path lin lins = do - convertTerm cnc_defs sub_sel ctype (record !! index) ((lbl_path,lin) : lins) - - ------------------------------------------------------------- --- eval a term to ground terms - -evalTerm :: TermMap -> FPath -> Term -> CnvMonad FIndex -evalTerm cnc_defs path (V nr) = do (_, args) <- get - let PFCat _ _ _ tcs = args !! nr - rpath = reverse path - index <- member (fromMaybe (error "evalTerm: wrong path") (lookup rpath tcs)) - restrictArg nr rpath index - return index -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 (F id) = case Map.lookup id cnc_defs of - Just term -> evalTerm cnc_defs path term - Nothing -> mzero -evalTerm cnc_defs path x = error ("evalTerm ("++show x++")") - - ----------------------------------------------------------------------- --- GrammarEnv - -data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet CoerceSet (IntMap.IntMap (Set.Set Production)) -type CatSet = IntMap.IntMap (Map.Map CId (FCat,FCat,[Int])) -type SeqSet = Map.Map FSeq SeqId -type FunSet = Map.Map FFun FunId -type CoerceSet= Map.Map [FCat] FCat - -emptyGrammarEnv cnc_defs lincats = - let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats - in GrammarEnv last_id (IntMap.singleton 0 catSet) Map.empty Map.empty Map.empty IntMap.empty - where - computeCatRange index cat ctype - | cat == cidString = (index, (fcatString,fcatString,[])) - | cat == cidInt = (index, (fcatInt, fcatInt, [])) - | cat == cidFloat = (index, (fcatFloat, fcatFloat, [])) - | otherwise = (index+size,(index,index+size-1,poly)) - where - (size,poly) = getMultipliers 1 [] ctype - - getMultipliers m ms (R record) = foldl (\(m,ms) t -> getMultipliers m ms t) (m,ms) record - getMultipliers m ms (S _) = (m,ms) - getMultipliers m ms (C max_index) = (m*(max_index+1),m : ms) - getMultipliers m ms (F id) = case Map.lookup id cnc_defs of - Just term -> getMultipliers m ms term - Nothing -> error ("unknown identifier: "++prCId id) - - -expandHOAS abs_defs cnc_defs lincats env = - foldl add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) hoCats - where - hoTypes :: [(Int,CId)] - hoTypes = sortNub [(n,c) | (_,(ty,_)) <- abs_defs - , (n,c) <- fst (typeSkeleton ty), n > 0] - - hoCats :: [CId] - hoCats = sortNub [c | (_,(ty,_)) <- abs_defs - , Hyp _ ty <- case ty of {DTyp hyps val _ -> hyps} - , c <- fst (catSkeleton ty)] - - -- add a range of PMCFG categories for each GF high-order category - add_hoCat env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,cat) = - case IntMap.lookup 0 catSet >>= Map.lookup cat of - Just (start,end,ms) -> let !catSet' = IntMap.insertWith Map.union n (Map.singleton cat (last_id,last_id+(end-start),ms)) catSet - !last_id' = last_id+(end-start)+1 - in (GrammarEnv last_id' catSet' seqSet funSet crcSet prodSet) - Nothing -> env - - -- add one PMCFG function for each high-order type: _B : Cat -> Var -> ... -> Var -> HoCat - add_hoFun env (n,cat) = - let linRec = reverse $ - [(l ,[FSymCat 0 i]) | (l,i) <- case arg of {PFCat _ _ rcs _ -> zip rcs [0..]}] ++ - [([],[FSymLit i 0]) | i <- [1..n]] - (env1,lins) = List.mapAccumL addFSeq env linRec - newLinRec = mkArray lins - - (env2,funid) = addFFun env1 (FFun _B [[i] | i <- [0..n]] newLinRec) - - env3 = foldl (\env (arg,res) -> addProduction env res (FApply funid (arg : replicate n fcatVar))) - env2 - (zip (getFCats env2 arg) (getFCats env2 res)) - in env3 - where - (arg,res) = case Map.lookup cat lincats of - Nothing -> error $ "No lincat for " ++ prCId cat - Just ctype -> (protoFCat cnc_defs (0,cat) ctype, protoFCat cnc_defs (n,cat) ctype) - - -- add one PMCFG function for each high-order category: _V : Var -> Cat - add_varFun env cat = - let (env1,seqid) = addFSeq env ([],[FSymLit 0 0]) - lins = replicate (case res of {PFCat _ _ rcs _ -> length rcs}) seqid - (env2,funid) = addFFun env1 (FFun _V [[0]] (mkArray lins)) - env3 = foldl (\env res -> addProduction env2 res (FApply funid [fcatVar])) - env2 - (getFCats env2 res) - in env3 - where - res = case Map.lookup cat lincats of - Nothing -> error $ "No lincat for " ++ prCId cat - Just ctype -> protoFCat cnc_defs (0,cat) ctype - - _B = mkCId "_B" - _V = mkCId "_V" - - -addProduction :: GrammarEnv -> FCat -> Production -> GrammarEnv -addProduction (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) cat p = - GrammarEnv last_id catSet seqSet funSet crcSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet) - -addFSeq :: GrammarEnv -> (FPath,[FSymbol]) -> (GrammarEnv,SeqId) -addFSeq env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (_,lst) = - case Map.lookup seq seqSet of - Just id -> (env,id) - Nothing -> let !last_seq = Map.size seqSet - in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet crcSet prodSet,last_seq) - where - seq = mkArray lst - -addFFun :: GrammarEnv -> FFun -> (GrammarEnv,FunId) -addFFun env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) fun = - case Map.lookup fun funSet of - Just id -> (env,id) - Nothing -> let !last_funid = Map.size funSet - in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) crcSet prodSet,last_funid) - -addFCoercion :: GrammarEnv -> [FCat] -> (GrammarEnv,FCat) -addFCoercion env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) sub_fcats = - case sub_fcats of - [fcat] -> (env,fcat) - _ -> case Map.lookup sub_fcats crcSet of - Just fcat -> (env,fcat) - Nothing -> let !fcat = last_id+1 - in (GrammarEnv fcat catSet seqSet funSet (Map.insert sub_fcats fcat crcSet) prodSet,fcat) - -getParserInfo :: GrammarEnv -> ParserInfo -getParserInfo (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = - ParserInfo { functions = mkArray funSet - , sequences = mkArray seqSet - , productions = IntMap.union prodSet coercions - , startCats = maybe Map.empty (Map.map (\(start,end,_) -> range (start,end))) (IntMap.lookup 0 catSet) - , totalCats = last_id+1 - } - where - mkArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] - - coercions = IntMap.fromList [(fcat,Set.fromList (map FCoerce sub_fcats)) | (sub_fcats,fcat) <- Map.toList crcSet] - -getFCats :: GrammarEnv -> ProtoFCat -> [FCat] -getFCats (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat rcs tcs) = - case IntMap.lookup n catSet >>= Map.lookup cat of - Just (start,end,ms) -> reverse (solutions (variants ms tcs start) ()) - where - variants _ [] fcat = return fcat - variants (m:ms) ((_,indices) : tcs) fcat = do index <- member indices - variants ms tcs ((m*index) + fcat) - ------------------------------------------------------------- --- updating the MCF rule - -restrictArg :: FIndex -> FPath -> FIndex -> CnvMonad () -restrictArg nr path index = do - (head, args) <- get - args' <- updateNthM (restrictProtoFCat path index) nr args - put (head, args') - -restrictHead :: FPath -> FIndex -> CnvMonad () -restrictHead path term - = do (head, args) <- get - head' <- restrictProtoFCat path term head - put (head', args) - -restrictProtoFCat :: FPath -> FIndex -> ProtoFCat -> CnvMonad ProtoFCat -restrictProtoFCat path0 index0 (PFCat n cat rcs tcs) = do - tcs <- addConstraint tcs - return (PFCat n cat rcs tcs) - where - addConstraint [] = error "restrictProtoFCat: unknown path" - addConstraint (c@(path,indices) : tcs) - | path0 == path = guard (index0 `elem` indices) >> - return ((path,[index0]) : tcs) - | otherwise = liftM (c:) (addConstraint tcs) - -mkArray lst = listArray (0,length lst-1) lst diff --git a/src/GF/Compile/GetGrammar.hs b/src/GF/Compile/GetGrammar.hs deleted file mode 100644 index c85f9588f..000000000 --- a/src/GF/Compile/GetGrammar.hs +++ /dev/null @@ -1,52 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GetGrammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/15 17:56:13 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.16 $ --- --- this module builds the internal GF grammar that is sent to the type checker ------------------------------------------------------------------------------ - -module GF.Compile.GetGrammar (getSourceModule, addOptionsToModule) where - -import GF.Data.Operations - -import GF.Infra.UseIO -import GF.Infra.Modules -import GF.Infra.Option -import GF.Grammar.Lexer -import GF.Grammar.Parser -import GF.Grammar.Grammar - -import GF.Compile.ReadFiles - -import Data.Char (toUpper) -import Data.List (nub) -import qualified Data.ByteString.Char8 as BS -import Control.Monad (foldM) -import System.Cmd (system) - -getSourceModule :: Options -> FilePath -> IOE SourceModule -getSourceModule opts file0 = ioe $ - catch (do file <- foldM runPreprocessor file0 (flag optPreprocessors opts) - content <- BS.readFile file - case runP pModDef content of - Left (Pn l c,msg) -> return (Bad (file++":"++show l++":"++show c++": "++msg)) - Right mo -> return (Ok (addOptionsToModule opts mo))) - (\e -> return (Bad (show e))) - -addOptionsToModule :: Options -> SourceModule -> SourceModule -addOptionsToModule opts = mapSourceModule (\m -> m { flags = flags m `addOptions` opts }) - --- FIXME: should use System.IO.openTempFile -runPreprocessor :: FilePath -> String -> IO FilePath -runPreprocessor file0 p = do - let tmp = "_gf_preproc.tmp" - cmd = p +++ file0 ++ ">" ++ tmp - system cmd - return tmp diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs deleted file mode 100644 index fb92ef74c..000000000 --- a/src/GF/Compile/GrammarToGFCC.hs +++ /dev/null @@ -1,587 +0,0 @@ -{-# LANGUAGE PatternGuards #-} -module GF.Compile.GrammarToGFCC (mkCanon2gfcc,addParsers) where - -import GF.Compile.Export -import qualified GF.Compile.GenerateFCFG as FCFG -import qualified GF.Compile.GeneratePMCFG as PMCFG - -import PGF.CId -import qualified PGF.Macros as CM -import qualified PGF.Data as C -import qualified PGF.Data as D -import GF.Grammar.Predef -import GF.Grammar.Printer -import GF.Grammar.Grammar -import qualified GF.Grammar.Lookup as Look -import qualified GF.Grammar as A -import qualified GF.Grammar.Macros as GM -import qualified GF.Compile.Concrete.Compute as Compute ---- -import qualified GF.Infra.Modules as M -import qualified GF.Infra.Option as O - -import GF.Infra.Ident -import GF.Infra.Option -import GF.Data.Operations - -import Data.List -import Data.Char (isDigit,isSpace) -import qualified Data.Map as Map -import qualified Data.ByteString.Char8 as BS -import Text.PrettyPrint -import Debug.Trace ---- - --- when developing, swap commenting ---traceD s t = trace s t -traceD s t = t - - --- the main function: generate PGF from GF. -mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.PGF) -mkCanon2gfcc opts cnc gr = - (showIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon opts abs) gr) - where - abs = err (const c) id $ M.abstractOfConcrete gr c where c = identC (BS.pack cnc) - pars = mkParamLincat gr - --- Adds parsers for all concretes -addParsers :: Options -> D.PGF -> IO D.PGF -addParsers opts pgf = do cncs <- sequence [conv lang cnc | (lang,cnc) <- Map.toList (D.concretes pgf)] - return pgf { D.concretes = Map.fromList cncs } - where - conv lang cnc = do pinfo <- if flag optErasing (erasingFromCnc `addOptions` opts) - then PMCFG.convertConcrete opts (D.abstract pgf) lang cnc - else return $ FCFG.convertConcrete (D.abstract pgf) cnc - return (lang,cnc { D.parser = Just pinfo }) - where - erasingFromCnc = modifyFlags (\o -> o { optErasing = Map.lookup (mkCId "erasing") (D.cflags cnc) == Just "on"}) - --- Generate PGF from GFCM. --- this assumes a grammar translated by canon2canon - -canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.PGF -canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) = - (if dump opts DumpCanon then trace (render (vcat (map (ppModule Qualified) (M.modules cgr)))) else id) $ - D.PGF an cns gflags abs cncs - where - -- abstract - an = (i2i a) - cns = map (i2i . fst) cms - abs = D.Abstr aflags funs cats catfuns - gflags = Map.empty - aflags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF (M.flags abm)] - - mkDef (Just eqs) = [C.Equ ps' (mkExp scope' e) | (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] - mkDef Nothing = [] - - mkArrity (Just a) = a - mkArrity Nothing = 0 - - -- concretes - lfuns = [(f', (mkType [] ty, mkArrity ma, mkDef pty)) | - (f,AbsFun (Just ty) ma pty) <- tree2list (M.jments abm), let f' = i2i f] - funs = Map.fromAscList lfuns - lcats = [(i2i c, snd (mkContext [] cont)) | - (c,AbsCat (Just 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,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 [(mkCId f,x) | (f,x) <- optionsPGF (M.flags mo)] - opers = Map.fromAscList [] -- opers will be created as optimization - utf = id -- trace (show lang0 +++ show flags) $ - -- if moduleFlag optEncoding (moduleOptions (M.flags mo)) == UTF_8 - -- then id else id - ---- then (trace "decode" D.convertStringsInTerm decodeUTF8) else id - umkTerm = utf . mkTerm - lins = Map.fromAscList - [(f', umkTerm tr) | (f,CncFun _ (Just tr) _) <- js, - let f' = i2i f, exists f'] -- eliminating lins without fun - -- needed even here because of restricted inheritance - lincats = Map.fromAscList - [(i2i c, mkCType ty) | (c,CncCat (Just ty) _ _) <- js] - lindefs = Map.fromAscList - [(i2i c, umkTerm tr) | (c,CncCat _ (Just tr) _) <- js] - printnames = Map.union - (Map.fromAscList [(i2i f, umkTerm tr) | (f,CncFun _ _ (Just tr)) <- js]) - (Map.fromAscList [(i2i f, umkTerm tr) | (f,CncCat _ _ (Just tr)) <- js]) - params = Map.fromAscList - [(i2i c, pars lang0 c) | (c,CncCat (Just ty) _ _) <- js] - fcfg = Nothing - - exists f = Map.member f funs - -i2i :: Ident -> CId -i2i = CId . ident2bs - -b2b :: A.BindType -> C.BindType -b2b A.Explicit = C.Explicit -b2b A.Implicit = C.Implicit - -mkType :: [Ident] -> A.Type -> C.Type -mkType scope t = - case GM.typeForm t of - (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps - in C.DTyp hyps' (i2i cat) (map (mkExp scope') args) - -mkExp :: [Ident] -> A.Term -> C.Expr -mkExp scope t = case GM.termForm t of - Ok (xs,c,args) -> mkAbs xs (mkApp (map snd (reverse xs)++scope) c (map (mkExp scope) args)) - where - mkAbs xs t = foldr (\(b,v) -> C.EAbs (b2b b) (i2i v)) t xs - mkApp scope c args = case c of - Q _ c -> foldl C.EApp (C.EFun (i2i c)) args - QC _ c -> foldl C.EApp (C.EFun (i2i c)) args - Vr x -> case lookup x (zip scope [0..]) of - Just i -> foldl C.EApp (C.EVar i) args - Nothing -> foldl C.EApp (C.EMeta 0) args - EInt i -> C.ELit (C.LInt i) - EFloat f -> C.ELit (C.LFlt f) - K s -> C.ELit (C.LStr s) - Meta i -> C.EMeta i - _ -> C.EMeta 0 - -mkPatt scope p = - case p of - A.PP _ c ps -> let (scope',ps') = mapAccumL mkPatt scope ps - in (scope',C.PApp (i2i c) ps') - A.PV x -> (x:scope,C.PVar (i2i x)) - A.PW -> ( scope,C.PWild) - A.PInt i -> ( scope,C.PLit (C.LInt i)) - A.PFloat f -> ( scope,C.PLit (C.LFlt f)) - A.PString s -> ( scope,C.PLit (C.LStr s)) - - -mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo]) -mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty - in if x == identW - then ( scope,(b2b bt,i2i x,ty')) - else (x:scope,(b2b bt,i2i x,ty'))) scope 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 (BS.last s) -> - C.V ((read . BS.unpack . snd . BS.spanEnd isDigit) 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.Alt (strings u) (strings v) | (u,v) <- tvs]) - _ -> prtTrace tr $ C.S [C.K (C.KS (render (A.ppTerm Unqualified 0 tr <+> int 66662)))] ---- for debugging - where - mkLab (LIdent l) = case BS.unpack 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 PGF-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) - _ | Just i <- GM.isTypeInts pt -> C.R $ replicate (fromInteger i) $ mkCType vt - - Sort s | s == cStr -> C.S [] --- Str only - _ | Just i <- GM.isTypeInts t -> 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 $ showIdent (label2ident 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 s | s == cStr -> return $ C.S [] - _ -> return $ - C.FV $ map (kks . filter showable . render . ppTerm Unqualified 0) $ - 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.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs poss): - [(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] [] (sorted2tree js) poss) - | (c,(fs,js)) <- cncs] - where - poss = emptyBinTree -- positions no longer needed - mos = M.modules cg - adefs = sorted2tree $ sortIds $ - predefADefs ++ Look.allOrigInfos cg abs - predefADefs = - [(c, AbsCat (Just []) Nothing) | c <- [cFloat,cInt,cString]] - aflags = - concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo] - - cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs] - concr la = (flags, - sortIds (predefCDefs ++ jments)) where - jments = Look.allOrigInfos cg la - flags = concatOptions - [M.flags mo | - (i,mo) <- mos, M.isModCnc mo, - Just r <- [lookup i (M.allExtendSpecs cg la)]] - - predefCDefs = - [(c, CncCat (Just GM.defLinType) Nothing Nothing) | c <- [cInt,cFloat,cString]] - - sortIds = sortBy (\ (f,_) (g,_) -> compare 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.modules cg, - lang <- case M.allConcretes cg abs of - [] -> [abs] -- to make pgf nonempty even when there are no concretes - cncs -> cncs, - let mo = errVal - (error (render (text "no module found for" <+> A.ppIdent lang))) $ M.lookupModule cg lang - ] - --- translate tables and records to arrays, parameters and labels to indices - -canon2canon :: Options -> Ident -> SourceGrammar -> SourceGrammar -canon2canon opts abs cg0 = - (recollect . map cl2cl . repartition abs . purgeGrammar abs) cg0 - 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,mo) = (c, M.replaceJudgements mo $ mapTree f2 (M.jments mo)) - - j2j cg (f,j) = - let debug = if verbAtLeast opts Verbose then trace ("+ " ++ showIdent f) else id in - case j of - CncFun x (Just tr) z -> CncFun x (Just (debug (t2t (unfactor cg0 tr)))) z - CncCat (Just ty) (Just x) y -> CncCat (Just (ty2ty ty)) (Just (t2t (unfactor cg0 x))) y - _ -> j - where - cg1 = cg - t2t = term2term f cg1 pv - ty2ty = type2type cg1 pv - pv@(labels,untyps,typs) = trs $ paramValues cg1 - - 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] - _ -> GM.composSafeOp unfac t - where - unfac = unfactor gr - vals = err error id . Look.allParamValues gr - restore x u t = case t of - Vr y | y == x -> u - _ -> GM.composSafeOp (restore x u) t - - -- flatten record arguments of param constructors - p2p (f,j) = case j of - ResParam (Just ps) (Just vs) -> - ResParam (Just [(c,concatMap unRec cont) | (c,cont) <- ps]) (Just (map unrec vs)) - _ -> j - unRec (bt,x,ty) = case ty of - RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (Explicit,identW,typ)] - _ -> [(bt,x,ty)] - unrec t = case t of - App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs] - _ -> GM.composSafeOp unrec t - - ----- - trs v = traceD (render (tr v)) v - - tr (labels,untyps,typs) = - (text "LABELS:" <+> - vcat [A.ppIdent c <> char '.' <> hsep (map A.ppLabel l) <+> char '=' <+> text (show i) | ((c,l),i) <- Map.toList labels]) $$ - (text "UNTYPS:" <+> - vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show i) | (t,i) <- Map.toList untyps]) $$ - (text "TYPS: " <+> - vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show (Map.assocs i)) | (t,i) <- Map.toList typs]) ----- - -purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar -purgeGrammar abstr gr = - (M.MGrammar . list . filter complete . purge . M.modules) gr - where - list ms = traceD (render (text "MODULES" <+> hsep (punctuate comma (map (ppIdent . 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) = M.isCompleteModule m --- not . isIncompleteCanon - -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 (Just ty0) _ _)) <- jments, - ty <- typsFrom ty0 - ] ++ [ - Q m ty | - (m,(ty,ResParam _ _)) <- jments - ] ++ [ty | - (_,(_,CncFun _ (Just 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 = (if isParam ty then (ty:) else id) $ case ty of - Table p t -> typsFrom p ++ typsFrom t - RecType ls -> concat [typsFrom t | (_, t) <- ls] - _ -> [] - - isParam ty = case ty of - Q _ _ -> True - QC _ _ -> True - RecType rs -> all isParam (map snd rs) - _ -> False - - 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 - - mods = traceD (render (hsep (map (ppIdent . fst) ms))) ms where ms = M.modules cgr - - jments = - [(m,j) | (m,mo) <- mods, 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 = - [(cat,[f | let RecType fs = GM.defLinType, f <- fs]) | cat <- [cInt,cFloat, cString]] ++ - reverse ---- TODO: really those lincats that are reached - ---- reverse is enough to expel overshadowed ones... - [(cat,ls) | (_,(cat,CncCat (Just ty) _ _)) <- jments, - RecType ls <- [unlockTy ty]] - 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 :: Ident -> SourceGrammar -> ParamEnv -> Term -> Term -term2term fun 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..] (GM.sortRec (unlock rs))] - P t l -> r2r tr - - T (TWild _) _ -> error $ (render (text "wild" <+> ppTerm Qualified 0 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 fun 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: - comp t = errVal t $ Compute.computeConcreteRec cgr 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 $ (BS.pack (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 $ render (text "doVar1" <+> A.ppTerm Unqualified 0 ty) - _ -> error $ render (text "doVar2" <+> A.ppTerm Unqualified 0 tr <+> text (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 (render (A.ppTerm Unqualified 0 tr <+> prtTrace tr (int 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 = BS.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] -> let msg = render (text "DEBUG" <+> ppIdent fun <> text ": error in valNum" <+> ppTerm Qualified 0 tr) in - trace msg $ error (showIdent fun) - _ -> 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 (BS.pack ("_" ++ 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 $ GM.sortRec [(l, unlockTy t) | (l,t) <- ls, notlock (l,t)] - _ -> GM.composSafeOp unlockTy ty - - -prtTrace tr n = - trace (render (text "-- INTERNAL COMPILER ERROR" <+> A.ppTerm Unqualified 0 tr $$ text (show n))) n -prTrace tr n = trace (render (text "-- OBSERVE" <+> A.ppTerm Unqualified 0 tr <+> text (show n) <+> text (show tr))) n - - --- | 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 -> M.MGrammar i a -> i -> [i] -requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where - exts = M.allExtends gr c - ops = if isSingle - then map fst (M.modules gr) - else iterFix (concatMap more) $ exts - more i = errVal [] $ do - m <- M.lookupModule gr i - return $ M.extends m ++ [o | o <- map M.openedModule (M.opens m)] - notReuse i = errVal True $ do - m <- M.lookupModule gr i - return $ M.isModRes m -- to exclude reused Cnc and Abs from required diff --git a/src/GF/Compile/ModDeps.hs b/src/GF/Compile/ModDeps.hs deleted file mode 100644 index 1e689aabc..000000000 --- a/src/GF/Compile/ModDeps.hs +++ /dev/null @@ -1,145 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ModDeps --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:34 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.14 $ --- --- Check correctness of module dependencies. Incomplete. --- --- AR 13\/5\/2003 ------------------------------------------------------------------------------ - -module GF.Compile.ModDeps (mkSourceGrammar, - moduleDeps, - openInterfaces, - requiredCanModules - ) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Option -import GF.Grammar.Printer -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 :: [SourceModule] -> 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 = test [n | OQualif n v <- opens mo, n /= v] - 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 :: [SourceModule] -> Err Dependencies -moduleDeps ms = mapM deps ms where - deps (c,m) = errIn ("checking dependencies of module" +++ prt c) $ 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 - (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 - _ -> case mt of - MTResource -> 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 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 <- lookupModule gr i - return $ extends m ++ [o | o <- map openedModule (opens m)] - notReuse i = errVal True $ do - m <- lookupModule gr i - return $ isModRes m -- to exclude reused Cnc and Abs from required - - -{- --- to test -exampleDeps = [ - (ir "Nat",[ii "Gen", ir "Adj"]), - (ir "Adj",[ii "Num", ii "Gen", ir "Nou"]), - (ir "Nou",[ii "Cas"]) - ] - -ii s = IdentM (IC s) MTInterface -ir s = IdentM (IC s) MTResource --} - diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs deleted file mode 100644 index 2c556b36f..000000000 --- a/src/GF/Compile/Optimize.hs +++ /dev/null @@ -1,228 +0,0 @@ -{-# LANGUAGE PatternGuards #-} ----------------------------------------------------------------------- --- | --- 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.Printer -import GF.Grammar.Macros -import GF.Grammar.Lookup -import GF.Grammar.Predef -import GF.Compile.Refresh -import GF.Compile.Concrete.Compute -import GF.Compile.CheckGrammar -import GF.Compile.Update - -import GF.Data.Operations -import GF.Infra.CheckM -import GF.Infra.Option - -import Control.Monad -import Data.List -import qualified Data.Set as Set -import Text.PrettyPrint -import Debug.Trace -import qualified Data.ByteString.Char8 as BS - - --- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005. - -optimizeModule :: Options -> [SourceModule] -> SourceModule -> Err SourceModule -optimizeModule opts ms m@(name,mi) - | mstatus mi == MSComplete = do - ids <- topoSortJments m - mi <- foldM updateEvalInfo mi ids - return (name,mi) - | otherwise = return m - where - oopts = opts `addOptions` flagsModule m - - updateEvalInfo mi (i,info) = do - info' <- evalInfo oopts ms (name,mi) i info - return (updateModule mi i info') - -evalInfo :: Options -> [SourceModule] -> SourceModule -> Ident -> Info -> Err Info -evalInfo opts ms m c info = do - - (if verbAtLeast opts Verbose then trace (" " ++ showIdent c) else id) return () - - errIn ("optimizing " ++ showIdent c) $ case info of - - CncCat ptyp pde ppr -> do - pde' <- case (ptyp,pde) of - (Just typ, Just de) -> do - de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de - return (Just (factor param c 0 de)) - (Just typ, Nothing) -> do - de <- mkLinDefault gr typ - de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de - return (Just (factor param c 0 de)) - _ -> return pde -- indirection - - ppr' <- liftM Just $ evalPrintname gr c ppr (Just $ K $ showIdent c) - - return (CncCat ptyp pde' ppr') - - CncFun (mt@(Just (_,cont,val))) pde ppr -> --trace (prt c) $ - eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do - pde' <- case pde of - Just de -> do de <- partEval opts gr (cont,val) de - return (Just (factor param c 0 de)) - Nothing -> return pde - ppr' <- liftM Just $ evalPrintname gr c ppr pde' - return $ CncFun mt pde' ppr' -- only cat in type actually needed - - ResOper pty pde - | OptExpand `Set.member` optim -> do - pde' <- case pde of - Just de -> do de <- computeConcrete gr de - return (Just (factor param c 0 de)) - Nothing -> return Nothing - return $ ResOper pty pde' - - _ -> return info - where - gr = MGrammar (m : ms) - optim = flag optOptimizations opts - param = OptParametrize `Set.member` optim - eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon)) - --- | the main function for compiling linearizations -partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term -partEval opts gr (context, val) trm = errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $ do - let vars = map (\(bt,x,t) -> x) context - args = map Vr vars - subst = [(v, Vr v) | v <- vars] - trm1 = mkApp trm args - trm2 <- computeTerm gr subst trm1 - trm3 <- if rightType trm2 - then computeTerm gr subst trm2 - else recordExpand val trm2 >>= computeTerm gr subst - return $ mkAbs [(Explicit,v) | v <- vars] trm3 - where - -- don't eta expand records of right length (correct by type checking) - rightType (R rs) = case val of - RecType ts -> length rs == length ts - _ -> False - rightType _ = 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 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 = liftM (Abs Explicit varStr) $ mkDefField typ - where - mkDefField typ = case typ of - Table p t -> do - t' <- mkDefField t - let T _ cs = mkWildCases t' - return $ T (TWild p) cs - Sort s | s == cStr -> return $ Vr varStr - QC q p -> do vs <- lookupParamValues gr q p - case vs of - v:_ -> return v - _ -> Bad (render (text "no parameter values given to type" <+> ppIdent p)) - RecType r -> do - let (ls,ts) = unzip r - ts <- mapM mkDefField ts - return $ R (zipWith assign ls ts) - _ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val - _ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 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 -> Maybe Term -> Maybe Term -> Err Term -evalPrintname gr c ppr lin = - case ppr of - Just pr -> comp pr - Nothing -> case lin of - Just t -> return $ K $ clean $ render (ppTerm Unqualified 0 (oneBranch t)) - Nothing -> return $ K $ showIdent 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 - - --- do even more: factor parametric branches - -factor :: Bool -> Ident -> Int -> Term -> Term -factor param c i t = - case t of - T (TComp ty) cs -> factors ty [(p, factor param c (i+1) v) | (p, v) <- cs] - _ -> composSafeOp (factor param c i) t - where - factors ty pvs0 - | not param = V ty (map snd pvs0) - factors ty [] = V ty [] - factors ty pvs0@[(p,v)] = V ty [v] - factors ty pvs0@(pv:pvs) = - let t = mkFun pv - ts = map mkFun pvs - in if all (==t) ts - then T (TTyped ty) (mkCases t) - else V ty (map snd pvs0) - - --- we hope this will be fresh and don't check... in GFC would be safe - qvar = identC (BS.pack ("q_" ++ showIdent c ++ "__" ++ show i)) - - mkFun (patt, val) = replace (patt2term patt) (Vr qvar) val - mkCases t = [(PV qvar, t)] - --- 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 _ _ | trm == old -> new - R _ | trm == old -> new - App x y -> App (replace old new x) (replace old new y) - _ -> composSafeOp (replace old new) trm diff --git a/src/GF/Compile/OptimizeGFCC.hs b/src/GF/Compile/OptimizeGFCC.hs deleted file mode 100644 index 2a218e1bb..000000000 --- a/src/GF/Compile/OptimizeGFCC.hs +++ /dev/null @@ -1,121 +0,0 @@ -module GF.Compile.OptimizeGFCC where - -import PGF.CId -import PGF.Data -import PGF.Macros - -import GF.Data.Operations - -import Data.List -import qualified Data.Map as Map - - --- back-end optimization: --- suffix analysis followed by common subexpression elimination - -optPGF :: PGF -> PGF -optPGF = cseOptimize . suffixOptimize - -suffixOptimize :: PGF -> PGF -suffixOptimize = mapConcretes opt - where - opt cnc = cnc { - lins = Map.map optTerm (lins cnc), - lindefs = Map.map optTerm (lindefs cnc), - printnames = Map.map optTerm (printnames cnc) - } - -cseOptimize :: PGF -> PGF -cseOptimize = mapConcretes subex - --- 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 = err error id $ 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 = mkCId $ "_" ++ show n - rec field = Map.fromAscList [(f,recomp f trm) | (f,trm) <- Map.assocs (field cnc)] - - -getSubtermsMod :: Concr -> TermM TermList -getSubtermsMod cnc = do - mapM getSubterms (Map.assocs (lins cnc)) - mapM getSubterms (Map.assocs (lindefs cnc)) - mapM getSubterms (Map.assocs (printnames cnc)) - (tree0,_) <- readSTM - return $ Map.filter (\ (nu,_) -> nu > 1) tree0 - where - getSubterms (f,trm) = collectSubterms trm >> return () - -collectSubterms :: Term -> TermM () -collectSubterms t = case t of - R ts -> do - mapM collectSubterms ts - add t - S ts -> do - mapM collectSubterms ts - add t - W s u -> do - collectSubterms u - add t - P p u -> do - collectSubterms p - collectSubterms u - add t - _ -> return () - where - add t = do - (ts,i) <- readSTM - let - ((count,id),next) = case Map.lookup t ts of - Just (nu,id) -> ((nu+1,id), i) - _ -> ((1, i ), i+1) - writeSTM (Map.insert t (count,id) ts, next) - diff --git a/src/GF/Compile/PGFPretty.hs b/src/GF/Compile/PGFPretty.hs deleted file mode 100644 index 679714db5..000000000 --- a/src/GF/Compile/PGFPretty.hs +++ /dev/null @@ -1,93 +0,0 @@ --- | Print a part of a PGF grammar on the human-readable format used in --- the paper "PGF: A Portable Run-Time Format for Type-Theoretical Grammars". -module GF.Compile.PGFPretty (prPGFPretty, prPMCFGPretty) where - -import PGF.CId -import PGF.Data -import PGF.Macros -import PGF.PMCFG - -import GF.Data.Operations - -import Data.Map (Map) -import qualified Data.Map as Map -import Text.PrettyPrint.HughesPJ - - -prPGFPretty :: PGF -> String -prPGFPretty pgf = render $ prAbs (abstract pgf) $$ prAll (prCnc (abstract pgf)) (concretes pgf) - -prPMCFGPretty :: PGF -> CId -> String -prPMCFGPretty pgf lang = render $ - case lookParser pgf lang of - Nothing -> empty - Just pinfo -> text "language" <+> ppCId lang $$ ppPMCFG pinfo - - -prAbs :: Abstr -> Doc -prAbs a = prAll prCat (cats a) $$ prAll prFun (funs a) - -prCat :: CId -> [Hypo] -> Doc -prCat c h | isLiteralCat c = empty - | otherwise = text "cat" <+> ppCId c - -prFun :: CId -> (Type,Int,[Equation]) -> Doc -prFun f (t,_,_) = text "fun" <+> ppCId f <+> text ":" <+> prType t - -prType :: Type -> Doc -prType t = parens (hsep (punctuate (text ",") (map ppCId cs))) <+> text "->" <+> ppCId c - where (cs,c) = catSkeleton t - - --- FIXME: show concrete name --- FIXME: inline opers first -prCnc :: Abstr -> CId -> Concr -> Doc -prCnc abstr name c = prAll prLinCat (lincats c) $$ prAll prLin (lins (expand c)) - where - prLinCat :: CId -> Term -> Doc - prLinCat c t | isLiteralCat c = empty - | otherwise = text "lincat" <+> ppCId c <+> text "=" <+> pr 0 t - where - pr p (R ts) = prec p 1 (hsep (punctuate (text " *") (map (pr 1) ts))) - pr _ (S []) = text "Str" - pr _ (C n) = text "Int_" <> text (show (n+1)) - - prLin :: CId -> Term -> Doc - prLin f t = text "lin" <+> ppCId f <+> text "=" <+> pr 0 t - where - pr :: Int -> Term -> Doc - pr p (R ts) = text "<" <+> hsep (punctuate (text ",") (map (pr 0) ts)) <+> text ">" - pr p (P t1 t2) = prec p 3 (pr 3 t1 <> text "!" <> pr 3 t2) - pr p (S ts) = prec p 2 (hsep (punctuate (text " ++") (map (pr 2) ts))) - pr p (K (KS t)) = doubleQuotes (text t) - pr p (V i) = text ("argv_" ++ show (i+1)) - pr p (C i) = text (show (i+1)) - pr p (FV ts) = prec p 1 (hsep (punctuate (text " |") (map (pr 1) ts))) - pr _ t = error $ "PGFPretty.prLin " ++ show t - -linCat :: Concr -> CId -> Term -linCat cnc c = Map.findWithDefault (error $ "lincat: " ++ showCId c) c (lincats cnc) - -prec :: Int -> Int -> Doc -> Doc -prec p m | p >= m = parens - | otherwise = id - -expand :: Concr -> Concr -expand cnc = cnc { lins = Map.map (f "") (lins cnc) } - where - -- FIXME: handle KP - f :: String -> Term -> Term - f w (R ts) = R (map (f w) ts) - f w (P t1 t2) = P (f w t1) (f w t2) - f w (S []) = S (if null w then [] else [K (KS w)]) - f w (S (t:ts)) = S (f w t : map (f "") ts) - f w (FV ts) = FV (map (f w) ts) - f w (W s t) = f (w++s) t - f w (K (KS t)) = K (KS (w++t)) - f w (F o) = f w (Map.findWithDefault (error $ "Bad oper: " ++ showCId o) o (opers cnc)) - f w t = t - --- Utilities - -prAll :: (a -> b -> Doc) -> Map a b -> Doc -prAll p m = vcat [ p k v | (k,v) <- Map.toList m] \ No newline at end of file diff --git a/src/GF/Compile/ReadFiles.hs b/src/GF/Compile/ReadFiles.hs deleted file mode 100644 index b96d3127b..000000000 --- a/src/GF/Compile/ReadFiles.hs +++ /dev/null @@ -1,220 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ReadFiles --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:34 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.26 $ --- --- Decide what files to read as function of dependencies and time stamps. --- --- make analysis for GF grammar modules. AR 11\/6\/2003--24\/2\/2004 --- --- to find all files that have to be read, put them in dependency order, and --- decide which files need recompilation. Name @file.gf@ is returned for them, --- and @file.gfo@ otherwise. ------------------------------------------------------------------------------ - -module GF.Compile.ReadFiles - ( getAllFiles,ModName,ModEnv,importsOfModule, - gfoFile,gfFile,isGFO,gf2gfo, - getOptionsFromFile) where - -import GF.Infra.UseIO -import GF.Infra.Option -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Data.Operations -import GF.Grammar.Lexer -import GF.Grammar.Parser -import GF.Grammar.Grammar -import GF.Grammar.Binary - -import Control.Monad -import Data.Char -import Data.List -import Data.Maybe(isJust) -import qualified Data.ByteString.Char8 as BS -import qualified Data.Map as Map -import System.Time -import System.Directory -import System.FilePath -import Text.PrettyPrint - -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) - ioeIO $ putIfVerb opts $ "all modules:" +++ show [name | (name,_,_,_,_) <- ds] - return $ paths ds - where - -- construct list of paths to read - paths ds = concatMap mkFile ds - where - mkFile (f,st,gfTime,gfoTime,p) = - case st of - CSComp -> [p gfFile f] - CSRead | isJust gfTime -> [gf2gfo opts (p gfFile f)] - | otherwise -> [p gfoFile f] - CSEnv -> [] - - -- | 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,_,t1,_,_) <- ds, elem f imps && liftM2 (>=) t0 t1 /= Just True] - = (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 $ getFilePath ps (gfFile name) - case mb_gfFile of - Just gfFile -> do gfTime <- ioeIO $ getModificationTime gfFile - mb_gfoTime <- ioeIO $ catch (liftM Just $ getModificationTime (gf2gfo opts gfFile)) - (\_->return Nothing) - return (gfFile, Just gfTime, mb_gfoTime) - Nothing -> do mb_gfoFile <- ioeIO $ getFilePath (maybe id (:) (flag optGFODir opts) ps) (gfoFile name) - case mb_gfoFile of - Just gfoFile -> do gfoTime <- ioeIO $ getModificationTime gfoFile - return (gfoFile, Nothing, Just gfoTime) - Nothing -> ioeErr $ Bad (render (text "File" <+> text (gfFile name) <+> text "does not exist." $$ - text "searched in:" <+> vcat (map text ps))) - - - let mb_envmod = Map.lookup name env - (st,t) = selectFormat opts (fmap fst mb_envmod) gfTime gfoTime - - (mname,imps) <- case st of - CSEnv -> return (name, maybe [] snd mb_envmod) - CSRead -> ioeIO $ fmap importsOfModule (decodeModHeader ((if isGFO file then id else gf2gfo opts) file)) - CSComp -> do s <- ioeIO $ BS.readFile file - case runP pModHeader s of - Left (Pn l c,msg) -> ioeBad (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg) - Right mo -> return (importsOfModule mo) - ioeErr $ testErr (mname == name) - ("module name" +++ mname +++ "differs from file name" +++ name) - 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" - -gf2gfo :: Options -> FilePath -> FilePath -gf2gfo opts file = maybe (gfoFile (dropExtension file)) - (\dir -> dir gfoFile (dropExtension (takeFileName file))) - (flag optGFODir opts) - --- 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 - (_,Just tgfo,Nothing) -> (CSRead,Just tgfo) -- source does not exist - _ -> (CSComp,Nothing) - where - fromComp = flag optRecomp opts == NeverRecomp - fromSrc = flag optRecomp opts == AlwaysRecomp - - --- 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 :: SourceModule -> (ModName,[ModName]) -importsOfModule (m,mi) = (modName m,depModInfo mi []) - where - depModInfo mi = - depModType (mtype mi) . - depExtends (extend mi) . - depWith (mwith mi) . - depExDeps (mexdeps mi). - depOpens (opens mi) - - depModType (MTAbstract) xs = xs - depModType (MTResource) xs = xs - depModType (MTInterface) xs = xs - depModType (MTConcrete m2) xs = modName m2:xs - depModType (MTInstance m2) xs = modName m2:xs - - depExtends es xs = foldr depInclude xs es - - depWith (Just (m,_,is)) xs = modName m : depInsts is xs - depWith Nothing xs = xs - - depExDeps eds xs = map modName eds ++ xs - - depOpens os xs = foldr depOpen xs os - - depInsts is xs = foldr depInst xs is - - depInclude (m,_) xs = modName m:xs - - depOpen (OSimple n ) xs = modName n:xs - depOpen (OQualif _ n) xs = modName n:xs - - depInst (m,n) xs = modName m:modName n:xs - - modName = showIdent - --- | options can be passed to the compiler by comments in @--#@, in the main file -getOptionsFromFile :: FilePath -> IOE Options -getOptionsFromFile file = do - s <- ioe $ catch (fmap Ok $ BS.readFile file) - (\_ -> return (Bad $ "File " ++ file ++ " does not exist")) - let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s - fs = map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls - ioeErr $ parseModuleOptions fs - -getFilePath :: [FilePath] -> String -> IO (Maybe FilePath) -getFilePath paths file = get paths - where - get [] = 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) diff --git a/src/GF/Compile/Refresh.hs b/src/GF/Compile/Refresh.hs deleted file mode 100644 index 04800fcce..000000000 --- a/src/GF/Compile/Refresh.hs +++ /dev/null @@ -1,133 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Refresh --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:27 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Compile.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 b x t -> liftM2 (Abs b) (refVarPlus x) (refresh t) - - Prod b x a t -> do - a' <- refresh a - x' <- refVar x - t' <- refresh t - return $ Prod b x' a' t' - - 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,mo) - | isModCnc mo || isModRes mo = do - (k',js') <- foldM refreshRes (k,[]) $ tree2list $ jments mo - return (k', (i, replaceJudgements mo (buildTree js')) : ms) - | otherwise = return (k, mi:ms) - where - refreshRes (k,cs) ci@(c,info) = case info of - ResOper ptyp (Just trm) -> do ---- refresh ptyp - (k',trm') <- refreshTermKN k trm - return $ (k', (c, ResOper ptyp (Just trm')):cs) - ResOverload os tyts -> do - (k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $ - appSTM (mapPairsM refresh tyts) (initIdStateN k) - return $ (k', (c, ResOverload os tyts'):cs) - CncCat mt (Just trm) pn -> do ---- refresh mt, pn - (k',trm') <- refreshTermKN k trm - return $ (k', (c, CncCat mt (Just trm') pn):cs) - CncFun mt (Just trm) pn -> do ---- refresh pn - (k',trm') <- refreshTermKN k trm - return $ (k', (c, CncFun mt (Just trm') pn):cs) - _ -> return (k, ci:cs) - diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs deleted file mode 100644 index 30616b4cb..000000000 --- a/src/GF/Compile/Rename.hs +++ /dev/null @@ -1,313 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Rename --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/30 18:39:44 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.19 $ --- --- AR 14\/5\/2003 --- The top-level function 'renameGrammar' does several things: --- --- - extends each module symbol table by indirections to extended module --- --- - changes unqualified and as-qualified imports to absolutely qualified --- --- - goes through the definitions and resolves names --- --- Dependency analysis between modules has been performed before this pass. --- Hence we can proceed by @fold@ing "from left to right". ------------------------------------------------------------------------------ - -module GF.Compile.Rename ( - renameSourceTerm, - renameModule - ) where - -import GF.Grammar.Grammar -import GF.Grammar.Values -import GF.Grammar.Predef -import GF.Infra.Modules -import GF.Infra.Ident -import GF.Infra.CheckM -import GF.Grammar.Macros -import GF.Grammar.Printer -import GF.Grammar.Lookup -import GF.Grammar.Printer -import GF.Data.Operations - -import Control.Monad -import Data.List (nub) -import Text.PrettyPrint - --- | this gives top-level access to renaming term input in the cc command -renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term -renameSourceTerm g m t = do - mo <- checkErr $ lookupModule g m - status <- buildStatus g m mo - renameTerm status [] t - -renameModule :: [SourceModule] -> SourceModule -> Check SourceModule -renameModule ms (name,mo) = checkIn (text "renaming module" <+> ppIdent name) $ do - let js1 = jments mo - status <- buildStatus (MGrammar ms) name mo - js2 <- checkMap (renameInfo mo status) js1 - return (name, mo {opens = map forceQualif (opens mo), jments = js2}) - -type Status = (StatusTree, [(OpenSpec Ident, StatusTree)]) - -type StatusTree = BinTree Ident StatusInfo - -type StatusInfo = Ident -> Term - -renameIdentTerm :: Status -> Term -> Check Term -renameIdentTerm env@(act,imps) t = - checkIn (text "atomic term" <+> ppTerm Qualified 0 t $$ text "given" <+> hsep (punctuate comma (map (ppIdent . fst) qualifs))) $ - case t of - Vr c -> ident predefAbs c - Cn c -> ident (\_ s -> checkError s) c - Q m' c | m' == cPredef {- && isInPredefined c -} -> return t - Q m' c -> do - m <- checkErr (lookupErr m' qualifs) - f <- lookupTree showIdent c m - return $ f c - QC m' c | m' == cPredef {- && isInPredefined c -} -> return t - QC m' c -> do - m <- checkErr (lookupErr m' qualifs) - f <- lookupTree showIdent 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 - | isPredefCat c = return $ Q cPredefAbs c - | otherwise = checkError s - - ident alt c = case lookupTree showIdent c act of - Ok f -> return $ f c - _ -> case lookupTreeManyAll showIdent opens c of - [f] -> return $ f c - [] -> alt c (text "constant not found:" <+> ppIdent c) - fs -> case nub [f c | f <- fs] of - [tr] -> return tr - ts@(t:_) -> do checkWarn (text "conflict" <+> hsep (punctuate comma (map (ppTerm Qualified 0) ts))) - return t - -- a warning will be generated in CheckGrammar, and the head returned - -- in next V: - -- Bad $ "conflicting imports:" +++ unwords (map prt ts) - -info2status :: Maybe Ident -> (Ident,Info) -> StatusInfo -info2status mq (c,i) = case i of - AbsFun _ _ Nothing -> 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 -> Check Status -buildStatus gr c mo = let mo' = self2status c mo in do - let gr1 = MGrammar ((c,mo) : modules gr) - ops = [OSimple e | e <- allExtends gr1 c] ++ opens mo - mods <- checkErr $ mapM (lookupModule gr1 . openedModule) ops - let sts = map modInfo2status $ zip ops mods - return $ if isModCnc mo - 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,mo) = (o,tree2status o (jments mo)) - -self2status :: Ident -> SourceModInfo -> StatusTree -self2status c m = mapTree (info2status (Just c)) (jments m) - -forceQualif o = case o of - OSimple i -> OQualif i i - OQualif _ i -> OQualif i i - -renameInfo :: SourceModInfo -> Status -> Ident -> Info -> Check Info -renameInfo mo status i info = checkIn - (text "renaming definition of" <+> ppIdent i <+> ppPosition mo i) $ - case info of - AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco) - (renPerh (mapM rent) pfs) - AbsFun pty pa ptr -> liftM3 AbsFun (ren pty) (return pa) (renPerh (mapM (renameEquation status [])) ptr) - ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr) - ResOverload os tysts -> - liftM (ResOverload os) (mapM (pairM rent) tysts) - - ResParam (Just pp) m -> do - pp' <- mapM (renameParam status) pp - return (ResParam (Just pp') m) - ResValue t -> do - t <- rent t - return (ResValue 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 (Just t) = liftM Just $ ren t -renPerh ren Nothing = return Nothing - -renameTerm :: Status -> [Ident] -> Term -> Check Term -renameTerm env vars = ren vars where - ren vs trm = case trm of - Abs b x t -> liftM (Abs b x) (ren (x:vs) t) - Prod bt x a b -> liftM2 (Prod bt 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 - 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 -- Here we have $r.l$ and this is ambiguous it could be either - -- record projection from variable or constant $r$ or qualified expression with module $r$ - | elem r vs -> return trm -- try var proj first .. - | otherwise -> checks [ renid (Q r (label2ident l)) -- .. and qualified expression second. - , renid t >>= \t -> return (P t l) -- try as a constant at the end - , checkError (text "unknown qualified constant" <+> ppTerm Unqualified 0 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 -> Check (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 - _ -> checkError (text "unresolved pattern" <+> ppPatt Unqualified 0 patt) - - PC c ps -> do - c' <- renid $ Cn c - case c' of - QC m c -> do psvss <- mapM renp ps - let (ps,vs) = unzip psvss - return (PP m c ps, concat vs) - Q _ _ -> checkError (text "data constructor expected but" <+> ppTerm Qualified 0 c' <+> text "is found instead") - _ -> checkError (text "unresolved data constructor" <+> ppTerm Qualified 0 c') - - PP p c ps -> do - (QC p' c') <- renid (QC p c) - psvss <- mapM renp ps - let (ps',vs) = unzip psvss - return (PP p' c' ps', concat vs) - - PM p c -> do - x <- renid (Q p c) - (p',c') <- case x of - (Q p' c') -> return (p',c') - _ -> checkError (text "not a pattern macro" <+> ppPatt Qualified 0 patt) - return (PM p' c', []) - - PV x -> checks [ renid (Vr x) >>= \t' -> case t' of - QC m c -> return (PP m c [],[]) - _ -> checkError (text "not a constructor") - , 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) -> Check (Ident, Context) -renameParam env (c,co) = do - co' <- renameContext env co - return (c,co') - -renameContext :: Status -> Context -> Check Context -renameContext b = renc [] where - renc vs cont = case cont of - (bt,x,t) : xts - | isWildIdent x -> do - t' <- ren vs t - xts' <- renc vs xts - return $ (bt,x,t') : xts' - | otherwise -> do - t' <- ren vs t - let vs' = x:vs - xts' <- renc vs' xts - return $ (bt,x,t') : xts' - _ -> return cont - ren = renameTerm b - --- | vars not needed in env, since patterns always overshadow old vars -renameEquation :: Status -> [Ident] -> Equation -> Check Equation -renameEquation b vs (ps,t) = do - (ps',vs') <- liftM unzip $ mapM (renamePattern b) ps - t' <- renameTerm b (concat vs' ++ vs) t - return (ps',t') diff --git a/src/GF/Compile/SubExOpt.hs b/src/GF/Compile/SubExOpt.hs deleted file mode 100644 index c7dbb5d3d..000000000 --- a/src/GF/Compile/SubExOpt.hs +++ /dev/null @@ -1,142 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : SubExOpt --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- This module implements a simple common subexpression elimination --- for .gfo 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 --- ------------------------------------------------------------------------------ - -module GF.Compile.SubExOpt (subexpModule,unsubexpModule) where - -import GF.Grammar.Grammar -import GF.Grammar.Lookup -import GF.Infra.Ident -import qualified GF.Grammar.Macros as C -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 qualified Data.ByteString.Char8 as BS -import Data.List - -subexpModule :: SourceModule -> SourceModule -subexpModule (n,mo) = errVal (n,mo) $ do - let ljs = tree2list (M.jments mo) - (tree,_) <- appSTM (getSubtermsMod n ljs) (Map.empty,0) - js2 <- liftM buildTree $ addSubexpConsts n tree $ ljs - return (n,M.replaceJudgements mo js2) - -unsubexpModule :: SourceModule -> SourceModule -unsubexpModule sm@(i,mo) - | hasSub ljs = (i,M.replaceJudgements mo (rebuild (map unparInfo ljs))) - | otherwise = sm - where - ljs = tree2list (M.jments mo) - - -- perform this iff the module has opers - hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs] - unparInfo (c,info) = case info of - CncFun xs (Just t) m -> [(c, CncFun xs (Just (unparTerm t)) m)] - ResOper (Just (EInt 8)) _ -> [] -- subexp-generated opers - ResOper pty (Just t) -> [(c, ResOper pty (Just (unparTerm t)))] - _ -> [(c,info)] - unparTerm t = case t of - Q m c | isOperIdent c -> --- name convention of subexp opers - errVal t $ liftM unparTerm $ lookupResDef gr m c - _ -> C.composSafeOp unparTerm t - gr = M.MGrammar [sm] - 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 (Just trm) pn -> do - trm' <- recomp f trm - return (f,CncFun xs (Just trm') pn) - ResOper ty (Just trm) -> do - trm' <- recomp f trm - return (f,ResOper ty (Just trm')) - _ -> return (f,def) - recomp f t = case Map.lookup t tree of - Just (_,id) | operIdent id /= f -> return $ Q mo (operIdent id) - _ -> C.composOp (recomp f) t - - list = Map.toList tree - - oper id trm = (operIdent id, ResOper (Just (EInt 8)) (Just 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 (Just trm) pn -> do - get trm - return $ fi - ResOper ty (Just 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 - -operIdent :: Int -> Ident -operIdent i = identC (operPrefix `BS.append` (BS.pack (show i))) --- - -isOperIdent :: Ident -> Bool -isOperIdent id = BS.isPrefixOf operPrefix (ident2bs id) - -operPrefix = BS.pack ("A''") diff --git a/src/GF/Compile/Update.hs b/src/GF/Compile/Update.hs deleted file mode 100644 index 1e39a2e03..000000000 --- a/src/GF/Compile/Update.hs +++ /dev/null @@ -1,226 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Update --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/30 18:39:44 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.8 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Compile.Update (buildAnyTree, extendModule, rebuildModule) where - -import GF.Infra.Ident -import GF.Grammar.Grammar -import GF.Grammar.Printer -import GF.Grammar.Lookup -import GF.Infra.Modules -import GF.Infra.Option - -import GF.Data.Operations - -import Data.List -import qualified Data.Map as Map -import Control.Monad -import Text.PrettyPrint - --- | combine a list of definitions into a balanced binary search tree -buildAnyTree :: Ident -> [(Ident,Info)] -> Err (BinTree Ident Info) -buildAnyTree m = go Map.empty - where - go map [] = return map - go map ((c,j):is) = do - case Map.lookup c map of - Just i -> case unifyAnyInfo m i j of - Ok k -> go (Map.insert c k map) is - Bad _ -> fail $ render (text "cannot unify the informations" $$ - nest 4 (ppJudgement Qualified (c,i)) $$ - text "and" $+$ - nest 4 (ppJudgement Qualified (c,j)) $$ - text "in module" <+> ppIdent m) - Nothing -> go (Map.insert c j map) is - -extendModule :: SourceGrammar -> SourceModule -> Err SourceModule -extendModule gr (name,m) - ---- 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 - | mstatus m == MSIncomplete && isModCnc m = return (name,m) - | otherwise = do m' <- foldM extOne m (extend m) - return (name,m') - where - extOne mo (n,cond) = do - m0 <- lookupModule gr n - - -- test that the module types match, and find out if the old is complete - testErr (sameMType (mtype m) (mtype mo)) - ("illegal extension type to module" +++ showIdent name) - - let isCompl = isCompleteModule m0 - - -- build extension in a way depending on whether the old module is complete - js1 <- extendMod gr isCompl (n, isInherited cond) name (jments m0) (jments mo) - - -- if incomplete, throw away extension information - return $ - if isCompl - then mo {jments = js1} - else mo {extend = filter ((/=n) . fst) (extend mo) - ,mexdeps= nub (n : mexdeps mo) - ,jments = js1 - } - --- | rebuilding instance + interface, and "with" modules, prior to renaming. --- AR 24/10/2003 -rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule -rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do ----- 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 mw of - - -- add the information given in interface into an instance module - Nothing -> do - testErr (null is || mstatus mi == MSIncomplete) - ("module" +++ showIdent i +++ - "has open interfaces and must therefore be declared incomplete") - case mt of - MTInstance i0 -> do - m1 <- lookupModule gr i0 - testErr (isModRes m1) ("interface expected instead of" +++ showIdent i0) - js' <- extendMod gr False (i0,const True) i (jments m1) (jments mi) - --- to avoid double inclusions, in instance I of I0 = J0 ** ... - case extends mi of - [] -> return $ replaceJudgements mi js' - j0s -> do - m0s <- mapM (lookupModule gr) j0s - let notInM0 c _ = all (not . isInBinTree c . jments) m0s - let js2 = filterBinTree notInM0 js' - return $ (replaceJudgements mi js2) - {positions = Map.union (positions m1) (positions mi)} - _ -> return mi - - -- add the instance opens to an incomplete module "with" instances - Just (ext,incl,ops) -> do - let (infs,insts) = unzip ops - let stat' = ifNull MSComplete (const MSIncomplete) - [i | i <- is, notElem i infs] - testErr (stat' == MSComplete || stat == MSIncomplete) - ("module" +++ showIdent i +++ "remains incomplete") - ModInfo mt0 _ fs me' _ ops0 _ js ps0 <- lookupModule gr ext - let ops1 = nub $ - ops_ ++ -- N.B. js has been name-resolved already - [OQualif i j | (i,j) <- ops] ++ - [o | o <- ops0, notElem (openedModule o) infs] ++ - [OQualif i i | i <- insts] ++ - [OSimple i | i <- insts] - - --- check if me is incomplete - let fs1 = fs `addOptions` fs_ -- new flags have priority - let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c] - let js1 = buildTree (tree2list js_ ++ js0) - let ps1 = Map.union ps_ ps0 - let med1= nub (ext : infs ++ insts ++ med_) - return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 js1 ps1 - - return (i,mi') - --- | 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 :: SourceGrammar -> - Bool -> (Ident,Ident -> Bool) -> Ident -> - BinTree Ident Info -> BinTree Ident Info -> - Err (BinTree Ident Info) -extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old - where - try new (c,i) - | not (cond c) = return new - | otherwise = case Map.lookup c new of - Just j -> case unifyAnyInfo name i j of - Ok k -> return $ updateTree (c,k) new - Bad _ -> do (base,j) <- case j of - AnyInd _ m -> lookupOrigInfo gr m c - _ -> return (base,j) - (name,i) <- case i of - AnyInd _ m -> lookupOrigInfo gr m c - _ -> return (name,i) - fail $ render (text "cannot unify the information" $$ - nest 4 (ppJudgement Qualified (c,i)) $$ - text "in module" <+> ppIdent name <+> text "with" $$ - nest 4 (ppJudgement Qualified (c,j)) $$ - text "in module" <+> ppIdent base) - Nothing-> if isCompl - then return $ updateTree (c,indirInfo name i) new - else return $ updateTree (c,i) new - - indirInfo :: Ident -> Info -> Info - indirInfo n info = AnyInd b n' where - (b,n') = case info of - ResValue _ -> (True,n) - ResParam _ _ -> (True,n) - AbsFun _ _ Nothing -> (True,n) - AnyInd b k -> (b,k) - _ -> (False,n) ---- canonical in Abs - -unifyAnyInfo :: Ident -> Info -> Info -> Err Info -unifyAnyInfo m i j = case (i,j) of - (AbsCat mc1 mf1, AbsCat mc2 mf2) -> - liftM2 AbsCat (unifMaybe mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs - (AbsFun mt1 ma1 md1, AbsFun mt2 ma2 md2) -> - liftM3 AbsFun (unifMaybe mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) -- adding defs - - (ResParam mt1 mv1, ResParam mt2 mv2) -> - liftM2 ResParam (unifMaybe mt1 mt2) (unifMaybe mv1 mv2) - (ResValue t1, ResValue t2) - | t1==t2 -> return (ResValue t1) - | otherwise -> fail "" - (_, ResOverload ms t) | elem m ms -> - return $ ResOverload ms t - (ResOper mt1 m1, ResOper mt2 m2) -> - liftM2 ResOper (unifMaybe mt1 mt2) (unifMaybe m1 m2) - - (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> - liftM3 CncCat (unifMaybe mc1 mc2) (unifMaybe mf1 mf2) (unifMaybe mp1 mp2) - (CncFun m mt1 md1, CncFun _ mt2 md2) -> - liftM2 (CncFun m) (unifMaybe mt1 mt2) (unifMaybe md1 md2) ---- adding defs - - (AnyInd b1 m1, AnyInd b2 m2) -> do - testErr (b1 == b2) $ "indirection status" - testErr (m1 == m2) $ "different sources of indirection" - return i - - _ -> fail "informations" - --- | this is what happens when matching two values in the same module -unifMaybe :: Eq a => Maybe a -> Maybe a -> Err (Maybe a) -unifMaybe Nothing Nothing = return Nothing -unifMaybe (Just p1) Nothing = return (Just p1) -unifMaybe Nothing (Just p2) = return (Just p2) -unifMaybe (Just p1) (Just p2) - | p1==p2 = return (Just p1) - | otherwise = fail "" - -unifAbsArrity :: Maybe Int -> Maybe Int -> Err (Maybe Int) -unifAbsArrity Nothing Nothing = return Nothing -unifAbsArrity (Just a ) Nothing = return (Just a ) -unifAbsArrity Nothing (Just a ) = return (Just a ) -unifAbsArrity (Just a1) (Just a2) - | a1==a2 = return (Just a1) - | otherwise = fail "" - -unifAbsDefs :: Maybe [Equation] -> Maybe [Equation] -> Err (Maybe [Equation]) -unifAbsDefs Nothing Nothing = return Nothing -unifAbsDefs (Just _ ) Nothing = fail "" -unifAbsDefs Nothing (Just _ ) = fail "" -unifAbsDefs (Just xs) (Just ys) = return (Just (xs ++ ys)) - -unifConstrs :: Maybe [Term] -> Maybe [Term] -> Err (Maybe [Term]) -unifConstrs p1 p2 = case (p1,p2) of - (Nothing, _) -> return p2 - (_, Nothing) -> return p1 - (Just bs, Just ds) -> return $ Just $ bs ++ ds diff --git a/src/GF/Data/Assoc.hs b/src/GF/Data/Assoc.hs deleted file mode 100644 index f775319ea..000000000 --- a/src/GF/Data/Assoc.hs +++ /dev/null @@ -1,143 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Assoc --- Maintainer : Peter Ljunglöf --- Stability : Stable --- Portability : Haskell 98 --- --- > CVS $Date: 2005/05/09 09:28:44 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.4 $ --- --- Association lists, or finite maps, --- including sets as maps with result type @()@. --- function names stolen from module @Array@. --- /O(log n)/ key lookup ------------------------------------------------------------------------------ - -module GF.Data.Assoc ( Assoc, - Set, - emptyAssoc, - emptySet, - listAssoc, - listSet, - accumAssoc, - aAssocs, - aElems, - assocMap, - assocFilter, - lookupAssoc, - lookupWith, - (?), - (?=) - ) where - -import GF.Data.SortedList - -infixl 9 ?, ?= - --- | a set is a finite map with empty values -type Set a = Assoc a () - -emptyAssoc :: Ord a => Assoc a b -emptySet :: Ord a => Set a - --- | creating a finite map from a sorted key-value list -listAssoc :: Ord a => SList (a, b) -> Assoc a b - --- | creating a set from a sorted list -listSet :: Ord a => SList a -> Set a - --- | building a finite map from a list of keys and 'b's, --- and a function that combines a sorted list of 'b's into a value -accumAssoc :: (Ord a, Ord c) => (SList c -> b) -> [(a, c)] -> Assoc a b - --- | all key-value pairs from an association list -aAssocs :: Ord a => Assoc a b -> SList (a, b) - --- | all keys from an association list -aElems :: Ord a => Assoc a b -> SList a - --- fmap :: Ord a => (b -> b') -> Assoc a b -> Assoc a b' - --- | mapping values to other values. --- the mapping function can take the key as information -assocMap :: Ord a => (a -> b -> b') -> Assoc a b -> Assoc a b' - -assocFilter :: Ord a => (b -> Bool) -> Assoc a b -> Assoc a b -assocFilter pred = listAssoc . filter (pred . snd) . aAssocs - --- | monadic lookup function, --- returning failure if the key does not exist -lookupAssoc :: (Ord a, Monad m) => Assoc a b -> a -> m b - --- | if the key does not exist, --- the first argument is returned -lookupWith :: Ord a => b -> Assoc a b -> a -> b - --- | if the values are monadic, we can return the value type -(?) :: (Ord a, Monad m) => Assoc a (m b) -> a -> m b - --- | checking wheter the map contains a given key -(?=) :: Ord a => Assoc a b -> a -> Bool - - ------------------------------------------------------------- - -data Assoc a b = ANil | ANode (Assoc a b) a b (Assoc a b) - deriving (Eq, Ord, Show) - -emptyAssoc = ANil -emptySet = emptyAssoc - -listAssoc as = assoc - where (assoc, []) = sl2bst (length as) as - sl2bst 0 xs = (ANil, xs) - sl2bst 1 (x:xs) = (ANode ANil (fst x) (snd x) ANil, xs) - sl2bst n xs = (ANode left (fst x) (snd x) right, zs) - where llen = (n-1) `div` 2 - rlen = n - 1 - llen - (left, x:ys) = sl2bst llen xs - (right, zs) = sl2bst rlen ys - -listSet as = listAssoc (zip as (repeat ())) - -accumAssoc join = listAssoc . map (mapSnd join) . groupPairs . nubsort - where mapSnd f (a, b) = (a, f b) - -aAssocs as = prs as [] - where prs ANil = id - prs (ANode left a b right) = prs left . ((a,b) :) . prs right - -aElems = map fst . aAssocs - - -instance Ord a => Functor (Assoc a) where - fmap f = assocMap (const f) - -assocMap f ANil = ANil -assocMap f (ANode left a b right) = ANode (assocMap f left) a (f a b) (assocMap f right) - - -lookupAssoc ANil _ = fail "key not found" -lookupAssoc (ANode left a b right) a' = case compare a a' of - GT -> lookupAssoc left a' - LT -> lookupAssoc right a' - EQ -> return b - -lookupWith z ANil _ = z -lookupWith z (ANode left a b right) a' = case compare a a' of - GT -> lookupWith z left a' - LT -> lookupWith z right a' - EQ -> b - -(?) = lookupWith (fail "key not found") - -(?=) = \assoc -> maybe False (const True) . lookupAssoc assoc - - - - - - - diff --git a/src/GF/Data/BacktrackM.hs b/src/GF/Data/BacktrackM.hs deleted file mode 100644 index 36317ebb6..000000000 --- a/src/GF/Data/BacktrackM.hs +++ /dev/null @@ -1,86 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : BacktrackM --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:00 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- Backtracking state monad, with r\/o environment ------------------------------------------------------------------------------ - -{-# OPTIONS_GHC -fglasgow-exts #-} -module GF.Data.BacktrackM ( - -- * the backtracking state monad - BacktrackM, - -- * monad specific utilities - member, - cut, - -- * running the monad - foldBM, runBM, - foldSolutions, solutions, - foldFinalStates, finalStates, - - -- * reexport the 'MonadState' class - module Control.Monad.State.Class, - ) where - -import Data.List -import Control.Monad -import Control.Monad.State.Class - ----------------------------------------------------------------------- --- 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 - -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 _ = mzero - -instance Functor (BacktrackM s) where - fmap f (BM m) = BM (\c s b -> m (\a s b -> c (f a) s b) s b) - -instance MonadPlus (BacktrackM s) where - mzero = BM (\c s b -> b) - (BM f) `mplus` (BM g) = BM (\c s b -> g c s $! f c s b) - -instance MonadState s (BacktrackM s) where - get = BM (\c s b -> c s s b) - put s = BM (\c _ b -> c () s b) - --- * 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) - -cut :: BacktrackM s a -> BacktrackM s [(s,a)] -cut f = BM (\c s b -> c (runBM f s) s b) diff --git a/src/GF/Data/ErrM.hs b/src/GF/Data/ErrM.hs deleted file mode 100644 index e8cea12d4..000000000 --- a/src/GF/Data/ErrM.hs +++ /dev/null @@ -1,38 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ErrM --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:00 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- hack for BNFC generated files. AR 21/9/2003 ------------------------------------------------------------------------------ - -module GF.Data.ErrM (Err(..)) where - -import Control.Monad (MonadPlus(..)) - --- | like @Maybe@ type with error msgs -data Err a = Ok a | Bad String - deriving (Read, Show, Eq) - -instance Monad Err where - return = Ok - fail = Bad - Ok a >>= f = f a - Bad s >>= f = Bad s - --- | added 2\/10\/2003 by PEB -instance Functor Err where - fmap f (Ok a) = Ok (f a) - fmap f (Bad s) = Bad s - --- | added by KJ -instance MonadPlus Err where - mzero = Bad "error (no reason given)" - mplus (Ok a) _ = Ok a - mplus (Bad s) b = b diff --git a/src/GF/Data/Graph.hs b/src/GF/Data/Graph.hs deleted file mode 100644 index bfb289860..000000000 --- a/src/GF/Data/Graph.hs +++ /dev/null @@ -1,178 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Graph --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/10 16:43:44 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- A simple graph module. ------------------------------------------------------------------------------ -module GF.Data.Graph ( Graph(..), Node, Edge, NodeInfo - , newGraph, nodes, edges - , nmap, emap, newNode, newNodes, newEdge, newEdges - , insertEdgeWith - , removeNode, removeNodes - , nodeInfo - , getIncoming, getOutgoing, getNodeLabel - , inDegree, outDegree - , nodeLabel - , edgeFrom, edgeTo, edgeLabel - , reverseGraph, mergeGraphs, renameNodes - ) where - -import GF.Data.Utilities - -import Data.List -import Data.Maybe -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set - -data Graph n a b = Graph [n] ![Node n a] ![Edge n b] - deriving (Eq,Show) - -type Node n a = (n,a) -type Edge n b = (n,n,b) - -type NodeInfo n a b = Map n (a, [Edge n b], [Edge n b]) - --- | Create a new empty graph. -newGraph :: [n] -> Graph n a b -newGraph ns = Graph ns [] [] - --- | Get all the nodes in the graph. -nodes :: Graph n a b -> [Node n a] -nodes (Graph _ ns _) = ns - --- | Get all the edges in the graph. -edges :: Graph n a b -> [Edge n b] -edges (Graph _ _ es) = es - --- | Map a function over the node labels. -nmap :: (a -> c) -> Graph n a b -> Graph n c b -nmap f (Graph c ns es) = Graph c [(n,f l) | (n,l) <- ns] es - --- | Map a function over the edge labels. -emap :: (b -> c) -> Graph n a b -> Graph n a c -emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es] - --- | Add a node to the graph. -newNode :: a -- ^ Node label - -> Graph n a b - -> (Graph n a b,n) -- ^ Node graph and name of new node -newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c) - -newNodes :: [a] -> Graph n a b -> (Graph n a b,[Node n a]) -newNodes ls g = (g', zip ns ls) - where (g',ns) = mapAccumL (flip newNode) g ls --- lazy version: ---newNodes ls (Graph cs ns es) = (Graph cs' (ns'++ns) es, ns') --- where (xs,cs') = splitAt (length ls) cs --- ns' = zip xs ls - -newEdge :: Edge n b -> Graph n a b -> Graph n a b -newEdge e (Graph c ns es) = Graph c ns (e:es) - -newEdges :: [Edge n b] -> Graph n a b -> Graph n a b -newEdges es g = foldl' (flip newEdge) g es --- lazy version: --- newEdges es' (Graph c ns es) = Graph c ns (es'++es) - -insertEdgeWith :: Eq n => - (b -> b -> b) -> Edge n b -> Graph n a b -> Graph n a b -insertEdgeWith f e@(x,y,l) (Graph c ns es) = Graph c ns (h es) - where h [] = [e] - h (e'@(x',y',l'):es') | x' == x && y' == y = (x',y', f l l'):es' - | otherwise = e':h es' - --- | Remove a node and all edges to and from that node. -removeNode :: Ord n => n -> Graph n a b -> Graph n a b -removeNode n = removeNodes (Set.singleton n) - --- | Remove a set of nodes and all edges to and from those nodes. -removeNodes :: Ord n => Set n -> Graph n a b -> Graph n a b -removeNodes xs (Graph c ns es) = Graph c ns' es' - where - keepNode n = not (Set.member n xs) - ns' = [ x | x@(n,_) <- ns, keepNode n ] - es' = [ e | e@(f,t,_) <- es, keepNode f && keepNode t ] - --- | Get a map of node names to info about each node. -nodeInfo :: Ord n => Graph n a b -> NodeInfo n a b -nodeInfo g = Map.fromList [ (n, (x, fn inc n, fn out n)) | (n,x) <- nodes g ] - where - inc = groupEdgesBy edgeTo g - out = groupEdgesBy edgeFrom g - fn m n = fromMaybe [] (Map.lookup n m) - -groupEdgesBy :: (Ord n) => (Edge n b -> n) -- ^ Gets the node to group by - -> Graph n a b -> Map n [Edge n b] -groupEdgesBy f g = Map.fromListWith (++) [(f e, [e]) | e <- edges g] - -lookupNode :: Ord n => NodeInfo n a b -> n -> (a, [Edge n b], [Edge n b]) -lookupNode i n = fromJust $ Map.lookup n i - -getIncoming :: Ord n => NodeInfo n a b -> n -> [Edge n b] -getIncoming i n = let (_,inc,_) = lookupNode i n in inc - -getOutgoing :: Ord n => NodeInfo n a b -> n -> [Edge n b] -getOutgoing i n = let (_,_,out) = lookupNode i n in out - -inDegree :: Ord n => NodeInfo n a b -> n -> Int -inDegree i n = length $ getIncoming i n - -outDegree :: Ord n => NodeInfo n a b -> n -> Int -outDegree i n = length $ getOutgoing i n - -getNodeLabel :: Ord n => NodeInfo n a b -> n -> a -getNodeLabel i n = let (l,_,_) = lookupNode i n in l - -nodeLabel :: Node n a -> a -nodeLabel = snd - -edgeFrom :: Edge n b -> n -edgeFrom (f,_,_) = f - -edgeTo :: Edge n b -> n -edgeTo (_,t,_) = t - -edgeLabel :: Edge n b -> b -edgeLabel (_,_,l) = l - -reverseGraph :: Graph n a b -> Graph n a b -reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ] - --- | Add the nodes from the second graph to the first graph. --- The nodes in the second graph will be renamed using the name --- supply in the first graph. --- This function is more efficient when the second graph --- is smaller than the first. -mergeGraphs :: Ord m => Graph n a b -> Graph m a b - -> (Graph n a b, m -> n) -- ^ The new graph and a function translating - -- the old names of nodes in the second graph - -- to names in the new graph. -mergeGraphs (Graph c ns1 es1) g2 = (Graph c' (ns2++ns1) (es2++es1), newName) - where - (xs,c') = splitAt (length (nodes g2)) c - newNames = Map.fromList (zip (map fst (nodes g2)) xs) - newName n = fromJust $ Map.lookup n newNames - Graph _ ns2 es2 = renameNodes newName undefined g2 - --- | Rename the nodes in the graph. -renameNodes :: (n -> m) -- ^ renaming function - -> [m] -- ^ infinite supply of fresh node names, to - -- use when adding nodes in the future. - -> Graph n a b -> Graph m a b -renameNodes newName c (Graph _ ns es) = Graph c ns' es' - where ns' = map' (\ (n,x) -> (newName n,x)) ns - es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es - --- | A strict 'map' -map' :: (a -> b) -> [a] -> [b] -map' _ [] = [] -map' f (x:xs) = ((:) $! f x) $! map' f xs diff --git a/src/GF/Data/Graphviz.hs b/src/GF/Data/Graphviz.hs deleted file mode 100644 index 411f76898..000000000 --- a/src/GF/Data/Graphviz.hs +++ /dev/null @@ -1,116 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Graphviz --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/15 18:10:44 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Graphviz DOT format representation and printing. ------------------------------------------------------------------------------ - -module GF.Data.Graphviz ( - Graph(..), GraphType(..), - Node(..), Edge(..), - Attr, - addSubGraphs, - setName, - setAttr, - prGraphviz - ) where - -import Data.Char - -import GF.Data.Utilities - --- | Graph type, graph ID, graph attirbutes, graph nodes, graph edges, subgraphs -data Graph = Graph { - gType :: GraphType, - gId :: Maybe String, - gAttrs :: [Attr], - gNodes :: [Node], - gEdges :: [Edge], - gSubgraphs :: [Graph] - } - deriving (Show) - -data GraphType = Directed | Undirected - deriving (Show) - -data Node = Node String [Attr] - deriving Show - -data Edge = Edge String String [Attr] - deriving Show - -type Attr = (String,String) - --- --- * Graph construction --- - -addSubGraphs :: [Graph] -> Graph -> Graph -addSubGraphs gs g = g { gSubgraphs = gs ++ gSubgraphs g } - -setName :: String -> Graph -> Graph -setName n g = g { gId = Just n } - -setAttr :: String -> String -> Graph -> Graph -setAttr n v g = g { gAttrs = tableSet n v (gAttrs g) } - --- --- * Pretty-printing --- - -prGraphviz :: Graph -> String -prGraphviz g@(Graph t i _ _ _ _) = - graphtype t ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}\n" - -prSubGraph :: Graph -> String -prSubGraph g@(Graph _ i _ _ _ _) = - "subgraph" ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}" - -prGraph :: Graph -> String -prGraph (Graph t id at ns es ss) = - unlines $ map (++";") (map prAttr at - ++ map prNode ns - ++ map (prEdge t) es - ++ map prSubGraph ss) - -graphtype :: GraphType -> String -graphtype Directed = "digraph" -graphtype Undirected = "graph" - -prNode :: Node -> String -prNode (Node n at) = esc n ++ " " ++ prAttrList at - -prEdge :: GraphType -> Edge -> String -prEdge t (Edge x y at) = esc x ++ " " ++ edgeop t ++ " " ++ esc y ++ " " ++ prAttrList at - -edgeop :: GraphType -> String -edgeop Directed = "->" -edgeop Undirected = "--" - -prAttrList :: [Attr] -> String -prAttrList [] = "" -prAttrList at = "[" ++ join "," (map prAttr at) ++ "]" - -prAttr :: Attr -> String -prAttr (n,v) = esc n ++ " = " ++ esc v - -esc :: String -> String -esc s | needEsc s = "\"" ++ concat [ if shouldEsc c then ['\\',c] else [c] | c <- s ] ++ "\"" - | otherwise = s - where shouldEsc = (`elem` ['"', '\\']) - -needEsc :: String -> Bool -needEsc [] = True -needEsc xs | all isDigit xs = False -needEsc (x:xs) = not (isIDFirst x && all isIDChar xs) - -isIDFirst, isIDChar :: Char -> Bool -isIDFirst c = c `elem` (['_']++['a'..'z']++['A'..'Z']) -isIDChar c = isIDFirst c || isDigit c diff --git a/src/GF/Data/MultiMap.hs b/src/GF/Data/MultiMap.hs deleted file mode 100644 index e565f433b..000000000 --- a/src/GF/Data/MultiMap.hs +++ /dev/null @@ -1,47 +0,0 @@ -module GF.Data.MultiMap where - -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Prelude hiding (map) -import qualified Prelude - -type MultiMap k a = Map k (Set a) - -empty :: MultiMap k a -empty = Map.empty - -keys :: MultiMap k a -> [k] -keys = Map.keys - -elems :: MultiMap k a -> [a] -elems = concatMap Set.toList . Map.elems - -(!) :: Ord k => MultiMap k a -> k -> [a] -m ! k = Set.toList $ Map.findWithDefault Set.empty k m - -member :: (Ord k, Ord a) => k -> a -> MultiMap k a -> Bool -member k x m = x `Set.member` Map.findWithDefault Set.empty k m - -insert :: (Ord k, Ord a) => k -> a -> MultiMap k a -> MultiMap k a -insert k x m = Map.insertWith Set.union k (Set.singleton x) m - -insert' :: (Ord k, Ord a) => k -> a -> MultiMap k a -> Maybe (MultiMap k a) -insert' k x m | member k x m = Nothing -- FIXME: inefficient - | otherwise = Just (insert k x m) - -union :: (Ord k, Ord a) => MultiMap k a -> MultiMap k a -> MultiMap k a -union = Map.unionWith Set.union - -size :: MultiMap k a -> Int -size = sum . Prelude.map Set.size . Map.elems - -map :: (Ord a, Ord b) => (a -> b) -> MultiMap k a -> MultiMap k b -map f = Map.map (Set.map f) - -fromList :: (Ord k, Ord a) => [(k,a)] -> MultiMap k a -fromList xs = Map.fromListWith Set.union [(k, Set.singleton x) | (k,x) <- xs] - -toList :: MultiMap k a -> [(k,a)] -toList m = [(k,x) | (k,s) <- Map.toList m, x <- Set.toList s] \ No newline at end of file diff --git a/src/GF/Data/Operations.hs b/src/GF/Data/Operations.hs deleted file mode 100644 index 7b2afc9fe..000000000 --- a/src/GF/Data/Operations.hs +++ /dev/null @@ -1,374 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Operations --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 16:12:41 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.22 $ --- --- some auxiliary GF operations. AR 19\/6\/1998 -- 6\/2\/2001 --- --- Copyright (c) Aarne Ranta 1998-2000, under GNU General Public License (see GPL) ------------------------------------------------------------------------------ - -module GF.Data.Operations (-- * misc functions - ifNull, onSnd, - - -- * the Error monad - Err(..), err, maybeErr, testErr, errVal, errIn, - lookupErr, - mapPairListM, mapPairsM, pairM, - singleton, mapsErr, mapsErrTree, - - -- ** checking - checkUnique, - - -- * binary search trees; now with FiniteMap - BinTree, emptyBinTree, isInBinTree, justLookupTree, - lookupTree, lookupTreeMany, lookupTreeManyAll, updateTree, - buildTree, filterBinTree, - sorted2tree, mapTree, mapMTree, tree2list, - - - -- * printing - indent, (+++), (++-), (++++), (+++++), - prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly, - prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes, - numberedParagraphs, prConjList, prIfEmpty, wrapLines, - - -- * extra - combinations, - - -- * topological sorting with test of cyclicity - topoTest, - - -- * the generic fix point iterator - iterFix, - - -- * chop into separator-separated parts - chunks, readIntArg, - - -- * 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 qualified Data.Map as Map -import Data.Map (Map) -import Control.Monad (liftM,liftM2, MonadPlus, mzero, mplus) - -import GF.Data.ErrM -import GF.Data.Relation - -infixr 5 +++ -infixr 5 ++- -infixr 5 ++++ -infixr 5 +++++ - -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 - -lookupErr :: (Eq a,Show a) => a -> [(a,b)] -> Err b -lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs) - -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) - -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 - --- binary search trees - -type BinTree a b = Map a b - -emptyBinTree :: BinTree a b -emptyBinTree = Map.empty - -isInBinTree :: (Ord a) => a -> BinTree a b -> Bool -isInBinTree = Map.member - -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 Map.lookup x tree 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 = [] - -updateTree :: (Ord a) => (a,b) -> BinTree a b -> BinTree a b -updateTree (a,b) = Map.insert a b - -buildTree :: (Ord a) => [(a,b)] -> BinTree a b -buildTree = Map.fromList - -sorted2tree :: Ord a => [(a,b)] -> BinTree a b -sorted2tree = Map.fromAscList - -mapTree :: ((a,b) -> c) -> BinTree a b -> BinTree a c -mapTree f = Map.mapWithKey (\k v -> f (k,v)) - -mapMTree :: (Ord a,Monad m) => ((a,b) -> m c) -> BinTree a b -> m (BinTree a c) -mapMTree f t = liftM Map.fromList $ sequence [liftM ((,) k) (f (k,x)) | (k,x) <- Map.toList t] - -filterBinTree :: Ord a => (a -> b -> Bool) -> BinTree a b -> BinTree a b -filterBinTree = Map.filterWithKey - -tree2list :: BinTree a b -> [(a,b)] -- inorder -tree2list = Map.toList - --- 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 - --- | '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] - --- | topological sorting with test of cyclicity -topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]] -topoTest = topologicalSort . mkRel' - --- | 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) - --- | 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)) - --- error recovery with multiple reporting AR 30/5/2008 -mapsErr :: (a -> Err b) -> [a] -> Err [b] - -mapsErr f = seqs . map f where - seqs es = case es of - Ok v : ms -> case seqs ms of - Ok vs -> return (v : vs) - b -> b - Bad s : ms -> case seqs ms of - Ok vs -> Bad s - Bad ss -> Bad (s +++++ ss) - [] -> return [] - -mapsErrTree :: (Ord a) => ((a,b) -> Err (a,c)) -> BinTree a b -> Err (BinTree a c) -mapsErrTree f t = mapsErr f (tree2list t) >>= return . sorted2tree - - --- | 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" diff --git a/src/GF/Data/Relation.hs b/src/GF/Data/Relation.hs deleted file mode 100644 index 7024a482c..000000000 --- a/src/GF/Data/Relation.hs +++ /dev/null @@ -1,193 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Relation --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/26 17:13:13 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.1 $ --- --- A simple module for relations. ------------------------------------------------------------------------------ - -module GF.Data.Relation (Rel, mkRel, mkRel' - , allRelated , isRelatedTo - , transitiveClosure - , reflexiveClosure, reflexiveClosure_ - , symmetricClosure - , symmetricSubrelation, reflexiveSubrelation - , reflexiveElements - , equivalenceClasses - , isTransitive, isReflexive, isSymmetric - , isEquivalence - , isSubRelationOf - , topologicalSort) where - -import Data.Foldable (toList) -import Data.List -import Data.Maybe -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Sequence (Seq) -import qualified Data.Sequence as Seq -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 :: Ord a => 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) - -reverseRel :: Ord a => Rel a -> Rel a -reverseRel r = mkRel [(y,x) | (x,y) <- relToList 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 = fst . purgeEmpty . Map.mapWithKey (Set.filter . p) - --- | Remove keys that map to no elements. -purgeEmpty :: Ord a => Rel a -> (Rel a, Set a) -purgeEmpty r = let (r',r'') = Map.partition (not . Set.null) r - in (r', Map.keysSet 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) - --- | Returns 'Left' if there are cycles, and 'Right' if there are cycles. -topologicalSort :: Ord a => Rel a -> Either [a] [[a]] -topologicalSort r = tsort r' noIncoming Seq.empty - where r' = relToRel' r - noIncoming = Seq.fromList [x | (x,(is,_)) <- Map.toList r', Set.null is] - -tsort :: Ord a => Rel' a -> Seq a -> Seq a -> Either [a] [[a]] -tsort r xs l = case Seq.viewl xs of - Seq.EmptyL | isEmpty' r -> Left (toList l) - | otherwise -> Right (findCycles (rel'ToRel r)) - x Seq.:< xs -> tsort r' (xs Seq.>< Seq.fromList new) (l Seq.|> x) - where (r',_,os) = remove x r - new = [o | o <- Set.toList os, Set.null (incoming o r')] - -findCycles :: Ord a => Rel a -> [[a]] -findCycles = map Set.toList . equivalenceClasses . reflexiveSubrelation . symmetricSubrelation . transitiveClosure - --- --- * Alternative representation that keeps both incoming and outgoing edges --- - --- | Keeps both incoming and outgoing edges. -type Rel' a = Map a (Set a, Set a) - -isEmpty' :: Ord a => Rel' a -> Bool -isEmpty' = Map.null - -relToRel' :: Ord a => Rel a -> Rel' a -relToRel' r = Map.unionWith (\ (i,_) (_,o) -> (i,o)) ir or - where ir = Map.map (\s -> (s,Set.empty)) $ reverseRel r - or = Map.map (\s -> (Set.empty,s)) $ r - -rel'ToRel :: Ord a => Rel' a -> Rel a -rel'ToRel = Map.map snd - --- | Removes an element from a relation. --- Returns the new relation, and the set of incoming and outgoing edges --- of the removed element. -remove :: Ord a => a -> Rel' a -> (Rel' a, Set a, Set a) -remove x r = let (mss,r') = Map.updateLookupWithKey (\_ _ -> Nothing) x r - in case mss of - -- element was not in the relation - Nothing -> (r', Set.empty, Set.empty) - -- remove element from all incoming and outgoing sets - -- of other elements - Just (is,os) -> - let r'' = foldr (\i -> Map.adjust (\ (is',os') -> (is', Set.delete x os')) i) r' $ Set.toList is - r''' = foldr (\o -> Map.adjust (\ (is',os') -> (Set.delete x is', os')) o) r'' $ Set.toList os - in (r''', is, os) - -incoming :: Ord a => a -> Rel' a -> Set a -incoming x r = maybe Set.empty fst $ Map.lookup x r - -outgoing :: Ord a => a -> Rel' a -> Set a -outgoing x r = maybe Set.empty snd $ Map.lookup x r \ No newline at end of file diff --git a/src/GF/Data/SortedList.hs b/src/GF/Data/SortedList.hs deleted file mode 100644 index d77ff68d4..000000000 --- a/src/GF/Data/SortedList.hs +++ /dev/null @@ -1,127 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Peter Ljunglöf --- Stability : stable --- Portability : portable --- --- > CVS $Date: 2005/04/21 16:22:08 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.3 $ --- --- Sets as sorted lists --- --- * /O(n)/ union, difference and intersection --- --- * /O(n log n)/ creating a set from a list (=sorting) --- --- * /O(n^2)/ fixed point iteration ------------------------------------------------------------------------------ - -module GF.Data.SortedList - ( -- * type declarations - SList, SMap, - -- * set operations - nubsort, union, - (<++>), (<\\>), (<**>), - limit, - hasCommonElements, subset, - -- * map operations - groupPairs, groupUnion, - unionMap, mergeMap - ) where - -import Data.List (groupBy) -import GF.Data.Utilities (split, foldMerge) - --- | The list must be sorted and contain no duplicates. -type SList a = [a] - --- | A sorted map also has unique keys, --- i.e. 'map fst m :: SList a', if 'm :: SMap a b' -type SMap a b = SList (a, b) - --- | Group a set of key-value pairs into a sorted map -groupPairs :: Ord a => SList (a, b) -> SMap a (SList b) -groupPairs = map mapFst . groupBy eqFst - where mapFst as = (fst (head as), map snd as) - eqFst a b = fst a == fst b - --- | Group a set of key-(sets-of-values) pairs into a sorted map -groupUnion :: (Ord a, Ord b) => SList (a, SList b) -> SMap a (SList b) -groupUnion = map unionSnd . groupPairs - where unionSnd (a, bs) = (a, union bs) - --- | True is the two sets has common elements -hasCommonElements :: Ord a => SList a -> SList a -> Bool -hasCommonElements as bs = not (null (as <**> bs)) - --- | True if the first argument is a subset of the second argument -subset :: Ord a => SList a -> SList a -> Bool -xs `subset` ys = null (xs <\\> ys) - --- | Create a set from any list. --- This function can also be used as an alternative to @nub@ in @List.hs@ -nubsort :: Ord a => [a] -> SList a -nubsort = union . map return - --- | the union of a list of sorted maps -unionMap :: Ord a => (b -> b -> b) - -> [SMap a b] -> SMap a b -unionMap plus = foldMerge (mergeMap plus) [] - --- | merging two sorted maps -mergeMap :: Ord a => (b -> b -> b) - -> SMap a b -> SMap a b -> SMap a b -mergeMap plus [] abs = abs -mergeMap plus abs [] = abs -mergeMap plus abs@(ab@(a,bs):abs') cds@(cd@(c,ds):cds') - = case compare a c of - EQ -> (a, plus bs ds) : mergeMap plus abs' cds' - LT -> ab : mergeMap plus abs' cds - GT -> cd : mergeMap plus abs cds' - --- | The union of a list of sets -union :: Ord a => [SList a] -> SList a -union = foldMerge (<++>) [] - --- | The union of two sets -(<++>) :: Ord a => SList a -> SList a -> SList a -[] <++> bs = bs -as <++> [] = as -as@(a:as') <++> bs@(b:bs') = case compare a b of - LT -> a : (as' <++> bs) - GT -> b : (as <++> bs') - EQ -> a : (as' <++> bs') - --- | The difference of two sets -(<\\>) :: Ord a => SList a -> SList a -> SList a -[] <\\> bs = [] -as <\\> [] = as -as@(a:as') <\\> bs@(b:bs') = case compare a b of - LT -> a : (as' <\\> bs) - GT -> (as <\\> bs') - EQ -> (as' <\\> bs') - --- | The intersection of two sets -(<**>) :: Ord a => SList a -> SList a -> SList a -[] <**> bs = [] -as <**> [] = [] -as@(a:as') <**> bs@(b:bs') = case compare a b of - LT -> (as' <**> bs) - GT -> (as <**> bs') - EQ -> a : (as' <**> bs') - --- | A fixed point iteration -limit :: Ord a => (a -> SList a) -- ^ The iterator function - -> SList a -- ^ The initial set - -> SList a -- ^ The result of the iteration -limit more start = limit' start start - where limit' chart agenda | null new' = chart - | otherwise = limit' (chart <++> new') new' - where new = union (map more agenda) - new'= new <\\> chart - - - - - diff --git a/src/GF/Data/Str.hs b/src/GF/Data/Str.hs deleted file mode 100644 index 6f65764c7..000000000 --- a/src/GF/Data/Str.hs +++ /dev/null @@ -1,134 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Str --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:09 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Data.Str ( - Str (..), Tok (..), --- constructors needed in PrGrammar - str2strings, str2allStrings, str, sstr, sstrV, - isZeroTok, prStr, plusStr, glueStr, - strTok, - allItems -) where - -import GF.Data.Operations -import Data.List (isPrefixOf, isSuffixOf, intersperse) - --- | abstract token list type. AR 2001, revised and simplified 20\/4\/2003 -newtype Str = Str [Tok] deriving (Read, Show, Eq, Ord) - --- | notice that having both pre and post would leave to inconsistent situations: --- --- > pre {"x" ; "y" / "a"} ++ post {"b" ; "a" / "x"} --- --- always violates a condition expressed by the one or the other -data Tok = - TK String - | TN Ss [(Ss, [String])] -- ^ variants depending on next string ---- | TP Ss [(Ss, [String])] -- variants depending on previous string - deriving (Eq, Ord, Show, Read) - - --- | a variant can itself be a token list, but for simplicity only a list of strings --- i.e. not itself containing variants -type Ss = [String] - --- matching functions in both ways - -matchPrefix :: Ss -> [(Ss,[String])] -> [String] -> Ss -matchPrefix s vs t = - head $ [u | - (u,as) <- vs, - any (\c -> isPrefixOf c (concat (unmarkup t))) as - ] ++ [s] - -matchSuffix :: String -> Ss -> [(Ss,[String])] -> Ss -matchSuffix t s vs = - head ([u | (u,as) <- vs, any (\c -> isSuffixOf c t) as] ++ [s]) - -unmarkup :: [String] -> [String] -unmarkup = filter (not . isXMLtag) where - isXMLtag s = case s of - '<':cs@(_:_) -> last cs == '>' - _ -> False - -str2strings :: Str -> Ss -str2strings (Str st) = alls st where - alls st = case st of - TK s : ts -> s : alls ts - TN ds vs : ts -> matchPrefix ds vs t ++ t where t = alls ts ----- u :TP ds vs: ts -> [u] ++ matchSuffix u ds vs ++ alls ts - [] -> [] - -str2allStrings :: Str -> [Ss] -str2allStrings (Str st) = alls st where - alls st = case st of - TK s : ts -> [s : t | t <- alls ts] - TN ds vs : [] -> [ds ++ v | v <- map fst vs] - TN ds vs : ts -> [matchPrefix ds vs t ++ t | t <- alls ts] - [] -> [[]] - -sstr :: Str -> String -sstr = unwords . str2strings - --- | to handle a list of variants -sstrV :: [Str] -> String -sstrV ss = case ss of - [] -> "*" - _ -> unwords $ intersperse "/" $ map (unwords . str2strings) ss - -str :: String -> Str -str s = if null s then Str [] else Str [itS s] - -itS :: String -> Tok -itS s = TK s - -isZeroTok :: Str -> Bool -isZeroTok t = case t of - Str [] -> True - Str [TK []] -> True - _ -> False - -strTok :: Ss -> [(Ss,[String])] -> Str -strTok ds vs = Str [TN ds vs] - -prStr :: Str -> String -prStr = prQuotedString . sstr - -plusStr :: Str -> Str -> Str -plusStr (Str ss) (Str tt) = Str (ss ++ tt) - -glueStr :: Str -> Str -> Str -glueStr (Str ss) (Str tt) = Str $ case (ss,tt) of - ([],_) -> tt - (_,[]) -> ss - _ -> init ss ++ glueIt (last ss) (head tt) ++ tail tt - where - glueIt t u = case (t,u) of - (TK s, TK s') -> return $ TK $ s ++ s' - (TN ds vs, TN es ws) -> return $ TN (glues (matchPrefix ds vs es) es) - [(glues (matchPrefix ds vs w) w,cs) | (w,cs) <- ws] - (TN ds vs, TK s) -> map TK $ glues (matchPrefix ds vs [s]) [s] - (TK s, TN es ws) -> return $ TN (glues [s] es) [(glues [s] w, c) | (w,c) <- ws] - -glues :: [[a]] -> [[a]] -> [[a]] -glues ss tt = case (ss,tt) of - ([],_) -> tt - (_,[]) -> ss - _ -> init ss ++ [last ss ++ head tt] ++ tail tt - --- | to create the list of all lexical items -allItems :: Str -> [String] -allItems (Str s) = concatMap allOne s where - allOne t = case t of - TK s -> [s] - TN ds vs -> ds ++ concatMap fst vs diff --git a/src/GF/Data/TrieMap.hs b/src/GF/Data/TrieMap.hs deleted file mode 100644 index a6749d641..000000000 --- a/src/GF/Data/TrieMap.hs +++ /dev/null @@ -1,66 +0,0 @@ -module GF.Data.TrieMap - ( TrieMap - - , empty - , singleton - - , lookup - - , null - , decompose - - , insertWith - - , unionWith - , unionsWith - - , elems - ) where - -import Prelude hiding (lookup, null) -import qualified Data.Map as Map - -data TrieMap k v = Tr (Maybe v) (Map.Map k (TrieMap k v)) - -empty = Tr Nothing Map.empty - -singleton :: [k] -> a -> TrieMap k a -singleton [] v = Tr (Just v) Map.empty -singleton (k:ks) v = Tr Nothing (Map.singleton k (singleton ks v)) - -lookup :: Ord k => [k] -> TrieMap k a -> Maybe a -lookup [] (Tr mb_v m) = mb_v -lookup (k:ks) (Tr mb_v m) = Map.lookup k m >>= lookup ks - -null :: TrieMap k v -> Bool -null (Tr Nothing m) = Map.null m -null _ = False - -decompose :: TrieMap k v -> (Maybe v, Map.Map k (TrieMap k v)) -decompose (Tr mb_v m) = (mb_v,m) - -insertWith :: Ord k => (v -> v -> v) -> [k] -> v -> TrieMap k v -> TrieMap k v -insertWith f [] v0 (Tr mb_v m) = case mb_v of - Just v -> Tr (Just (f v0 v)) m - Nothing -> Tr (Just v0 ) m -insertWith f (k:ks) v0 (Tr mb_v m) = case Map.lookup k m of - Nothing -> Tr mb_v (Map.insert k (singleton ks v0) m) - Just tr -> Tr mb_v (Map.insert k (insertWith f ks v0 tr) m) - -unionWith :: Ord k => (v -> v -> v) -> TrieMap k v -> TrieMap k v -> TrieMap k v -unionWith f (Tr mb_v1 m1) (Tr mb_v2 m2) = - let mb_v = case (mb_v1,mb_v2) of - (Nothing,Nothing) -> Nothing - (Just v ,Nothing) -> Just v - (Nothing,Just v ) -> Just v - (Just v1,Just v2) -> Just (f v1 v2) - m = Map.unionWith (unionWith f) m1 m2 - in Tr mb_v m - -unionsWith :: Ord k => (v -> v -> v) -> [TrieMap k v] -> TrieMap k v -unionsWith f = foldl (unionWith f) empty - -elems :: TrieMap k v -> [v] -elems tr = collect tr [] - where - collect (Tr mb_v m) xs = maybe id (:) mb_v (Map.fold collect xs m) diff --git a/src/GF/Data/Utilities.hs b/src/GF/Data/Utilities.hs deleted file mode 100644 index 74d3ef81e..000000000 --- a/src/GF/Data/Utilities.hs +++ /dev/null @@ -1,190 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/26 18:47:16 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- Basic functions not in the standard libraries ------------------------------------------------------------------------------ - - -module GF.Data.Utilities where - -import Data.Maybe -import Data.List -import Control.Monad (MonadPlus(..),liftM) - --- * functions on lists - -sameLength :: [a] -> [a] -> Bool -sameLength [] [] = True -sameLength (_:xs) (_:ys) = sameLength xs ys -sameLength _ _ = False - -notLongerThan, longerThan :: Int -> [a] -> Bool -notLongerThan n = null . snd . splitAt n -longerThan n = not . notLongerThan n - -lookupList :: Eq a => a -> [(a, b)] -> [b] -lookupList a [] = [] -lookupList a (p:ps) | a == fst p = snd p : lookupList a ps - | otherwise = lookupList a ps - -split :: [a] -> ([a], [a]) -split (x : y : as) = (x:xs, y:ys) - where (xs, ys) = split as -split as = (as, []) - -splitBy :: (a -> Bool) -> [a] -> ([a], [a]) -splitBy p [] = ([], []) -splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys) - where (xs, ys) = splitBy p as - -foldMerge :: (a -> a -> a) -> a -> [a] -> a -foldMerge merge zero = fm - where fm [] = zero - fm [a] = a - fm abs = let (as, bs) = split abs in fm as `merge` fm bs - -select :: [a] -> [(a, [a])] -select [] = [] -select (x:xs) = (x,xs) : [ (y,x:ys) | (y,ys) <- select xs ] - -updateNth :: (a -> a) -> Int -> [a] -> [a] -updateNth update 0 (a : as) = update a : as -updateNth update n (a : as) = a : updateNth update (n-1) as - -updateNthM :: Monad m => (a -> m a) -> Int -> [a] -> m [a] -updateNthM update 0 (a : as) = liftM (:as) (update a) -updateNthM update n (a : as) = liftM (a:) (updateNthM update (n-1) as) - --- | Like 'init', but returns the empty list when the input is empty. -safeInit :: [a] -> [a] -safeInit [] = [] -safeInit xs = init xs - --- | Like 'nub', but more efficient as it uses sorting internally. -sortNub :: Ord a => [a] -> [a] -sortNub = map head . group . sort - --- | Like 'nubBy', but more efficient as it uses sorting internally. -sortNubBy :: (a -> a -> Ordering) -> [a] -> [a] -sortNubBy f = map head . sortGroupBy f - --- | Sorts and then groups elements given and ordering of the --- elements. -sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]] -sortGroupBy f = groupBy (compareEq f) . sortBy f - --- | Take the union of a list of lists. -unionAll :: Eq a => [[a]] -> [a] -unionAll = nub . concat - --- | Like 'lookup', but fails if the argument is not found, --- instead of returning Nothing. -lookup' :: (Show a, Eq a) => a -> [(a,b)] -> b -lookup' x = fromMaybe (error $ "Not found: " ++ show x) . lookup x - --- | Like 'find', but fails if nothing is found. -find' :: (a -> Bool) -> [a] -> a -find' p = fromJust . find p - --- | Set a value in a lookup table. -tableSet :: Eq a => a -> b -> [(a,b)] -> [(a,b)] -tableSet x y [] = [(x,y)] -tableSet x y (p@(x',_):xs) | x' == x = (x,y):xs - | otherwise = p:tableSet x y xs - --- | Group tuples by their first elements. -buildMultiMap :: Ord a => [(a,b)] -> [(a,[b])] -buildMultiMap = map (\g -> (fst (head g), map snd g) ) - . sortGroupBy (compareBy fst) - --- | Replace all occurences of an element by another element. -replace :: Eq a => a -> a -> [a] -> [a] -replace x y = map (\z -> if z == x then y else z) - --- * equality functions - --- | Use an ordering function as an equality predicate. -compareEq :: (a -> a -> Ordering) -> a -> a -> Bool -compareEq f x y = case f x y of - EQ -> True - _ -> False - --- * ordering functions - -compareBy :: Ord b => (a -> b) -> a -> a -> Ordering -compareBy f = both f compare - -both :: (a -> b) -> (b -> b -> c) -> a -> a -> c -both f g x y = g (f x) (f y) - --- * functions on pairs - -mapFst :: (a -> a') -> (a, b) -> (a', b) -mapFst f (a, b) = (f a, b) - -mapSnd :: (b -> b') -> (a, b) -> (a, b') -mapSnd f (a, b) = (a, f b) - --- * functions on monads - --- | Return the given value if the boolean is true, els return 'mzero'. -whenMP :: MonadPlus m => Bool -> a -> m a -whenMP b x = if b then return x else mzero - --- * functions on Maybes - --- | Returns true if the argument is Nothing or Just [] -nothingOrNull :: Maybe [a] -> Bool -nothingOrNull = maybe True null - --- * functions on functions - --- | Apply all the functions in the list to the argument. -foldFuns :: [a -> a] -> a -> a -foldFuns fs x = foldl (flip ($)) x fs - --- | Fixpoint iteration. -fix :: Eq a => (a -> a) -> a -> a -fix f x = let x' = f x in if x' == x then x else fix f x' - --- * functions on strings - --- | Join a number of lists by using the given glue --- between the lists. -join :: [a] -- ^ glue - -> [[a]] -- ^ lists to join - -> [a] -join g = concat . intersperse g - --- * ShowS-functions - -nl :: ShowS -nl = showChar '\n' - -sp :: ShowS -sp = showChar ' ' - -wrap :: String -> ShowS -> String -> ShowS -wrap o s c = showString o . s . showString c - -concatS :: [ShowS] -> ShowS -concatS = foldr (.) id - -unwordsS :: [ShowS] -> ShowS -unwordsS = joinS " " - -unlinesS :: [ShowS] -> ShowS -unlinesS = joinS "\n" - -joinS :: String -> [ShowS] -> ShowS -joinS glue = concatS . intersperse (showString glue) - - - diff --git a/src/GF/Data/XML.hs b/src/GF/Data/XML.hs deleted file mode 100644 index bdc6f98a1..000000000 --- a/src/GF/Data/XML.hs +++ /dev/null @@ -1,58 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : XML --- --- Utilities for creating XML documents. ----------------------------------------------------------------------- -module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where - -import GF.Data.Utilities -import GF.Text.UTF8 - -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 = encodeUTF8 . showString header . showsXML xml - where header = "" - -showsXML :: XML -> ShowS -showsXML = showsX 0 where - showsX i x = ind i . case x of - (Data s) -> showString s - (CData s) -> showString "" - (ETag t as) -> showChar '<' . showString t . showsAttrs as . showString "/>" - (Tag t as cs) -> - showChar '<' . showString t . showsAttrs as . showChar '>' . - concatS (map (showsX (i+1)) cs) . ind i . - showString "' - (Comment c) -> showString "" - (Empty) -> id - ind i = showString ("\n" ++ replicate (2*i) ' ') - -showsAttrs :: [Attr] -> ShowS -showsAttrs = concatS . map (showChar ' ' .) . map showsAttr - -showsAttr :: Attr -> ShowS -showsAttr (n,v) = showString n . showString "=\"" . showString (escape v) . showString "\"" - -escape :: String -> String -escape = concatMap escChar - where - escChar '<' = "<" - escChar '>' = ">" - escChar '&' = "&" - escChar '"' = """ - escChar c = [c] - -bottomUpXML :: (XML -> XML) -> XML -> XML -bottomUpXML f (Tag n attrs cs) = f (Tag n attrs (map (bottomUpXML f) cs)) -bottomUpXML f x = f x diff --git a/src/GF/Data/Zipper.hs b/src/GF/Data/Zipper.hs deleted file mode 100644 index a4491f76e..000000000 --- a/src/GF/Data/Zipper.hs +++ /dev/null @@ -1,257 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Zipper --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/11 20:27:05 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.9 $ --- --- Gérard Huet's zipper (JFP 7 (1997)). AR 10\/8\/2001 ------------------------------------------------------------------------------ - -module GF.Data.Zipper (-- * types - Tr(..), - Path(..), - Loc(..), - -- * basic (original) functions - leaf, - goLeft, goRight, goUp, goDown, - changeLoc, - changeNode, - forgetNode, - -- * added sequential representation - goAhead, - goBack, - -- ** n-ary versions - goAheadN, - goBackN, - -- * added mappings between locations and trees - loc2tree, - loc2treeMarked, - tree2loc, - goRoot, - goLast, - goPosition, - getPosition, - keepPosition, - -- * added some utilities - traverseCollect, - scanTree, - mapTr, - mapTrM, - mapPath, - mapPathM, - mapLoc, - mapLocM, - foldTr, - foldTrM, - mapSubtrees, - mapSubtreesM, - changeRoot, - nthSubtree, - arityTree - ) where - -import GF.Data.Operations - -newtype Tr a = Tr (a,[Tr a]) deriving (Show,Eq) - -data Path a = - Top - | Node ([Tr a], (Path a, a), [Tr a]) - deriving Show - -leaf :: a -> Tr a -leaf a = Tr (a,[]) - -newtype Loc a = Loc (Tr a, Path a) deriving Show - -goLeft, goRight, goUp, goDown :: Loc a -> Err (Loc a) -goLeft (Loc (t,p)) = case p of - Top -> Bad "left of top" - Node (l:left, upv, right) -> return $ Loc (l, Node (left,upv,t:right)) - Node _ -> Bad "left of first" -goRight (Loc (t,p)) = case p of - Top -> Bad "right of top" - Node (left, upv, r:right) -> return $ Loc (r, Node (t:left,upv,right)) - Node _ -> Bad "right of first" -goUp (Loc (t,p)) = case p of - Top -> Bad "up of top" - Node (left, (up,v), right) -> - return $ Loc (Tr (v, reverse left ++ (t:right)), up) -goDown (Loc (t,p)) = case t of - Tr (v,(t1:trees)) -> return $ Loc (t1,Node ([],(p,v),trees)) - _ -> Bad "down of empty" - -changeLoc :: Loc a -> Tr a -> Err (Loc a) -changeLoc (Loc (_,p)) t = return $ Loc (t,p) - -changeNode :: (a -> a) -> Loc a -> Loc a -changeNode f (Loc (Tr (n,ts),p)) = Loc (Tr (f n, ts),p) - -forgetNode :: Loc a -> Err (Loc a) -forgetNode (Loc (Tr (n,[t]),p)) = return $ Loc (t,p) -forgetNode _ = Bad $ "not a one-branch tree" - --- added sequential representation - --- | a successor function -goAhead :: Loc a -> Err (Loc a) -goAhead s@(Loc (t,p)) = case (t,p) of - (Tr (_,_:_),Node (_,_,_:_)) -> goDown s - (Tr (_,[]), _) -> upsRight s - (_, _) -> goDown s - where - upsRight t = case goRight t of - Ok t' -> return t' - Bad _ -> goUp t >>= upsRight - --- | a predecessor function -goBack :: Loc a -> Err (Loc a) -goBack s@(Loc (t,p)) = case goLeft s of - Ok s' -> downRight s' - _ -> goUp s - where - downRight s = case goDown s of - Ok s' -> case goRight s' of - Ok s'' -> downRight s'' - _ -> downRight s' - _ -> return s - --- n-ary versions - -goAheadN :: Int -> Loc a -> Err (Loc a) -goAheadN i st - | i < 1 = return st - | otherwise = goAhead st >>= goAheadN (i-1) - -goBackN :: Int -> Loc a -> Err (Loc a) -goBackN i st - | i < 1 = return st - | otherwise = goBack st >>= goBackN (i-1) - --- added mappings between locations and trees - -loc2tree :: Loc a -> Tr a -loc2tree (Loc (t,p)) = case p of - Top -> t - Node (left,(p',v),right) -> - loc2tree (Loc (Tr (v, reverse left ++ (t : right)),p')) - -loc2treeMarked :: Loc a -> Tr (a, Bool) -loc2treeMarked (Loc (Tr (a,ts),p)) = - loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p)) - where - (mark, nomark) = (\a -> (a,True), \a -> (a, False)) - -tree2loc :: Tr a -> Loc a -tree2loc t = Loc (t,Top) - -goRoot :: Loc a -> Loc a -goRoot = tree2loc . loc2tree - -goLast :: Loc a -> Err (Loc a) -goLast = rep goAhead where - rep f s = err (const (return s)) (rep f) (f s) - -goPosition :: [Int] -> Loc a -> Err (Loc a) -goPosition p = go p . goRoot where - go [] s = return s - go (p:ps) s = goDown s >>= apply p goRight >>= go ps - -getPosition :: Loc a -> [Int] -getPosition = reverse . getp where - getp (Loc (t,p)) = case p of - Top -> [] - Node (left,(p',v),_) -> length left : getp (Loc (Tr (v, []),p')) - -keepPosition :: (Loc a -> Err (Loc a)) -> (Loc a -> Err (Loc a)) -keepPosition f s = do - let p = getPosition s - s' <- f s - goPosition p s' - -apply :: Monad m => Int -> (a -> m a) -> a -> m a -apply n f a = case n of - 0 -> return a - _ -> f a >>= apply (n-1) f - --- added some utilities - -traverseCollect :: Path a -> [a] -traverseCollect p = reverse $ case p of - Top -> [] - Node (_, (p',v), _) -> v : traverseCollect p' - -scanTree :: Tr a -> [a] -scanTree (Tr (a,ts)) = a : concatMap scanTree ts - -mapTr :: (a -> b) -> Tr a -> Tr b -mapTr f (Tr (x,ts)) = Tr (f x, map (mapTr f) ts) - -mapTrM :: Monad m => (a -> m b) -> Tr a -> m (Tr b) -mapTrM f (Tr (x,ts)) = do - fx <- f x - fts <- mapM (mapTrM f) ts - return $ Tr (fx,fts) - -mapPath :: (a -> b) -> Path a -> Path b -mapPath f p = case p of - Node (ts1, (p,v), ts2) -> - Node (map (mapTr f) ts1, (mapPath f p, f v), map (mapTr f) ts2) - Top -> Top - -mapPathM :: Monad m => (a -> m b) -> Path a -> m (Path b) -mapPathM f p = case p of - Node (ts1, (p,v), ts2) -> do - ts1' <- mapM (mapTrM f) ts1 - p' <- mapPathM f p - v' <- f v - ts2' <- mapM (mapTrM f) ts2 - return $ Node (ts1', (p',v'), ts2') - Top -> return Top - -mapLoc :: (a -> b) -> Loc a -> Loc b -mapLoc f (Loc (t,p)) = Loc (mapTr f t, mapPath f p) - -mapLocM :: Monad m => (a -> m b) -> Loc a -> m (Loc b) -mapLocM f (Loc (t,p)) = do - t' <- mapTrM f t - p' <- mapPathM f p - return $ (Loc (t',p')) - -foldTr :: (a -> [b] -> b) -> Tr a -> b -foldTr f (Tr (x,ts)) = f x (map (foldTr f) ts) - -foldTrM :: Monad m => (a -> [b] -> m b) -> Tr a -> m b -foldTrM f (Tr (x,ts)) = do - fts <- mapM (foldTrM f) ts - f x fts - -mapSubtrees :: (Tr a -> Tr a) -> Tr a -> Tr a -mapSubtrees f t = let Tr (x,ts) = f t in Tr (x, map (mapSubtrees f) ts) - -mapSubtreesM :: Monad m => (Tr a -> m (Tr a)) -> Tr a -> m (Tr a) -mapSubtreesM f t = do - Tr (x,ts) <- f t - ts' <- mapM (mapSubtreesM f) ts - return $ Tr (x, ts') - --- | change the root without moving the pointer -changeRoot :: (a -> a) -> Loc a -> Loc a -changeRoot f loc = case loc of - Loc (Tr (a,ts),Top) -> Loc (Tr (f a,ts),Top) - Loc (t, Node (left,pv,right)) -> Loc (t, Node (left,chPath pv,right)) - where - chPath pv = case pv of - (Top,a) -> (Top, f a) - (Node (left,pv,right),v) -> (Node (left, chPath pv,right),v) - -nthSubtree :: Int -> Tr a -> Err (Tr a) -nthSubtree n (Tr (a,ts)) = ts !? n - -arityTree :: Tr a -> Int -arityTree (Tr (_,ts)) = length ts diff --git a/src/GF/Grammar.hs b/src/GF/Grammar.hs deleted file mode 100644 index c540f77b8..000000000 --- a/src/GF/Grammar.hs +++ /dev/null @@ -1,29 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Abstract --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:18 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Grammar - ( module GF.Infra.Ident, - module GF.Grammar.Grammar, - module GF.Grammar.Values, - module GF.Grammar.Macros, - module GF.Grammar.MMacros, - module GF.Grammar.Printer - ) where - -import GF.Infra.Ident -import GF.Grammar.Grammar -import GF.Grammar.Values -import GF.Grammar.Macros -import GF.Grammar.MMacros -import GF.Grammar.Printer diff --git a/src/GF/Grammar/Binary.hs b/src/GF/Grammar/Binary.hs deleted file mode 100644 index fbad5ac7e..000000000 --- a/src/GF/Grammar/Binary.hs +++ /dev/null @@ -1,261 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Grammar.Binary --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- ------------------------------------------------------------------------------ - -module GF.Grammar.Binary where - -import Data.Binary -import qualified Data.Map as Map -import qualified Data.ByteString.Char8 as BS - -import GF.Data.Operations -import GF.Infra.Ident -import GF.Infra.Option -import GF.Infra.Modules -import GF.Grammar.Grammar - -instance Binary Ident where - put id = put (ident2bs id) - get = do bs <- get - if bs == BS.pack "_" - then return identW - else return (identC bs) - -instance (Ord i, Binary i, Binary a) => Binary (MGrammar i a) where - put (MGrammar ms) = put ms - get = fmap MGrammar get - -instance (Ord i, Binary i, Binary a) => Binary (ModInfo i a) where - put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,jments mi,positions mi) - get = do (mtype,mstatus,flags,extend,mwith,opens,med,jments,positions) <- get - return (ModInfo mtype mstatus flags extend mwith opens med jments positions) - -instance (Binary i) => Binary (ModuleType i) where - put MTAbstract = putWord8 0 - put MTResource = putWord8 2 - put (MTConcrete i) = putWord8 3 >> put i - put MTInterface = putWord8 4 - put (MTInstance i) = putWord8 5 >> put i - get = do tag <- getWord8 - case tag of - 0 -> return MTAbstract - 2 -> return MTResource - 3 -> get >>= return . MTConcrete - 4 -> return MTInterface - 5 -> get >>= return . MTInstance - _ -> decodingError - -instance (Binary i) => Binary (MInclude i) where - put MIAll = putWord8 0 - put (MIOnly xs) = putWord8 1 >> put xs - put (MIExcept xs) = putWord8 2 >> put xs - get = do tag <- getWord8 - case tag of - 0 -> return MIAll - 1 -> fmap MIOnly get - 2 -> fmap MIExcept get - _ -> decodingError - -instance Binary i => Binary (OpenSpec i) where - put (OSimple i) = putWord8 0 >> put i - put (OQualif i j) = putWord8 1 >> put (i,j) - get = do tag <- getWord8 - case tag of - 0 -> get >>= return . OSimple - 1 -> get >>= \(i,j) -> return (OQualif i j) - _ -> decodingError - -instance Binary ModuleStatus where - put MSComplete = putWord8 0 - put MSIncomplete = putWord8 1 - get = do tag <- getWord8 - case tag of - 0 -> return MSComplete - 1 -> return MSIncomplete - _ -> decodingError - -instance Binary Options where - put = put . optionsGFO - get = do opts <- get - case parseModuleOptions ["--" ++ flag ++ "=" ++ value | (flag,value) <- opts] of - Ok x -> return x - Bad msg -> fail msg - -instance Binary Info where - put (AbsCat x y) = putWord8 0 >> put (x,y) - put (AbsFun x y z) = putWord8 1 >> put (x,y,z) - put (ResParam x y) = putWord8 2 >> put (x,y) - put (ResValue x) = putWord8 3 >> put x - put (ResOper x y) = putWord8 4 >> put (x,y) - put (ResOverload x y)= putWord8 5 >> put (x,y) - put (CncCat x y z) = putWord8 6 >> put (x,y,z) - put (CncFun x y z) = putWord8 7 >> put (x,y,z) - put (AnyInd x y) = putWord8 8 >> put (x,y) - get = do tag <- getWord8 - case tag of - 0 -> get >>= \(x,y) -> return (AbsCat x y) - 1 -> get >>= \(x,y,z) -> return (AbsFun x y z) - 2 -> get >>= \(x,y) -> return (ResParam x y) - 3 -> get >>= \x -> return (ResValue x) - 4 -> get >>= \(x,y) -> return (ResOper x y) - 5 -> get >>= \(x,y) -> return (ResOverload x y) - 6 -> get >>= \(x,y,z) -> return (CncCat x y z) - 7 -> get >>= \(x,y,z) -> return (CncFun x y z) - 8 -> get >>= \(x,y) -> return (AnyInd x y) - _ -> decodingError - -instance Binary BindType where - put Explicit = putWord8 0 - put Implicit = putWord8 1 - get = do tag <- getWord8 - case tag of - 0 -> return Explicit - 1 -> return Implicit - _ -> decodingError - -instance Binary Term where - put (Vr x) = putWord8 0 >> put x - put (Cn x) = putWord8 1 >> put x - put (Con x) = putWord8 2 >> put x - put (Sort x) = putWord8 3 >> put x - put (EInt x) = putWord8 4 >> put x - put (EFloat x) = putWord8 5 >> put x - put (K x) = putWord8 6 >> put x - put (Empty) = putWord8 7 - put (App x y) = putWord8 8 >> put (x,y) - put (Abs x y z) = putWord8 9 >> put (x,y,z) - put (Meta x) = putWord8 10 >> put x - put (Prod w x y z)= putWord8 11 >> put (w,x,y,z) - put (Typed x y) = putWord8 12 >> put (x,y) - put (Example x y) = putWord8 13 >> put (x,y) - put (RecType x) = putWord8 14 >> put x - put (R x) = putWord8 15 >> put x - put (P x y) = putWord8 16 >> put (x,y) - put (ExtR x y) = putWord8 17 >> put (x,y) - put (Table x y) = putWord8 18 >> put (x,y) - put (T x y) = putWord8 19 >> put (x,y) - put (V x y) = putWord8 20 >> put (x,y) - put (S x y) = putWord8 21 >> put (x,y) - put (Let x y) = putWord8 22 >> put (x,y) - put (Q x y) = putWord8 23 >> put (x,y) - put (QC x y) = putWord8 24 >> put (x,y) - put (C x y) = putWord8 25 >> put (x,y) - put (Glue x y) = putWord8 26 >> put (x,y) - put (EPatt x) = putWord8 27 >> put x - put (EPattType x) = putWord8 28 >> put x - put (FV x) = putWord8 29 >> put x - put (Alts x) = putWord8 30 >> put x - put (Strs x) = putWord8 31 >> put x - put (ELin x y) = putWord8 32 >> put (x,y) - - get = do tag <- getWord8 - case tag of - 0 -> get >>= \x -> return (Vr x) - 1 -> get >>= \x -> return (Cn x) - 2 -> get >>= \x -> return (Con x) - 3 -> get >>= \x -> return (Sort x) - 4 -> get >>= \x -> return (EInt x) - 5 -> get >>= \x -> return (EFloat x) - 6 -> get >>= \x -> return (K x) - 7 -> return (Empty) - 8 -> get >>= \(x,y) -> return (App x y) - 9 -> get >>= \(x,y,z) -> return (Abs x y z) - 10 -> get >>= \x -> return (Meta x) - 11 -> get >>= \(w,x,y,z)->return (Prod w x y z) - 12 -> get >>= \(x,y) -> return (Typed x y) - 13 -> get >>= \(x,y) -> return (Example x y) - 14 -> get >>= \x -> return (RecType x) - 15 -> get >>= \x -> return (R x) - 16 -> get >>= \(x,y) -> return (P x y) - 17 -> get >>= \(x,y) -> return (ExtR x y) - 18 -> get >>= \(x,y) -> return (Table x y) - 19 -> get >>= \(x,y) -> return (T x y) - 20 -> get >>= \(x,y) -> return (V x y) - 21 -> get >>= \(x,y) -> return (S x y) - 22 -> get >>= \(x,y) -> return (Let x y) - 23 -> get >>= \(x,y) -> return (Q x y) - 24 -> get >>= \(x,y) -> return (QC x y) - 25 -> get >>= \(x,y) -> return (C x y) - 26 -> get >>= \(x,y) -> return (Glue x y) - 27 -> get >>= \x -> return (EPatt x) - 28 -> get >>= \x -> return (EPattType x) - 29 -> get >>= \x -> return (FV x) - 30 -> get >>= \x -> return (Alts x) - 31 -> get >>= \x -> return (Strs x) - 32 -> get >>= \(x,y) -> return (ELin x y) - _ -> decodingError - -instance Binary Patt where - put (PC x y) = putWord8 0 >> put (x,y) - put (PP x y z) = putWord8 1 >> put (x,y,z) - put (PV x) = putWord8 2 >> put x - put (PW) = putWord8 3 - put (PR x) = putWord8 4 >> put x - put (PString x) = putWord8 5 >> put x - put (PInt x) = putWord8 6 >> put x - put (PFloat x) = putWord8 7 >> put x - put (PT x y) = putWord8 8 >> put (x,y) - put (PAs x y) = putWord8 10 >> put (x,y) - put (PNeg x) = putWord8 11 >> put x - put (PAlt x y) = putWord8 12 >> put (x,y) - put (PSeq x y) = putWord8 13 >> put (x,y) - put (PRep x) = putWord8 14 >> put x - put (PChar) = putWord8 15 - put (PChars x) = putWord8 16 >> put x - put (PMacro x) = putWord8 17 >> put x - put (PM x y) = putWord8 18 >> put (x,y) - get = do tag <- getWord8 - case tag of - 0 -> get >>= \(x,y) -> return (PC x y) - 1 -> get >>= \(x,y,z) -> return (PP x y z) - 2 -> get >>= \x -> return (PV x) - 3 -> return (PW) - 4 -> get >>= \x -> return (PR x) - 5 -> get >>= \x -> return (PString x) - 6 -> get >>= \x -> return (PInt x) - 7 -> get >>= \x -> return (PFloat x) - 8 -> get >>= \(x,y) -> return (PT x y) - 10 -> get >>= \(x,y) -> return (PAs x y) - 11 -> get >>= \x -> return (PNeg x) - 12 -> get >>= \(x,y) -> return (PAlt x y) - 13 -> get >>= \(x,y) -> return (PSeq x y) - 14 -> get >>= \x -> return (PRep x) - 15 -> return (PChar) - 16 -> get >>= \x -> return (PChars x) - 17 -> get >>= \x -> return (PMacro x) - 18 -> get >>= \(x,y) -> return (PM x y) - _ -> decodingError - -instance Binary TInfo where - put TRaw = putWord8 0 - put (TTyped t) = putWord8 1 >> put t - put (TComp t) = putWord8 2 >> put t - put (TWild t) = putWord8 3 >> put t - get = do tag <- getWord8 - case tag of - 0 -> return TRaw - 1 -> fmap TTyped get - 2 -> fmap TComp get - 3 -> fmap TWild get - _ -> decodingError - -instance Binary Label where - put (LIdent bs) = putWord8 0 >> put bs - put (LVar i) = putWord8 1 >> put i - get = do tag <- getWord8 - case tag of - 0 -> fmap LIdent get - 1 -> fmap LVar get - _ -> decodingError - -decodeModHeader :: FilePath -> IO SourceModule -decodeModHeader fpath = do - (m,mtype,mstatus,flags,extend,mwith,opens,med) <- decodeFile fpath - return (m,ModInfo mtype mstatus flags extend mwith opens med Map.empty Map.empty) - -decodingError = fail "This GFO file was compiled with different version of GF" diff --git a/src/GF/Grammar/CF.hs b/src/GF/Grammar/CF.hs deleted file mode 100644 index a1d716994..000000000 --- a/src/GF/Grammar/CF.hs +++ /dev/null @@ -1,128 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/15 17:56:13 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.13 $ --- --- parsing CF grammars and converting them to GF ------------------------------------------------------------------------------ - -module GF.Grammar.CF (getCF) where - -import GF.Grammar.Grammar -import GF.Grammar.Macros -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Infra.Option - -import GF.Data.Operations - -import Data.Char -import Data.List -import qualified Data.ByteString.Char8 as BS - -getCF :: String -> String -> Err SourceGrammar -getCF name = fmap (cf2gf name) . pCF - ---------------------- --- the parser ------- ---------------------- - -pCF :: String -> Err CF -pCF s = do - rules <- mapM getCFRule $ filter isRule $ lines s - return $ concat rules - where - isRule line = case dropWhile isSpace line of - '-':'-':_ -> False - _ -> not $ all isSpace line - --- 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 -> Err [CFRule] -getCFRule s = getcf (wrds s) where - getcf ws = case ws of - fun : cat : a : its | isArrow a -> - Ok [(init fun, (cat, map mkIt its))] - cat : a : its | isArrow a -> - Ok [(mkFun cat it, (cat, map mkIt it)) | it <- chunk its] - _ -> Bad (" invalid rule:" +++ s) - isArrow a = elem a ["->", "::="] - mkIt w = case w of - ('"':w@(_:_)) -> Right (init w) - _ -> Left 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 - -type CF = [CFRule] - -type CFRule = (CFFun, (CFCat, [CFItem])) - -type CFItem = Either CFCat String - -type CFCat = String -type CFFun = String - --------------------------- --- the compiler ---------- --------------------------- - -cf2gf :: String -> CF -> SourceGrammar -cf2gf name cf = MGrammar [ - (aname, addFlag (modifyFlags (\fs -> fs{optStartCat = Just cat})) - (emptyModInfo{mtype = MTAbstract, jments = abs})), - (cname, emptyModInfo{mtype = MTConcrete aname, jments = cnc}) - ] - where - (abs,cnc,cat) = cf2grammar cf - aname = identS $ name ++ "Abs" - cname = identS name - - -cf2grammar :: CF -> (BinTree Ident Info, BinTree Ident Info, String) -cf2grammar rules = (buildTree abs, buildTree conc, cat) where - abs = cats ++ funs - conc = lincats ++ lins - cat = case rules of - (_,(c,_)):_ -> c -- the value category of the first rule - _ -> error "empty CF" - cats = [(cat, AbsCat (Just []) (Just [])) | - cat <- nub (concat (map cf2cat rules))] ----notPredef cat - lincats = [(cat, CncCat (Just defLinType) Nothing Nothing) | (cat,AbsCat _ _) <- cats] - (funs,lins) = unzip (map cf2rule rules) - -cf2cat :: CFRule -> [Ident] -cf2cat (_,(cat, items)) = map identS $ cat : [c | Left c <- items] - -cf2rule :: CFRule -> ((Ident,Info),(Ident,Info)) -cf2rule (fun, (cat, items)) = (def,ldef) where - f = identS fun - def = (f, AbsFun (Just (mkProd args' (Cn (identS cat)) [])) Nothing Nothing) - args0 = zip (map (identS . ("x" ++) . show) [0..]) items - args = [((Explicit,v), Cn (identS c)) | (v, Left c) <- args0] - args' = [(Explicit,identS "_", Cn (identS c)) | (_, Left c) <- args0] - ldef = (f, CncFun - Nothing - (Just (mkAbs (map fst args) - (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)]))) - Nothing) - mkIt (v, Left _) = P (Vr v) theLinLabel - mkIt (_, Right a) = K a - foldconcat [] = K "" - foldconcat tt = foldr1 C tt - -identS = identC . BS.pack - diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs deleted file mode 100644 index 8d1468d9d..000000000 --- a/src/GF/Grammar/Grammar.hs +++ /dev/null @@ -1,230 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Grammar --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:20 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- GF source abstract syntax used internally in compilation. --- --- AR 23\/1\/2000 -- 30\/5\/2001 -- 4\/5\/2003 ------------------------------------------------------------------------------ - -module GF.Grammar.Grammar (SourceGrammar, - emptySourceGrammar, - SourceModInfo, - SourceModule, - mapSourceModule, - Info(..), - Type, - Cat, - Fun, - QIdent, - BindType(..), - Term(..), - Patt(..), - TInfo(..), - Label(..), - MetaId, - Hypo, - Context, - Equation, - Labelling, - Assign, - Case, - LocalDef, - Param, - Altern, - Substitution, - varLabel, tupleLabel, linLabel, theLinLabel, - ident2label, label2ident - ) where - -import GF.Infra.Ident -import GF.Infra.Option --- -import GF.Infra.Modules - -import GF.Data.Operations - -import qualified Data.ByteString.Char8 as BS - --- | grammar as presented to the compiler -type SourceGrammar = MGrammar Ident Info - -emptySourceGrammar = MGrammar [] - -type SourceModInfo = ModInfo Ident Info - -type SourceModule = (Ident, SourceModInfo) - -mapSourceModule :: (SourceModInfo -> SourceModInfo) -> (SourceModule -> SourceModule) -mapSourceModule f (i,mi) = (i, f mi) - --- | 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 (Maybe Context) (Maybe [Term]) -- ^ (/ABS/) the second parameter is list of constructors - must be 'Id' or 'QId' - | AbsFun (Maybe Type) (Maybe Int) (Maybe [Equation]) -- ^ (/ABS/) type, arrity and definition of function - --- judgements in resource - | ResParam (Maybe [Param]) (Maybe [Term]) -- ^ (/RES/) the second parameter is list of all possible values - | ResValue Type -- ^ (/RES/) to mark parameter constructors for lookup - | ResOper (Maybe Type) (Maybe Term) -- ^ (/RES/) - - | ResOverload [Ident] [(Type,Term)] -- ^ (/RES/) idents: modules inherited - --- judgements in concrete syntax - | CncCat (Maybe Type) (Maybe Term) (Maybe Term) -- ^ (/CNC/) lindef ini'zed, - | CncFun (Maybe (Ident,Context,Type)) (Maybe Term) (Maybe Term) -- ^ (/CNC/) type info added at 'TC' - --- indirection to module Ident - | AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical - deriving Show - -type Type = Term -type Cat = QIdent -type Fun = QIdent - -type QIdent = (Ident,Ident) - -data BindType = - Explicit - | Implicit - deriving (Eq,Ord,Show) - -data Term = - Vr Ident -- ^ variable - | Cn Ident -- ^ constant - | Con Ident -- ^ constructor - | Sort Ident -- ^ 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 BindType Ident Term -- ^ abstraction: @\x -> b@ - | Meta {-# UNPACK #-} !MetaId -- ^ metavariable: @?i@ (only parsable: ? = ?0) - | ImplArg Term -- ^ placeholder for implicit argument @{t}@ - | Prod BindType Ident Term Term -- ^ function type: @(x : A) -> B@, @A -> B@, @({x} : A) -> B@ - | 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@ - | 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] -- ^ table given as course of values: @table T [c1 ; ... ; cn]@ - | S Term Term -- ^ selection: @t ! p@ - - | Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@ - - | 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 - - | ELincat Ident Term -- ^ boxed linearization type of Ident - | ELin Ident Term -- ^ boxed linearization of type Ident - - | 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 ; ...}@ - - deriving (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 - - | PAs Ident Patt -- ^ as-pattern: x@p - - | PImplArg Patt -- ^ placeholder for pattern for implicit argument @{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 (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 (Show, Eq, Ord) - --- | record label -data Label = - LIdent BS.ByteString - | LVar Int - deriving (Show, Eq, Ord) - -type MetaId = Int - -type Hypo = (BindType,Ident,Term) -- (x:A) (_:A) A ({x}:A) -type Context = [Hypo] -- (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)] - -varLabel :: Int -> Label -varLabel = LVar - -tupleLabel, linLabel :: Int -> Label -tupleLabel i = LIdent $! BS.pack ('p':show i) -linLabel i = LIdent $! BS.pack ('s':show i) - -theLinLabel :: Label -theLinLabel = LIdent (BS.singleton 's') - -ident2label :: Ident -> Label -ident2label c = LIdent (ident2bs c) - -label2ident :: Label -> Ident -label2ident (LIdent s) = identC s -label2ident (LVar i) = identC (BS.pack ('$':show i)) diff --git a/src/GF/Grammar/Lexer.hs b/src/GF/Grammar/Lexer.hs deleted file mode 100644 index 7cacb0588..000000000 --- a/src/GF/Grammar/Lexer.hs +++ /dev/null @@ -1,478 +0,0 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# LINE 3 "src\GF\Grammar\Lexer.x" #-} - -module GF.Grammar.Lexer - ( Token(..), Posn(..) - , P, runP, lexer, getPosn, failLoc - , isReservedWord - ) where - -import GF.Infra.Ident -import GF.Data.Operations -import qualified Data.ByteString.Char8 as BS -import qualified Data.Map as Map - - -#if __GLASGOW_HASKELL__ >= 603 -#include "ghcconfig.h" -#elif defined(__GLASGOW_HASKELL__) -#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\xf5\xff\xff\xff\x16\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x2e\x00\x00\x00\x6c\x01\x00\x00\x3c\x02\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\x15\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\x12\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\x14\x00\x0e\x00\x14\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x11\x00\x0e\x00\xff\xff\x13\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\x18\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\x00\x00\x00\x00\xff\xff\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\x1b\x00\xff\xff\x00\x00\x00\x00\x18\x00\x1b\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\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\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\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\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\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\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\x5c\x00\x2b\x00\x27\x00\x3e\x00\x27\x00\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\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00"# - -alex_deflt :: AlexAddr -alex_deflt = AlexA# "\x17\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\x16\x00\x16\x00\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_3))],[(AlexAcc (alex_action_4))],[],[],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))],[],[],[],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_8))],[],[],[]] -{-# LINE 42 "src\GF\Grammar\Lexer.x" #-} - - -tok f p s = f s - -data Token - = T_exclmark - | T_patt - | T_int_label - | T_oparen - | T_cparen - | T_star - | T_starstar - | T_plus - | T_plusplus - | T_comma - | T_minus - | T_rarrow - | T_dot - | T_alt - | T_colon - | T_semicolon - | T_less - | T_equal - | T_big_rarrow - | T_great - | T_questmark - | T_obrack - | T_lam - | T_lamlam - | T_cbrack - | T_ocurly - | T_bar - | T_ccurly - | T_underscore - | T_at - | T_PType - | T_Str - | T_Strs - | T_Tok - | T_Type - | T_abstract - | T_case - | T_cat - | T_concrete - | T_data - | T_def - | T_flags - | T_fn - | T_fun - | T_in - | T_incomplete - | T_instance - | T_interface - | T_let - | T_lin - | T_lincat - | T_lindef - | T_of - | T_open - | T_oper - | T_param - | T_pattern - | T_pre - | T_printname - | T_resource - | T_strs - | T_table - | T_transfer - | T_variants - | T_where - | T_with - | T_String String -- string literals - | T_Integer Integer -- integer literals - | T_Double Double -- double precision float literals - | T_LString String - | T_Ident Ident - | T_EOF - -eitherResIdent :: (BS.ByteString -> Token) -> BS.ByteString -> Token -eitherResIdent tv s = - case Map.lookup s resWords of - Just t -> t - Nothing -> tv s - -isReservedWord :: BS.ByteString -> Bool -isReservedWord s = Map.member s resWords - -resWords = Map.fromList - [ b "!" T_exclmark - , b "#" T_patt - , b "$" T_int_label - , b "(" T_oparen - , b ")" T_cparen - , b "*" T_star - , b "**" T_starstar - , b "+" T_plus - , b "++" T_plusplus - , b "," T_comma - , b "-" T_minus - , b "->" T_rarrow - , b "." T_dot - , b "/" T_alt - , b ":" T_colon - , b ";" T_semicolon - , b "<" T_less - , b "=" T_equal - , b "=>" T_big_rarrow - , b ">" T_great - , b "?" T_questmark - , b "[" T_obrack - , b "]" T_cbrack - , b "\\" T_lam - , b "\\\\" T_lamlam - , b "{" T_ocurly - , b "}" T_ccurly - , b "|" T_bar - , b "_" T_underscore - , b "@" T_at - , b "PType" T_PType - , b "Str" T_Str - , b "Strs" T_Strs - , b "Tok" T_Tok - , b "Type" T_Type - , b "abstract" T_abstract - , b "case" T_case - , b "cat" T_cat - , b "concrete" T_concrete - , b "data" T_data - , b "def" T_def - , b "flags" T_flags - , b "fn" T_fn - , b "fun" T_fun - , b "in" T_in - , b "incomplete" T_incomplete - , b "instance" T_instance - , b "interface" T_interface - , b "let" T_let - , b "lin" T_lin - , b "lincat" T_lincat - , b "lindef" T_lindef - , b "of" T_of - , b "open" T_open - , b "oper" T_oper - , b "param" T_param - , b "pattern" T_pattern - , b "pre" T_pre - , b "printname" T_printname - , b "resource" T_resource - , b "strs" T_strs - , b "table" T_table - , b "transfer" T_transfer - , b "variants" T_variants - , b "where" T_where - , b "with" T_with - ] - where b s t = (BS.pack s, t) - -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 {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - -alexMove :: Posn -> Char -> Posn -alexMove (Pn l c) '\n' = Pn (l+1) 1 -alexMove (Pn l c) _ = Pn l (c+1) - -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (AI p _ s) = - case BS.uncons s of - Nothing -> Nothing - Just (c,s) -> - let p' = alexMove p c - in p' `seq` Just (c, (AI p' c s)) - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (AI p c s) = c - -data AlexInput = AI {-# UNPACK #-} !Posn -- current position, - {-# UNPACK #-} !Char -- previous char - {-# UNPACK #-} !BS.ByteString -- current input string - -data ParseResult a - = POk AlexInput a - | PFailed Posn -- The position of the error - String -- The error message - -newtype P a = P { unP :: AlexInput -> ParseResult a } - -instance Monad P where - return a = a `seq` (P $ \s -> POk s a) - (P m) >>= k = P $ \ s -> case m s of - POk s1 a -> unP (k a) s1 - PFailed posn err -> PFailed posn err - fail msg = P $ \(AI posn _ _) -> PFailed posn msg - -runP :: P a -> BS.ByteString -> Either (Posn,String) a -runP (P f) txt = - case f (AI (Pn 1 0) ' ' txt) of - POk _ x -> Right x - PFailed pos msg -> Left (pos,msg) - -failLoc :: Posn -> String -> P a -failLoc pos msg = P $ \_ -> PFailed pos msg - -lexer :: (Token -> P a) -> P a -lexer cont = P go - where - go inp@(AI pos _ str) = - case alexScan inp 0 of - AlexEOF -> unP (cont T_EOF) inp - AlexError (AI pos _ _) -> PFailed pos "lexical error" - AlexSkip inp' len -> go inp' - AlexToken inp' len act -> unP (cont (act pos (BS.take len str))) inp' - -getPosn :: P Posn -getPosn = P $ \inp@(AI pos _ _) -> POk inp pos - - -alex_action_3 = tok (eitherResIdent (T_Ident . identC)) -alex_action_4 = tok (eitherResIdent (T_LString . BS.unpack)) -alex_action_5 = tok (eitherResIdent (T_Ident . identC)) -alex_action_6 = tok (T_String . unescapeInitTail . BS.unpack) -alex_action_7 = tok (T_Integer . read . BS.unpack) -alex_action_8 = tok (T_Double . read . BS.unpack) -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "templates/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 "templates/GenericTemplate.hs" #-} - -{-# LINE 45 "templates/GenericTemplate.hs" #-} - - -data AlexAddr = AlexA# Addr# - -#if __GLASGOW_HASKELL__ < 503 -uncheckedShiftL# = shiftL# -#endif - -{-# INLINE alexIndexInt16OffAddr #-} -alexIndexInt16OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow16Int# i - where - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# -#else - indexInt16OffAddr# arr off -#endif - - - - - -{-# INLINE alexIndexInt32OffAddr #-} -alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow32Int# i - where - i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` - (b2 `uncheckedShiftL#` 16#) `or#` - (b1 `uncheckedShiftL#` 8#) `or#` b0) - b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) - b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) - b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - b0 = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 4# -#else - indexInt32OffAddr# arr off -#endif - - - - - -#if __GLASGOW_HASKELL__ < 503 -quickIndex arr i = arr ! i -#else --- GHC >= 503, unsafeAt is available from Data.Array.Base. -quickIndex = unsafeAt -#endif - - - - --- ----------------------------------------------------------------------------- --- Main lexing routines - -data AlexReturn a - = AlexEOF - | AlexError !AlexInput - | AlexSkip !AlexInput !Int - | AlexToken !AlexInput !Int a - --- alexScan :: AlexInput -> StartCode -> AlexReturn a -alexScan input (I# (sc)) - = alexScanUser undefined input (I# (sc)) - -alexScanUser user input (I# (sc)) - = case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, input') -> - case alexGetChar input of - Nothing -> - - - - AlexEOF - Just _ -> - - - - AlexError input' - - (AlexLastSkip input len, _) -> - - - - AlexSkip input len - - (AlexLastAcc k input len, _) -> - - - - AlexToken input len k - - --- Push the input through the DFA, remembering the most recent accepting --- state it encountered. - -alex_scan_tkn user orig_input len input s last_acc = - input `seq` -- strict in the input - let - new_acc = check_accs (alex_accept `quickIndex` (I# (s))) - in - new_acc `seq` - case alexGetChar input of - Nothing -> (new_acc, input) - Just (c, new_input) -> - - - - let - base = alexIndexInt32OffAddr alex_base s - (I# (ord_c)) = ord c - offset = (base +# ord_c) - check = alexIndexInt16OffAddr alex_check offset - - new_s = if (offset >=# 0#) && (check ==# ord_c) - then alexIndexInt16OffAddr alex_table offset - else alexIndexInt16OffAddr alex_deflt s - in - case new_s of - -1# -> (new_acc, input) - -- on an error, we want to keep the input *before* the - -- character that failed, not after. - _ -> alex_scan_tkn user orig_input (len +# 1#) - new_input new_s new_acc - - where - check_accs [] = last_acc - check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) - check_accs (AlexAccPred a pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkipPred pred : rest) - | pred user orig_input (I# (len)) input - = AlexLastSkip input (I# (len)) - check_accs (_ : rest) = check_accs rest - -data AlexLastAcc a - = AlexNone - | AlexLastAcc a !AlexInput !Int - | AlexLastSkip !AlexInput !Int - -data AlexAcc a user - = AlexAcc a - | AlexAccSkip - | AlexAccPred a (AlexAccPred user) - | AlexAccSkipPred (AlexAccPred user) - -type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool - --- ----------------------------------------------------------------------------- --- Predicates on a rule - -alexAndPred p1 p2 user in1 len in2 - = p1 user in1 len in2 && p2 user in1 len in2 - ---alexPrevCharIsPred :: Char -> AlexAccPred _ -alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input - ---alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ -alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input - ---alexRightContext :: Int -> AlexAccPred _ -alexRightContext (I# (sc)) user _ _ input = - case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, _) -> False - _ -> True - -- TODO: there's no need to find the longest - -- match when checking the right context, just - -- the first match will do. - --- used by wrappers -iUnbox (I# (i)) = i diff --git a/src/GF/Grammar/Lexer.x b/src/GF/Grammar/Lexer.x deleted file mode 100644 index d6f49bbb1..000000000 --- a/src/GF/Grammar/Lexer.x +++ /dev/null @@ -1,272 +0,0 @@ --- -*- haskell -*- --- This Alex file was machine-generated by the BNF converter -{ -module GF.Grammar.Lexer - ( Token(..), Posn(..) - , P, runP, lexer, getPosn, failLoc - , isReservedWord - ) where - -import GF.Infra.Ident -import GF.Data.Operations -import qualified Data.ByteString.Char8 as BS -import qualified Data.Map as Map - -} - - -$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 - \; | \= | \{ | \} | \( | \) | \* \* | \: | \- \> | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \# | \! | \* | \+ | \+ \+ | \\ | \\\\ | \= \> | \_ | \$ | \/ - -:- -"--" [.]* ; -- Toss single line comments -"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ; - -$white+ ; -@rsyms { tok (eitherResIdent (T_Ident . identC)) } -\' ($u # \')* \' { tok (eitherResIdent (T_LString . BS.unpack)) } -(\_ | $l)($l | $d | \_ | \')* { tok (eitherResIdent (T_Ident . identC)) } - -\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \" { tok (T_String . unescapeInitTail . BS.unpack) } - -$d+ { tok (T_Integer . read . BS.unpack) } -$d+ \. $d+ (e (\-)? $d+)? { tok (T_Double . read . BS.unpack) } - -{ - -tok f p s = f s - -data Token - = T_exclmark - | T_patt - | T_int_label - | T_oparen - | T_cparen - | T_star - | T_starstar - | T_plus - | T_plusplus - | T_comma - | T_minus - | T_rarrow - | T_dot - | T_alt - | T_colon - | T_semicolon - | T_less - | T_equal - | T_big_rarrow - | T_great - | T_questmark - | T_obrack - | T_lam - | T_lamlam - | T_cbrack - | T_ocurly - | T_bar - | T_ccurly - | T_underscore - | T_at - | T_PType - | T_Str - | T_Strs - | T_Tok - | T_Type - | T_abstract - | T_case - | T_cat - | T_concrete - | T_data - | T_def - | T_flags - | T_fn - | T_fun - | T_in - | T_incomplete - | T_instance - | T_interface - | T_let - | T_lin - | T_lincat - | T_lindef - | T_of - | T_open - | T_oper - | T_param - | T_pattern - | T_pre - | T_printname - | T_resource - | T_strs - | T_table - | T_transfer - | T_variants - | T_where - | T_with - | T_String String -- string literals - | T_Integer Integer -- integer literals - | T_Double Double -- double precision float literals - | T_LString String - | T_Ident Ident - | T_EOF - -eitherResIdent :: (BS.ByteString -> Token) -> BS.ByteString -> Token -eitherResIdent tv s = - case Map.lookup s resWords of - Just t -> t - Nothing -> tv s - -isReservedWord :: BS.ByteString -> Bool -isReservedWord s = Map.member s resWords - -resWords = Map.fromList - [ b "!" T_exclmark - , b "#" T_patt - , b "$" T_int_label - , b "(" T_oparen - , b ")" T_cparen - , b "*" T_star - , b "**" T_starstar - , b "+" T_plus - , b "++" T_plusplus - , b "," T_comma - , b "-" T_minus - , b "->" T_rarrow - , b "." T_dot - , b "/" T_alt - , b ":" T_colon - , b ";" T_semicolon - , b "<" T_less - , b "=" T_equal - , b "=>" T_big_rarrow - , b ">" T_great - , b "?" T_questmark - , b "[" T_obrack - , b "]" T_cbrack - , b "\\" T_lam - , b "\\\\" T_lamlam - , b "{" T_ocurly - , b "}" T_ccurly - , b "|" T_bar - , b "_" T_underscore - , b "@" T_at - , b "PType" T_PType - , b "Str" T_Str - , b "Strs" T_Strs - , b "Tok" T_Tok - , b "Type" T_Type - , b "abstract" T_abstract - , b "case" T_case - , b "cat" T_cat - , b "concrete" T_concrete - , b "data" T_data - , b "def" T_def - , b "flags" T_flags - , b "fn" T_fn - , b "fun" T_fun - , b "in" T_in - , b "incomplete" T_incomplete - , b "instance" T_instance - , b "interface" T_interface - , b "let" T_let - , b "lin" T_lin - , b "lincat" T_lincat - , b "lindef" T_lindef - , b "of" T_of - , b "open" T_open - , b "oper" T_oper - , b "param" T_param - , b "pattern" T_pattern - , b "pre" T_pre - , b "printname" T_printname - , b "resource" T_resource - , b "strs" T_strs - , b "table" T_table - , b "transfer" T_transfer - , b "variants" T_variants - , b "where" T_where - , b "with" T_with - ] - where b s t = (BS.pack s, t) - -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 {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - -alexMove :: Posn -> Char -> Posn -alexMove (Pn l c) '\n' = Pn (l+1) 1 -alexMove (Pn l c) _ = Pn l (c+1) - -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (AI p _ s) = - case BS.uncons s of - Nothing -> Nothing - Just (c,s) -> - let p' = alexMove p c - in p' `seq` Just (c, (AI p' c s)) - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (AI p c s) = c - -data AlexInput = AI {-# UNPACK #-} !Posn -- current position, - {-# UNPACK #-} !Char -- previous char - {-# UNPACK #-} !BS.ByteString -- current input string - -data ParseResult a - = POk a - | PFailed Posn -- The position of the error - String -- The error message - -newtype P a = P { unP :: AlexInput -> ParseResult a } - -instance Monad P where - return a = a `seq` (P $ \s -> POk a) - (P m) >>= k = P $ \ s -> case m s of - POk a -> unP (k a) s - PFailed posn err -> PFailed posn err - fail msg = P $ \(AI posn _ _) -> PFailed posn msg - -runP :: P a -> BS.ByteString -> Either (Posn,String) a -runP (P f) txt = - case f (AI (Pn 1 0) ' ' txt) of - POk x -> Right x - PFailed pos msg -> Left (pos,msg) - -failLoc :: Posn -> String -> P a -failLoc pos msg = P $ \_ -> PFailed pos msg - -lexer :: (Token -> P a) -> P a -lexer cont = P go - where - go inp@(AI pos _ str) = - case alexScan inp 0 of - AlexEOF -> unP (cont T_EOF) inp - AlexError (AI pos _ _) -> PFailed pos "lexical error" - AlexSkip inp' len -> go inp' - AlexToken inp' len act -> unP (cont (act pos (BS.take len str))) inp' - -getPosn :: P Posn -getPosn = P $ \inp@(AI pos _ _) -> POk pos - -} diff --git a/src/GF/Grammar/Lockfield.hs b/src/GF/Grammar/Lockfield.hs deleted file mode 100644 index 3e78a48b6..000000000 --- a/src/GF/Grammar/Lockfield.hs +++ /dev/null @@ -1,52 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Lockfield --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 23:24:34 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.7 $ --- --- Creating and using lock fields in reused resource grammars. --- --- AR 8\/2\/2005 detached from 'compile/MkResource' ------------------------------------------------------------------------------ - -module GF.Grammar.Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where - -import qualified Data.ByteString.Char8 as BS - -import GF.Infra.Ident -import GF.Grammar.Grammar -import GF.Grammar.Macros - -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 (showIdent 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 - let lock = R [(lockLabel c, (Just (RecType []),R []))] - case plusRecord t lock of - Ok t' -> return $ mkAbs xs t' - _ -> return $ mkAbs xs (ExtR t lock) - -lockLabel :: Ident -> Label -lockLabel c = LIdent $! BS.append lockPrefix (ident2bs c) - -isLockLabel :: Label -> Bool -isLockLabel l = case l of - LIdent c -> BS.isPrefixOf lockPrefix c - _ -> False - - -lockPrefix = BS.pack "lock_" diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs deleted file mode 100644 index 074f0c5ec..000000000 --- a/src/GF/Grammar/Lookup.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE PatternGuards #-} ----------------------------------------------------------------------- --- | --- 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 ( - lookupIdent, - lookupIdentInfo, - lookupOrigInfo, - allOrigInfos, - lookupResDef, - lookupResType, - lookupOverload, - lookupParamValues, - allParamValues, - lookupAbsDef, - lookupLincat, - lookupFunType, - lookupCatContext - ) where - -import GF.Data.Operations -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Grammar.Macros -import GF.Grammar.Grammar -import GF.Grammar.Printer -import GF.Grammar.Predef -import GF.Grammar.Lockfield - -import Data.List (nub,sortBy) -import Control.Monad -import Text.PrettyPrint - --- whether lock fields are added in reuse -lock c = lockRecType c -- return -unlock c = unlockRecord c -- return - --- to look up a constant etc in a search tree --- why here? AR 29/5/2008 -lookupIdent :: Ident -> BinTree Ident b -> Err b -lookupIdent c t = - case lookupTree showIdent c t of - Ok v -> return v - Bad _ -> Bad ("unknown identifier" +++ showIdent c) - -lookupIdentInfo :: ModInfo Ident a -> Ident -> Err a -lookupIdentInfo mo i = lookupIdent i (jments mo) - -lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term -lookupResDef gr m c - | isPredefCat c = lock c defLinType - | otherwise = look m c - where - look m c = do - mo <- lookupModule gr m - info <- lookupIdentInfo mo c - case info of - ResOper _ (Just t) -> return t - ResOper _ Nothing -> return (Q m c) - CncCat (Just ty) _ _ -> lock c ty - CncCat _ _ _ -> lock c defLinType - - CncFun (Just (cat,_,_)) (Just tr) _ -> unlock cat tr - CncFun _ (Just tr) _ -> return tr - - AnyInd _ n -> look n c - ResParam _ _ -> return (QC m c) - ResValue _ -> return (QC m c) - _ -> Bad $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m) - -lookupResType :: SourceGrammar -> Ident -> Ident -> Err Type -lookupResType gr m c = do - mo <- lookupModule gr m - info <- lookupIdentInfo mo c - case info of - ResOper (Just t) _ -> return t - - -- used in reused concrete - CncCat _ _ _ -> return typeType - CncFun (Just (cat,cont,val)) _ _ -> do - val' <- lock cat val - return $ mkProd cont val' [] - AnyInd _ n -> lookupResType gr n c - ResParam _ _ -> return typePType - ResValue t -> return t - _ -> Bad $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m) - -lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))] -lookupOverload gr m c = do - mo <- lookupModule gr m - info <- lookupIdentInfo mo c - case info of - ResOverload os tysts -> do - tss <- mapM (\x -> lookupOverload gr x c) os - return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) | - (ty,tr) <- tysts] ++ - concat tss - - AnyInd _ n -> lookupOverload gr n c - _ -> Bad $ render (ppIdent c <+> text "is not an overloaded operation") - --- | returns the original 'Info' and the module where it was found -lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err (Ident,Info) -lookupOrigInfo gr m c = do - mo <- lookupModule gr m - info <- lookupIdentInfo mo c - case info of - AnyInd _ n -> lookupOrigInfo gr n c - i -> return (m,i) - -allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)] -allOrigInfos gr m = errVal [] $ do - mo <- lookupModule gr m - return [(c,i) | (c,_) <- tree2list (jments mo), Ok (_,i) <- [look c]] - where - look = lookupOrigInfo gr m - -lookupParamValues :: SourceGrammar -> Ident -> Ident -> Err [Term] -lookupParamValues gr m c = do - (_,info) <- lookupOrigInfo gr m c - case info of - ResParam _ (Just pvs) -> return pvs - _ -> Bad $ render (ppIdent c <+> text "has no parameter values defined in resource" <+> ppIdent m) - -allParamValues :: SourceGrammar -> Type -> Err [Term] -allParamValues cnc ptyp = case ptyp of - _ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]] - QC p c -> lookupParamValues cnc p c - Q p c -> lookupResDef cnc p c >>= allParamValues cnc - RecType r -> do - let (ls,tys) = unzip $ sortByFst r - tss <- mapM (allParamValues cnc) tys - return [R (zipAssign ls ts) | ts <- combinations tss] - _ -> Bad (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp)) - where - -- to normalize records and record types - sortByFst = sortBy (\ x y -> compare (fst x) (fst y)) - -lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Int,Maybe [Equation]) -lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) $ do - mo <- lookupModule gr m - info <- lookupIdentInfo mo c - case info of - AbsFun _ a d -> return (a,d) - AnyInd _ n -> lookupAbsDef gr n c - _ -> return (Nothing,Nothing) - -lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type -lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed? -lookupLincat gr m c = do - mo <- lookupModule gr m - info <- lookupIdentInfo mo c - case info of - CncCat (Just t) _ _ -> return t - AnyInd _ n -> lookupLincat gr n c - _ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m)) - --- | this is needed at compile time -lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type -lookupFunType gr m c = do - mo <- lookupModule gr m - info <- lookupIdentInfo mo c - case info of - AbsFun (Just t) _ _ -> return t - AnyInd _ n -> lookupFunType gr n c - _ -> Bad (render (text "cannot find type of" <+> ppIdent c)) - --- | this is needed at compile time -lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context -lookupCatContext gr m c = do - mo <- lookupModule gr m - info <- lookupIdentInfo mo c - case info of - AbsCat (Just co) _ -> return co - AnyInd _ n -> lookupCatContext gr n c - _ -> Bad (render (text "unknown category" <+> ppIdent c)) diff --git a/src/GF/Grammar/MMacros.hs b/src/GF/Grammar/MMacros.hs deleted file mode 100644 index a7f746b66..000000000 --- a/src/GF/Grammar/MMacros.hs +++ /dev/null @@ -1,279 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : MMacros --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/10 12:49:13 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.9 $ --- --- some more abstractions on grammars, esp. for Edit ------------------------------------------------------------------------------ - -module GF.Grammar.MMacros where - -import GF.Data.Operations ---import GF.Data.Zipper - -import GF.Grammar.Grammar -import GF.Grammar.Printer -import GF.Infra.Ident -import GF.Compile.Refresh -import GF.Grammar.Values -----import GrammarST -import GF.Grammar.Macros - -import Control.Monad -import qualified Data.ByteString.Char8 as BS -import Text.PrettyPrint - -{- -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) - -metasTree :: Tree -> [MetaId] -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 --} - -type Var = Ident - -uVal :: Val -uVal = vClos uExp - -vClos :: Exp -> Val -vClos = VClos [] - -uExp :: Exp -uExp = Meta meta0 - -mExp, mExp0 :: Exp -mExp = Meta meta0 -mExp0 = mExp - -meta2exp :: MetaId -> 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 - -atomIsMeta :: Atom -> Bool -atomIsMeta atom = case atom of - AtM _ -> True - _ -> False - -getMetaAtom :: Atom -> Err MetaId -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 (uncurry Q cat) [Meta i | i <- [1..length cont]] - -val2cat :: Val -> Err Cat -val2cat v = liftM valCat (val2exp v) - -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 b x t -> let y = mkFreshVarX ss x in - Abs b y (substTerm (y:ss) ((x, Vr y):g) t) - Prod b x a t -> let y = mkFreshVarX ss x in - Prod b y (substTerm ss g a) (substTerm (y:ss) ((x,Vr y):g) t) - _ -> c - -metaSubstExp :: MetaSubst -> [(MetaId,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 Bad (render (text "unsafe value substitution" <+> ppValue Unqualified 0 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 $ uncurry Q c - VGen i x -> if safe - then Bad (render (text "unsafe val2exp" <+> ppValue Unqualified 0 v)) - else return $ Vr $ x --- in editing, no alpha conversions presentv - VRecType xs->do xs <- mapM (\(l,v) -> val2expP safe v >>= \e -> return (l,e)) xs - return (RecType xs) - VType -> return typeType - 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 Explicit)) 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 - -int2var :: Int -> Ident -int2var = identC . BS.pack . ('$':) . show - -meta0 :: MetaId -meta0 = 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 b x t -> let x' = chV x in Abs b x' $ qualif (x':xs) t - Prod b x a t -> Prod b x (qualif xs a) $ qualif (x:xs) t - 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 $ ident2bs x - -string2var :: BS.ByteString -> Ident -string2var s = case BS.unpack s of - c:'_':i -> identV (BS.singleton c) (readIntArg i) --- - _ -> identC 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 b x t -> let x' = ind x d in Abs b x' $ qualif (d+1, (x,x'):g) t - Prod b x a t -> let x' = ind x d in Prod b x' (qualif dg a) $ qualif (d+1, (x,x'):g) t - 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 $ ident2bs x `BS.append` BS.singleton '_' `BS.append` BS.pack (show d) - -{- --- this method works for context-free abstract syntax --- and is meant to be used in simple embedded GF applications - -exp2tree :: Exp -> Err Tree -exp2tree e = do - (bs,f,xs) <- termForm e - cont <- case bs of - [] -> return [] - _ -> prtBad "cannot convert bindings in" e - at <- case f of - Q m c -> return $ AtC (m,c) - QC m c -> return $ AtC (m,c) - Meta m -> return $ AtM m - K s -> return $ AtL s - EInt n -> return $ AtI n - EFloat n -> return $ AtF n - _ -> prtBad "cannot convert to atom" f - ts <- mapM exp2tree xs - return $ Tr (N (cont,at,uVal,([],[]),True),ts) --} diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs deleted file mode 100644 index 799cd9ec5..000000000 --- a/src/GF/Grammar/Macros.hs +++ /dev/null @@ -1,627 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Macros --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 16:38:00 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.24 $ --- --- Macros for constructing and analysing source code terms. --- --- operations on terms and types not involving lookup in or reference to grammars --- --- AR 7\/12\/1999 - 9\/5\/2000 -- 4\/6\/2001 ------------------------------------------------------------------------------ - -module GF.Grammar.Macros where - -import GF.Data.Operations -import GF.Data.Str -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Grammar.Grammar -import GF.Grammar.Values -import GF.Grammar.Predef -import GF.Grammar.Printer - -import Control.Monad (liftM, liftM2) -import Data.Char (isDigit) -import Data.List (sortBy,nub) -import Text.PrettyPrint - -typeForm :: Type -> (Context, Cat, [Term]) -typeForm t = - case t of - Prod b x a t -> - let (x', cat, args) = typeForm t - in ((b,x,a):x', cat, args) - App c a -> - let (_, cat, args) = typeForm c - in ([],cat,args ++ [a]) - Q m c -> ([],(m,c),[]) - QC m c -> ([],(m,c),[]) - Sort c -> ([],(identW, c),[]) - _ -> error (render (text "no normal form of type" <+> ppTerm Unqualified 0 t)) - -typeFormCnc :: Type -> (Context, Type) -typeFormCnc t = - case t of - Prod b x a t -> let (x', v) = typeFormCnc t - in ((b,x,a):x',v) - _ -> ([],t) - -valCat :: Type -> Cat -valCat typ = - let (_,cat,_) = typeForm typ - in cat - -valType :: Type -> Type -valType typ = - let (_,cat,xx) = typeForm typ --- not optimal to do in this way - in mkApp (uncurry Q cat) xx - -valTypeCnc :: Type -> Type -valTypeCnc typ = snd (typeFormCnc typ) - -typeSkeleton :: Type -> ([(Int,Cat)],Cat) -typeSkeleton typ = - let (cont,cat,_) = typeForm typ - args = map (\(b,x,t) -> typeSkeleton t) cont - in ([(length c, v) | (c,v) <- args], cat) - -catSkeleton :: Type -> ([Cat],Cat) -catSkeleton typ = - let (args,val) = typeSkeleton typ - in (map snd args, val) - -funsToAndFrom :: Type -> (Cat, [(Cat,[Int])]) -funsToAndFrom t = - let (cs,v) = catSkeleton t - cis = zip cs [0..] - in (v, [(c,[i | (c',i) <- cis, c' == c]) | c <- cs]) - -isRecursiveType :: Type -> Bool -isRecursiveType t = - let (cc,c) = catSkeleton t -- thus recursivity on Cat level - in 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 b x a t -> liftM ((b,x,a):) $ contextOfType t - _ -> return [] - -termForm :: Term -> Err ([(BindType,Ident)], Term, [Term]) -termForm t = case t of - Abs b x t -> - do (x', fun, args) <- termForm t - return ((b,x):x', fun, args) - App c a -> - do (_,fun, args) <- termForm c - return ([],fun,args ++ [a]) - _ -> - return ([],t,[]) - -termFormCnc :: Term -> ([(BindType,Ident)], Term) -termFormCnc t = case t of - Abs b x t -> ((b,x):xs, t') where (xs,t') = termFormCnc t - _ -> ([],t) - -appForm :: Term -> (Term, [Term]) -appForm t = case t of - App c a -> (fun, args ++ [a]) where (fun, args) = appForm c - _ -> (t,[]) - -mkProdSimple :: Context -> Term -> Term -mkProdSimple c t = mkProd c t [] - -mkProd :: Context -> Term -> [Term] -> Term -mkProd [] typ args = mkApp typ args -mkProd ((b,x,a):dd) typ args = Prod b x a (mkProd dd typ args) - -mkTerm :: ([(BindType,Ident)], Term, [Term]) -> Term -mkTerm (xx,t,aa) = mkAbs xx (mkApp t aa) - -mkApp :: Term -> [Term] -> Term -mkApp = foldl App - -mkAbs :: [(BindType,Ident)] -> Term -> Term -mkAbs xx t = foldr (uncurry Abs) t xx - -appCons :: Ident -> [Term] -> Term -appCons = mkApp . Cn - -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 = (==) - -uType :: Type -uType = Cn cUndefinedType - -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] - -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 [(identC x, t) | (LIdent x,(_,t)) <- fs] - _ -> Bad (render (text "record expected, found" <+> ppTerm Unqualified 0 t)) - -typeType, typePType, typeStr, typeTok, typeStrs :: Term - -typeType = Sort cType -typePType = Sort cPType -typeStr = Sort cStr -typeTok = Sort cTok -typeStrs = Sort cStrs - -typeString, typeFloat, typeInt :: Term -typeInts :: Integer -> Term -typePBool :: Term -typeError :: Term - -typeString = cnPredef cString -typeInt = cnPredef cInt -typeFloat = cnPredef cFloat -typeInts i = App (cnPredef cInts) (EInt i) -typePBool = cnPredef cPBool -typeError = cnPredef cErrorType - -isTypeInts :: Term -> Maybe Integer -isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i -isTypeInts _ = Nothing - -isPredefConstant :: Term -> Bool -isPredefConstant t = case t of - Q mod _ | mod == cPredef || mod == cPredefAbs -> True - _ -> False - -cnPredef :: Ident -> Term -cnPredef f = Q cPredef f - -mkSelects :: Term -> [Term] -> Term -mkSelects t tt = foldl S t tt - -mkTable :: [Term] -> Term -> Term -mkTable tt t = foldr Table t tt - -mkCTable :: [(BindType,Ident)] -> Term -> Term -mkCTable ids v = foldr ccase v ids where - ccase (_,x) t = T TRaw [(PV x,t)] - -mkHypo :: Term -> Hypo -mkHypo typ = (Explicit,identW, typ) - -eqStrIdent :: Ident -> Ident -> Bool -eqStrIdent = (==) - -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 identW - -mkFunType :: [Type] -> Type -> Type -mkFunType tt t = mkProd [(Explicit,identW, ty) | ty <- tt] t [] -- nondep prod - -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 $ render (text "clashing labels" <+> hsep (map ppLabel ls)) - _ -> Bad $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 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 $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2) - --- | default linearization type -defLinType :: Type -defLinType = RecType [(theLinLabel, typeStr)] - --- | 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 . showIdent - -symbolOfIdent :: Ident -> String -symbolOfIdent = showIdent - -symid :: Ident -> String -symid = symbolOfIdent - -justIdentOf :: Term -> Maybe Ident -justIdentOf (Vr x) = Just x -justIdentOf (Cn x) = Just x -justIdentOf _ = Nothing - -linTypeStr :: Type -linTypeStr = mkRecType linLabel [typeStr] -- default lintype {s :: Str} - -linAsStr :: String -> Term -linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s} - -term2patt :: Term -> Err Patt -term2patt trm = case termForm trm of - Ok ([], Vr x, []) | x == identW -> return PW - | otherwise -> return (PV 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 id, [Vr a,b]) | id == cAs -> do - b' <- term2patt b - return (PAs a b') - Ok ([], Cn id, [a]) | id == cNeg -> do - a' <- term2patt a - return (PNeg a') - Ok ([], Cn id, [a]) | id == cRep -> do - a' <- term2patt a - return (PRep a') - Ok ([], Cn id, []) | id == cRep -> do - return PChar - Ok ([], Cn id,[K s]) | id == cChars -> do - return $ PChars s - Ok ([], Cn id, [a,b]) | id == cSeq -> do - a' <- term2patt a - b' <- term2patt b - return (PSeq a' b') - Ok ([], Cn id, [a,b]) | id == cAlt -> do - a' <- term2patt a - b' <- term2patt b - return (PAlt a' b') - - Ok ([], Cn c, []) -> do - return (PMacro c) - - _ -> Bad $ render (text "no pattern corresponds to term" <+> ppTerm Unqualified 0 trm) - -patt2term :: Patt -> Term -patt2term pt = case pt of - PV x -> Vr x - PW -> Vr identW --- not parsable, should not occur - 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 -> appCons cAs [Vr x, patt2term p] --- an encoding - PChar -> appCons cChar [] --- an encoding - PChars s -> appCons cChars [K s] --- an encoding - PSeq a b -> appCons cSeq [(patt2term a), (patt2term b)] --- an encoding - PAlt a b -> appCons cAlt [(patt2term a), (patt2term b)] --- an encoding - PRep a -> appCons cRep [(patt2term a)] --- an encoding - PNeg a -> appCons cNeg [(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 ultimate cases in a table; preserves pattern list -allCaseValues :: Term -> [([Patt],Term)] -allCaseValues trm = case trm of - T _ cs -> [(p:ps, t) | (p,t0) <- cs, (ps,t) <- allCaseValues t0] - _ -> [([],trm)] - --- | 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 - Strs ts -> mapM strsFromTerm ts >>= return . concat - _ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 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 b x t -> - do t' <- co t - return (Abs b x t') - Prod b x a t -> - do a' <- co a - t' <- co t - return (Prod b x a' t') - 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) - 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') - - 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 - Strs tt -> mapM co tt >>= return . Strs - - EPattType ty -> - do ty' <- co ty - return (EPattType ty') - - ELincat c ty -> - do ty' <- co ty - return (ELincat c ty') - - ELin c ty -> - do ty' <- co ty - return (ELin c 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 - 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 - --- | 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 - _ -> collectOp wo trm - where wo = wordsInTerm - -noExist :: Term -noExist = FV [] - -defaultLinType :: Type -defaultLinType = mkRecType linLabel [typeStr] - --- normalize records and record types; put s first - -sortRec :: [(Label,a)] -> [(Label,a)] -sortRec = sortBy ordLabel where - ordLabel (r1,_) (r2,_) = - case (showIdent (label2ident r1), showIdent (label2ident r2)) of - ("s",_) -> LT - (_,"s") -> GT - (s1,s2) -> compare s1 s2 - --- | dependency check, detecting circularities and returning topo-sorted list - -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 (Just ty) = opersIn ty - opty _ = [] - pts i = case i of - ResOper pty pt -> [pty,pt] - ResParam (Just ps) _ -> [Just 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 (Just co) _ -> [Just ty | (_,_,ty) <- co] - _ -> [] - -topoSortJments :: SourceModule -> Err [(Ident,Info)] -topoSortJments (m,mi) = do - is <- either - return - (\cyc -> Bad (render (text "circular definitions:" <+> fsep (map ppIdent (head cyc))))) - (topoTest (allDependencies (==m) (jments mi))) - return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]]) diff --git a/src/GF/Grammar/Parser.y b/src/GF/Grammar/Parser.y deleted file mode 100644 index 320053674..000000000 --- a/src/GF/Grammar/Parser.y +++ /dev/null @@ -1,739 +0,0 @@ -{ -{-# OPTIONS -fno-warn-overlapping-patterns #-} -module GF.Grammar.Parser - ( P, runP - , pModDef - , pModHeader - , pExp - ) where - -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Infra.Option -import GF.Data.Operations -import GF.Grammar.Predef -import GF.Grammar.Grammar -import GF.Grammar.Macros -import GF.Grammar.Lexer -import qualified Data.ByteString.Char8 as BS -import GF.Compile.Update (buildAnyTree) -} - -%name pModDef ModDef -%partial pModHeader ModHeader -%name pExp Exp - --- no lexer declaration -%monad { P } { >>= } { return } -%lexer { lexer } { T_EOF } -%tokentype { Token } - - -%token - '!' { T_exclmark } - '#' { T_patt } - '$' { T_int_label } - '(' { T_oparen } - ')' { T_cparen } - '*' { T_star } - '**' { T_starstar } - '+' { T_plus } - '++' { T_plusplus } - ',' { T_comma } - '-' { T_minus } - '->' { T_rarrow } - '.' { T_dot } - '/' { T_alt } - ':' { T_colon } - ';' { T_semicolon } - '<' { T_less } - '=' { T_equal } - '=>' { T_big_rarrow} - '>' { T_great } - '?' { T_questmark } - '@' { T_at } - '[' { T_obrack } - ']' { T_cbrack } - '{' { T_ocurly } - '}' { T_ccurly } - '\\' { T_lam } - '\\\\' { T_lamlam } - '_' { T_underscore} - '|' { T_bar } - 'PType' { T_PType } - 'Str' { T_Str } - 'Strs' { T_Strs } - 'Tok' { T_Tok } - 'Type' { T_Type } - 'abstract' { T_abstract } - 'case' { T_case } - 'cat' { T_cat } - 'concrete' { T_concrete } - 'data' { T_data } - 'def' { T_def } - 'flags' { T_flags } - 'fun' { T_fun } - 'in' { T_in } - 'incomplete' { T_incomplete} - 'instance' { T_instance } - 'interface' { T_interface } - 'let' { T_let } - 'lin' { T_lin } - 'lincat' { T_lincat } - 'lindef' { T_lindef } - 'of' { T_of } - 'open' { T_open } - 'oper' { T_oper } - 'param' { T_param } - 'pattern' { T_pattern } - 'pre' { T_pre } - 'printname' { T_printname } - 'resource' { T_resource } - 'strs' { T_strs } - 'table' { T_table } - 'variants' { T_variants } - 'where' { T_where } - 'with' { T_with } - -Integer { (T_Integer $$) } -Double { (T_Double $$) } -String { (T_String $$) } -LString { (T_LString $$) } -Ident { (T_Ident $$) } - - -%% - -ModDef :: { SourceModule } -ModDef - : ComplMod ModType '=' ModBody {% - do let mstat = $1 - (mtype,id) = $2 - (extends,with,content) = $4 - (opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) } - mapM_ (checkInfoType mtype) jments - defs <- case buildAnyTree id [(i,d) | (i,_,d) <- jments] of - Ok x -> return x - Bad msg -> fail msg - let poss = buildTree [(i,(fname,mkSrcSpan p)) | (i,p,_) <- jments] - fname = showIdent id ++ ".gf" - - mkSrcSpan :: (Posn, Posn) -> (Int,Int) - mkSrcSpan (Pn l1 _, Pn l2 _) = (l1,l2) - - return (id, ModInfo mtype mstat opts extends with opens [] defs poss) } - -ModHeader :: { SourceModule } -ModHeader - : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ; - (mtype,id) = $2 ; - (extends,with,opens) = $4 } - in (id, ModInfo mtype mstat noOptions extends with opens [] emptyBinTree emptyBinTree) } - -ComplMod :: { ModuleStatus } -ComplMod - : {- empty -} { MSComplete } - | 'incomplete' { MSIncomplete } - -ModType :: { (ModuleType Ident,Ident) } -ModType - : 'abstract' Ident { (MTAbstract, $2) } - | 'resource' Ident { (MTResource, $2) } - | 'interface' Ident { (MTInterface, $2) } - | 'concrete' Ident 'of' Ident { (MTConcrete $4, $2) } - | 'instance' Ident 'of' Ident { (MTInstance $4, $2) } - -ModHeaderBody :: { ( [(Ident,MInclude Ident)] - , Maybe (Ident,MInclude Ident,[(Ident,Ident)]) - , [OpenSpec Ident] - ) } -ModHeaderBody - : ListIncluded '**' Included 'with' ListInst '**' ModOpen { ($1, Just (fst $3,snd $3,$5), $7) } - | ListIncluded '**' Included 'with' ListInst { ($1, Just (fst $3,snd $3,$5), []) } - | ListIncluded '**' ModOpen { ($1, Nothing, $3) } - | ListIncluded { ($1, Nothing, []) } - | Included 'with' ListInst '**' ModOpen { ([], Just (fst $1,snd $1,$3), $5) } - | Included 'with' ListInst { ([], Just (fst $1,snd $1,$3), []) } - | ModOpen { ([], Nothing, $1) } - -ModOpen :: { [OpenSpec Ident] } -ModOpen - : { [] } - | 'open' ListOpen { $2 } - -ModBody :: { ( [(Ident,MInclude Ident)] - , Maybe (Ident,MInclude Ident,[(Ident,Ident)]) - , Maybe ([OpenSpec Ident],[(Ident,SrcSpan,Info)],Options) - ) } -ModBody - : ListIncluded '**' Included 'with' ListInst '**' ModContent { ($1, Just (fst $3,snd $3,$5), Just $7) } - | ListIncluded '**' Included 'with' ListInst { ($1, Just (fst $3,snd $3,$5), Nothing) } - | ListIncluded '**' ModContent { ($1, Nothing, Just $3) } - | ListIncluded { ($1, Nothing, Nothing) } - | Included 'with' ListInst '**' ModContent { ([], Just (fst $1,snd $1,$3), Just $5) } - | Included 'with' ListInst { ([], Just (fst $1,snd $1,$3), Nothing) } - | ModContent { ([], Nothing, Just $1) } - | ModBody ';' { $1 } - -ModContent :: { ([OpenSpec Ident],[(Ident,SrcSpan,Info)],Options) } -ModContent - : '{' ListTopDef '}' { ([],[d | Left ds <- $2, d <- ds],concatOptions [o | Right o <- $2]) } - | 'open' ListOpen 'in' '{' ListTopDef '}' { ($2,[d | Left ds <- $5, d <- ds],concatOptions [o | Right o <- $5]) } - -ListTopDef :: { [Either [(Ident,SrcSpan,Info)] Options] } -ListTopDef - : {- empty -} { [] } - | TopDef ListTopDef { $1 : $2 } - -ListOpen :: { [OpenSpec Ident] } -ListOpen - : Open { [$1] } - | Open ',' ListOpen { $1 : $3 } - -Open :: { OpenSpec Ident } -Open - : Ident { OSimple $1 } - | '(' Ident '=' Ident ')' { OQualif $2 $4 } - -ListInst :: { [(Ident,Ident)] } -ListInst - : Inst { [$1] } - | Inst ',' ListInst { $1 : $3 } - -Inst :: { (Ident,Ident) } -Inst - : '(' Ident '=' Ident ')' { ($2,$4) } - -ListIncluded :: { [(Ident,MInclude Ident)] } -ListIncluded - : Included { [$1] } - | Included ',' ListIncluded { $1 : $3 } - -Included :: { (Ident,MInclude Ident) } -Included - : Ident { ($1,MIAll ) } - | Ident '[' ListIdent ']' { ($1,MIOnly $3) } - | Ident '-' '[' ListIdent ']' { ($1,MIExcept $4) } - -TopDef :: { Either [(Ident,SrcSpan,Info)] Options } -TopDef - : 'cat' ListCatDef { Left $2 } - | 'fun' ListFunDef { Left $2 } - | 'def' ListDefDef { Left $2 } - | 'data' ListDataDef { Left $2 } - | 'param' ListParamDef { Left $2 } - | 'oper' ListOperDef { Left $2 } - | 'lincat' ListTermDef { Left [(f, pos, CncCat (Just e) Nothing Nothing ) | (f,pos,e) <- $2] } - | 'lindef' ListTermDef { Left [(f, pos, CncCat Nothing (Just e) Nothing ) | (f,pos,e) <- $2] } - | 'lin' ListLinDef { Left $2 } - | 'printname' 'cat' ListTermDef { Left [(f, pos, CncCat Nothing Nothing (Just e)) | (f,pos,e) <- $3] } - | 'printname' 'fun' ListTermDef { Left [(f, pos, CncFun Nothing Nothing (Just e)) | (f,pos,e) <- $3] } - | 'flags' ListFlagDef { Right $2 } - -CatDef :: { [(Ident,SrcSpan,Info)] } -CatDef - : Posn Ident ListDDecl Posn { [($2, ($1,$4), AbsCat (Just $3) Nothing)] } - | Posn '[' Ident ListDDecl ']' Posn { listCatDef $3 ($1,$6) $4 0 } - | Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef $3 ($1,$9) $4 (fromIntegral $7) } - -FunDef :: { [(Ident,SrcSpan,Info)] } -FunDef - : Posn ListIdent ':' Exp Posn { [(fun, ($1,$5), AbsFun (Just $4) Nothing (Just [])) | fun <- $2] } - -DefDef :: { [(Ident,SrcSpan,Info)] } -DefDef - : Posn ListName '=' Exp Posn { [(f, ($1,$5),AbsFun Nothing (Just 0) (Just [([],$4)])) | f <- $2] } - | Posn Name ListPatt '=' Exp Posn { [($2,($1,$6),AbsFun Nothing (Just (length $3)) (Just [($3,$5)]))] } - -DataDef :: { [(Ident,SrcSpan,Info)] } -DataDef - : Posn Ident '=' ListDataConstr Posn { ($2, ($1,$5), AbsCat Nothing (Just (map Cn $4))) : - [(fun, ($1,$5), AbsFun Nothing Nothing Nothing) | fun <- $4] } - | Posn ListIdent ':' Exp Posn { -- (snd (valCat $4), ($1,$5), AbsCat Nothing (Just (map Cn $2))) : - [(fun, ($1,$5), AbsFun (Just $4) Nothing Nothing) | fun <- $2] } - -ParamDef :: { [(Ident,SrcSpan,Info)] } -ParamDef - : Posn Ident '=' ListParConstr Posn { ($2, ($1,$5), ResParam (Just $4) Nothing) : - [(f, ($1,$5), ResValue (mkProdSimple co (Cn $2))) | (f,co) <- $4] } - | Posn Ident Posn { [($2, ($1,$3), ResParam Nothing Nothing)] } - -OperDef :: { [(Ident,SrcSpan,Info)] } -OperDef - : Posn ListName ':' Exp Posn { [(i, ($1,$5), info) | i <- $2, info <- mkOverload (Just $4) Nothing ] } - | Posn ListName '=' Exp Posn { [(i, ($1,$5), info) | i <- $2, info <- mkOverload Nothing (Just $4)] } - | Posn Name ListArg '=' Exp Posn { [(i, ($1,$6), info) | i <- [$2], info <- mkOverload Nothing (Just (mkAbs $3 $5))] } - | Posn ListName ':' Exp '=' Exp Posn { [(i, ($1,$7), info) | i <- $2, info <- mkOverload (Just $4) (Just $6)] } - -LinDef :: { [(Ident,SrcSpan,Info)] } -LinDef - : Posn ListName '=' Exp Posn { [(f, ($1,$5), CncFun Nothing (Just $4) Nothing) | f <- $2] } - | Posn Name ListArg '=' Exp Posn { [($2, ($1,$6), CncFun Nothing (Just (mkAbs $3 $5)) Nothing)] } - -TermDef :: { [(Ident,SrcSpan,Term)] } -TermDef - : Posn ListName '=' Exp Posn { [(i,($1,$5),$4) | i <- $2] } - -FlagDef :: { Options } -FlagDef - : Posn Ident '=' Ident Posn {% case parseModuleOptions ["--" ++ showIdent $2 ++ "=" ++ showIdent $4] of - Ok x -> return x - Bad msg -> failLoc $1 msg } - -ListDataConstr :: { [Ident] } -ListDataConstr - : Ident { [$1] } - | Ident '|' ListDataConstr { $1 : $3 } - -ParConstr :: { Param } -ParConstr - : Ident ListDDecl { ($1,$2) } - -ListLinDef :: { [(Ident,SrcSpan,Info)] } -ListLinDef - : LinDef ';' { $1 } - | LinDef ';' ListLinDef { $1 ++ $3 } - -ListDefDef :: { [(Ident,SrcSpan,Info)] } -ListDefDef - : DefDef ';' { $1 } - | DefDef ';' ListDefDef { $1 ++ $3 } - -ListOperDef :: { [(Ident,SrcSpan,Info)] } -ListOperDef - : OperDef ';' { $1 } - | OperDef ';' ListOperDef { $1 ++ $3 } - -ListCatDef :: { [(Ident,SrcSpan,Info)] } -ListCatDef - : CatDef ';' { $1 } - | CatDef ';' ListCatDef { $1 ++ $3 } - -ListFunDef :: { [(Ident,SrcSpan,Info)] } -ListFunDef - : FunDef ';' { $1 } - | FunDef ';' ListFunDef { $1 ++ $3 } - -ListDataDef :: { [(Ident,SrcSpan,Info)] } -ListDataDef - : DataDef ';' { $1 } - | DataDef ';' ListDataDef { $1 ++ $3 } - -ListParamDef :: { [(Ident,SrcSpan,Info)] } -ListParamDef - : ParamDef ';' { $1 } - | ParamDef ';' ListParamDef { $1 ++ $3 } - -ListTermDef :: { [(Ident,SrcSpan,Term)] } -ListTermDef - : TermDef ';' { $1 } - | TermDef ';' ListTermDef { $1 ++ $3 } - -ListFlagDef :: { Options } -ListFlagDef - : FlagDef ';' { $1 } - | FlagDef ';' ListFlagDef { addOptions $1 $3 } - -ListParConstr :: { [Param] } -ListParConstr - : ParConstr { [$1] } - | ParConstr '|' ListParConstr { $1 : $3 } - -ListIdent :: { [Ident] } -ListIdent - : Ident { [$1] } - | Ident ',' ListIdent { $1 : $3 } - -ListIdent2 :: { [Ident] } -ListIdent2 - : Ident { [$1] } - | Ident ListIdent2 { $1 : $2 } - -Name :: { Ident } -Name - : Ident { $1 } - | '[' Ident ']' { mkListId $2 } - -ListName :: { [Ident] } -ListName - : Name { [$1] } - | Name ',' ListName { $1 : $3 } - -LocDef :: { [(Ident, Maybe Type, Maybe Term)] } -LocDef - : ListIdent ':' Exp { [(lab,Just $3,Nothing) | lab <- $1] } - | ListIdent '=' Exp { [(lab,Nothing,Just $3) | lab <- $1] } - | ListIdent ':' Exp '=' Exp { [(lab,Just $3,Just $5) | lab <- $1] } - -ListLocDef :: { [(Ident, Maybe Type, Maybe Term)] } -ListLocDef - : {- empty -} { [] } - | LocDef { $1 } - | LocDef ';' ListLocDef { $1 ++ $3 } - -Exp :: { Term } -Exp - : Exp1 '|' Exp { FV [$1,$3] } - | '\\' ListBind '->' Exp { mkAbs $2 $4 } - | '\\\\' ListBind '=>' Exp { mkCTable $2 $4 } - | Decl '->' Exp { mkProdSimple $1 $3 } - | Exp3 '=>' Exp { Table $1 $3 } - | 'let' '{' ListLocDef '}' 'in' Exp {% - do defs <- mapM tryLoc $3 - return $ mkLet defs $6 } - | 'let' ListLocDef 'in' Exp {% - do defs <- mapM tryLoc $2 - return $ mkLet defs $4 } - | Exp3 'where' '{' ListLocDef '}' {% - do defs <- mapM tryLoc $4 - return $ mkLet defs $1 } - | 'in' Exp5 String { Example $2 $3 } - | Exp1 { $1 } - -Exp1 :: { Term } -Exp1 - : Exp2 '++' Exp1 { C $1 $3 } - | Exp2 { $1 } - -Exp2 :: { Term } -Exp2 - : Exp3 '+' Exp2 { Glue $1 $3 } - | Exp3 { $1 } - -Exp3 :: { Term } -Exp3 - : Exp3 '!' Exp4 { S $1 $3 } - | 'table' '{' ListCase '}' { T TRaw $3 } - | 'table' Exp6 '{' ListCase '}' { T (TTyped $2) $4 } - | 'table' Exp6 '[' ListExp ']' { V $2 $4 } - | Exp3 '*' Exp4 { case $1 of - RecType xs -> RecType (xs ++ [(tupleLabel (length xs+1),$3)]) - t -> RecType [(tupleLabel 1,$1), (tupleLabel 2,$3)] } - | Exp3 '**' Exp4 { ExtR $1 $3 } - | Exp4 { $1 } - -Exp4 :: { Term } -Exp4 - : Exp4 Exp5 { App $1 $2 } - | Exp4 '{' Exp '}' { App $1 (ImplArg $3) } - | 'case' Exp 'of' '{' ListCase '}' { let annot = case $2 of - Typed _ t -> TTyped t - _ -> TRaw - in S (T annot $5) $2 } - | 'variants' '{' ListExp '}' { FV $3 } - | 'pre' '{' ListCase '}' {% mkAlts $3 } - | 'pre' '{' String ';' ListAltern '}' { Alts (K $3, $5) } - | 'pre' '{' Ident ';' ListAltern '}' { Alts (Vr $3, $5) } - | 'strs' '{' ListExp '}' { Strs $3 } - | '#' Patt2 { EPatt $2 } - | 'pattern' Exp5 { EPattType $2 } - | 'lincat' Ident Exp5 { ELincat $2 $3 } - | 'lin' Ident Exp5 { ELin $2 $3 } - | Exp5 { $1 } - -Exp5 :: { Term } -Exp5 - : Exp5 '.' Label { P $1 $3 } - | Exp6 { $1 } - -Exp6 :: { Term } -Exp6 - : Ident { Vr $1 } - | Sort { Sort $1 } - | String { K $1 } - | Integer { EInt $1 } - | Double { EFloat $1 } - | '?' { Meta 0 } - | '[' ']' { Empty } - | '[' Ident Exps ']' { foldl App (Vr (mkListId $2)) $3 } - | '[' String ']' { case $2 of - [] -> Empty - str -> foldr1 C (map K (words str)) } - | '{' ListLocDef '}' {% mkR $2 } - | '<' ListTupleComp '>' { R (tuple2record $2) } - | '<' Exp ':' Exp '>' { Typed $2 $4 } - | LString { K $1 } - | '(' Exp ')' { $2 } - -ListExp :: { [Term] } -ListExp - : {- empty -} { [] } - | Exp { [$1] } - | Exp ';' ListExp { $1 : $3 } - -Exps :: { [Term] } -Exps - : {- empty -} { [] } - | Exp6 Exps { $1 : $2 } - -Patt :: { Patt } -Patt - : Patt '|' Patt1 { PAlt $1 $3 } - | Patt '+' Patt1 { PSeq $1 $3 } - | Patt1 { $1 } - -Patt1 :: { Patt } -Patt1 - : Ident ListPatt { PC $1 $2 } - | Ident '.' Ident ListPatt { PP $1 $3 $4 } - | Patt2 '*' { PRep $1 } - | Ident '@' Patt2 { PAs $1 $3 } - | '-' Patt2 { PNeg $2 } - | Patt2 { $1 } - -Patt2 :: { Patt } -Patt2 - : '?' { PChar } - | '[' String ']' { PChars $2 } - | '#' Ident { PMacro $2 } - | '#' Ident '.' Ident { PM $2 $4 } - | '_' { PW } - | Ident { PV $1 } - | Ident '.' Ident { PP $1 $3 [] } - | Integer { PInt $1 } - | Double { PFloat $1 } - | String { PString $1 } - | '{' ListPattAss '}' { PR $2 } - | '<' ListPattTupleComp '>' { (PR . tuple2recordPatt) $2 } - | '(' Patt ')' { $2 } - -PattAss :: { [(Label,Patt)] } -PattAss - : ListIdent '=' Patt { [(LIdent (ident2bs i),$3) | i <- $1] } - -Label :: { Label } -Label - : Ident { LIdent (ident2bs $1) } - | '$' Integer { LVar (fromIntegral $2) } - -Sort :: { Ident } -Sort - : 'Type' { cType } - | 'PType' { cPType } - | 'Tok' { cTok } - | 'Str' { cStr } - | 'Strs' { cStrs } - -ListPattAss :: { [(Label,Patt)] } -ListPattAss - : {- empty -} { [] } - | PattAss { $1 } - | PattAss ';' ListPattAss { $1 ++ $3 } - -ListPatt :: { [Patt] } -ListPatt - : PattArg { [$1] } - | PattArg ListPatt { $1 : $2 } - -PattArg :: { Patt } - : Patt2 { $1 } - | '{' Patt2 '}' { PImplArg $2 } - -Arg :: { [(BindType,Ident)] } -Arg - : Ident { [(Explicit,$1 )] } - | '_' { [(Explicit,identW)] } - | '{' ListIdent2 '}' { [(Implicit,v) | v <- $2] } - -ListArg :: { [(BindType,Ident)] } -ListArg - : Arg { $1 } - | Arg ListArg { $1 ++ $2 } - -Bind :: { [(BindType,Ident)] } -Bind - : Ident { [(Explicit,$1 )] } - | '_' { [(Explicit,identW)] } - | '{' ListIdent '}' { [(Implicit,v) | v <- $2] } - -ListBind :: { [(BindType,Ident)] } -ListBind - : Bind { $1 } - | Bind ',' ListBind { $1 ++ $3 } - -Decl :: { [Hypo] } -Decl - : '(' ListBind ':' Exp ')' { [(b,x,$4) | (b,x) <- $2] } - | Exp4 { [mkHypo $1] } - -ListTupleComp :: { [Term] } -ListTupleComp - : {- empty -} { [] } - | Exp { [$1] } - | Exp ',' ListTupleComp { $1 : $3 } - -ListPattTupleComp :: { [Patt] } -ListPattTupleComp - : {- empty -} { [] } - | Patt { [$1] } - | Patt ',' ListPattTupleComp { $1 : $3 } - -Case :: { Case } -Case - : Patt '=>' Exp { ($1,$3) } - -ListCase :: { [Case] } -ListCase - : Case { [$1] } - | Case ';' ListCase { $1 : $3 } - -Altern :: { (Term,Term) } -Altern - : Exp '/' Exp { ($1,$3) } - -ListAltern :: { [(Term,Term)] } -ListAltern - : Altern { [$1] } - | Altern ';' ListAltern { $1 : $3 } - -DDecl :: { [Hypo] } -DDecl - : '(' ListBind ':' Exp ')' { [(b,x,$4) | (b,x) <- $2] } - | Exp6 { [mkHypo $1] } - -ListDDecl :: { [Hypo] } -ListDDecl - : {- empty -} { [] } - | DDecl ListDDecl { $1 ++ $2 } - -Posn :: { Posn } -Posn - : {- empty -} {% getPosn } - - -{ - -happyError :: P a -happyError = fail "parse error" - -mkListId,mkConsId,mkBaseId :: Ident -> Ident -mkListId = prefixId (BS.pack "List") -mkConsId = prefixId (BS.pack "Cons") -mkBaseId = prefixId (BS.pack "Base") - -prefixId :: BS.ByteString -> Ident -> Ident -prefixId pref id = identC (BS.append pref (ident2bs id)) - -listCatDef :: Ident -> SrcSpan -> Context -> Int -> [(Ident,SrcSpan,Info)] -listCatDef id pos cont size = [catd,nilfund,consfund] - where - listId = mkListId id - baseId = mkBaseId id - consId = mkConsId id - - catd = (listId, pos, AbsCat (Just cont') (Just [Cn baseId,Cn consId])) - nilfund = (baseId, pos, AbsFun (Just niltyp) Nothing Nothing) - consfund = (consId, pos, AbsFun (Just constyp) Nothing Nothing) - - cont' = [(b,mkId x i,ty) | (i,(b,x,ty)) <- zip [0..] cont] - xs = map (\(b,x,t) -> Vr x) cont' - cd = mkHypo (mkApp (Vr id) xs) - lc = mkApp (Vr listId) xs - - niltyp = mkProdSimple (cont' ++ replicate size cd) lc - constyp = mkProdSimple (cont' ++ [cd, mkHypo lc]) lc - - mkId x i = if isWildIdent x then (varX i) else x - -tryLoc (c,mty,Just e) = return (c,(mty,e)) -tryLoc (c,_ ,_ ) = fail ("local definition of" +++ showIdent c +++ "without value") - -mkR [] = return $ RecType [] --- empty record always interpreted as record type -mkR fs@(f:_) = - case f of - (lab,Just ty,Nothing) -> mapM tryRT fs >>= return . RecType - _ -> mapM tryR fs >>= return . R - where - tryRT (lab,Just ty,Nothing) = return (ident2label lab,ty) - tryRT (lab,_ ,_ ) = fail $ "illegal record type field" +++ showIdent lab --- manifest fields ?! - - tryR (lab,mty,Just t) = return (ident2label lab,(mty,t)) - tryR (lab,_ ,_ ) = fail $ "illegal record field" +++ showIdent lab - -mkOverload pdt pdf@(Just df) = - case appForm df of - (keyw, ts@(_:_)) | isOverloading keyw -> - case last ts of - R fs -> [ResOverload [m | Vr m <- ts] [(ty,fu) | (_,(Just ty,fu)) <- fs]] - _ -> [ResOper pdt pdf] - _ -> [ResOper pdt pdf] - - -- to enable separare type signature --- not type-checked -mkOverload pdt@(Just df) pdf = - case appForm df of - (keyw, ts@(_:_)) | isOverloading keyw -> - case last ts of - RecType _ -> [] - _ -> [ResOper pdt pdf] - _ -> [ResOper pdt pdf] -mkOverload pdt pdf = [ResOper pdt pdf] - -isOverloading t = - case t of - Vr keyw | showIdent keyw == "overload" -> True -- overload is a "soft keyword" - _ -> False - - -type SrcSpan = (Posn,Posn) - - -checkInfoType MTAbstract (id,pos,info) = - case info of - AbsCat _ _ -> return () - AbsFun _ _ _ -> return () - _ -> failLoc (fst pos) "illegal definition in abstract module" -checkInfoType MTResource (id,pos,info) = - case info of - ResParam _ _ -> return () - ResValue _ -> return () - ResOper _ _ -> return () - ResOverload _ _ -> return () - _ -> failLoc (fst pos) "illegal definition in resource module" -checkInfoType MTInterface (id,pos,info) = - case info of - ResParam _ _ -> return () - ResValue _ -> return () - ResOper _ _ -> return () - ResOverload _ _ -> return () - _ -> failLoc (fst pos) "illegal definition in interface module" -checkInfoType (MTConcrete _) (id,pos,info) = - case info of - CncCat _ _ _ -> return () - CncFun _ _ _ -> return () - ResParam _ _ -> return () - ResValue _ -> return () - ResOper _ _ -> return () - ResOverload _ _ -> return () - _ -> failLoc (fst pos) "illegal definition in concrete module" -checkInfoType (MTInstance _) (id,pos,info) = - case info of - ResParam _ _ -> return () - ResValue _ -> return () - ResOper _ _ -> return () - _ -> failLoc (fst pos) "illegal definition in instance module" - - -mkAlts cs = case cs of - _:_ -> do - def <- mkDef (last cs) - alts <- mapM mkAlt (init cs) - return (Alts (def,alts)) - _ -> fail "empty alts" - where - mkDef (_,t) = return t - mkAlt (p,t) = do - ss <- mkStrs p - return (t,ss) - mkStrs p = case p of - PAlt a b -> do - Strs as <- mkStrs a - Strs bs <- mkStrs b - return $ Strs $ as ++ bs - PString s -> return $ Strs [K s] - PV x -> return (Vr x) --- for macros; not yet complete - PMacro x -> return (Vr x) --- for macros; not yet complete - PM m c -> return (Q m c) --- for macros; not yet complete - _ -> fail "no strs from pattern" - -} - diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs deleted file mode 100644 index b8f7eff7d..000000000 --- a/src/GF/Grammar/PatternMatch.hs +++ /dev/null @@ -1,165 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PatternMatch --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/12 12:38:29 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.7 $ --- --- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003 ------------------------------------------------------------------------------ - -module GF.Grammar.PatternMatch (matchPattern, - testOvershadow, - findMatch - ) where - -import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Grammar.Macros -import GF.Grammar.Printer - -import Data.List -import Control.Monad -import Text.PrettyPrint -import Debug.Trace - -matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution) -matchPattern pts term = - if not (isInConstantForm term) - then Bad (render (text "variables occur in" <+> ppTerm Unqualified 0 term)) - else do - term' <- mkK term - errIn (render (text "trying patterns" <+> hsep (punctuate comma (map (ppPatt Unqualified 0 . fst) pts)))) $ - findMatch [([p],t) | (p,t) <- pts] [term'] - where - -- to capture all Str with string pattern matching - mkK s = case s of - C _ _ -> do - s' <- getS s - return (K (unwords s')) - _ -> return s - - getS s = case s of - K w -> return [w] - C v w -> liftM2 (++) (getS v) (getS w) - Empty -> return [] - _ -> Bad (render (text "cannot get string from" <+> ppTerm Unqualified 0 s)) - -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 (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms)))) - (patts,_):_ | length patts /= length terms -> - Bad (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+> - text "cannot take" <+> hsep (map (ppTerm Unqualified 0) 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 in matchPattern - trym p t' = - case (p,t') of - (_,(x,Empty,y)) -> trym p (x,K [],y) -- because "" = [""] = [] - (PW, _) | 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' - - (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 [] - _ -> Bad (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 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 [] - - _ -> Bad (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t)) - -isInConstantForm :: Term -> Bool -isInConstantForm trm = case trm of - Cn _ -> True - Con _ -> True - Q _ _ -> True - QC _ _ -> True - Abs _ _ _ -> True - C c a -> isInConstantForm c && isInConstantForm a - 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] - PC _ ps -> concat $ map varsOfPatt ps - PP _ _ ps -> concat $ map varsOfPatt ps - PR r -> concat $ map (varsOfPatt . snd) r - PT _ q -> varsOfPatt q - _ -> [] - --- | to search matching parameter combinations in tables -isMatchingForms :: [Patt] -> [Term] -> Bool -isMatchingForms ps ts = all match (zip ps ts') where - match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds - match _ = True - ts' = map appForm ts - diff --git a/src/GF/Grammar/Predef.hs b/src/GF/Grammar/Predef.hs deleted file mode 100644 index 045df06ca..000000000 --- a/src/GF/Grammar/Predef.hs +++ /dev/null @@ -1,180 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Grammar.Predef --- Maintainer : kr.angelov --- Stability : (stable) --- Portability : (portable) --- --- Predefined identifiers and labels which the compiler knows ----------------------------------------------------------------------- - - -module GF.Grammar.Predef - ( cType - , cPType - , cTok - , cStr - , cStrs - , cPredefAbs, cPredefCnc, cPredef - , cInt - , cFloat - , cString - , cInts - , cPBool - , cErrorType - , cOverload - , cUndefinedType - , isPredefCat - - , cPTrue, cPFalse - - , cLength, cDrop, cTake, cTk, cDp, cEqStr, cOccur - , cOccurs, cEqInt, cLessInt, cPlus, cShow, cRead - , cToStr, cMapStr, cError - - -- hacks - , cMeta, cAs, cChar, cChars, cSeq, cAlt, cRep - , cNeg, cCNC, cConflict - ) where - -import GF.Infra.Ident -import qualified Data.ByteString.Char8 as BS - -cType :: Ident -cType = identC (BS.pack "Type") - -cPType :: Ident -cPType = identC (BS.pack "PType") - -cTok :: Ident -cTok = identC (BS.pack "Tok") - -cStr :: Ident -cStr = identC (BS.pack "Str") - -cStrs :: Ident -cStrs = identC (BS.pack "Strs") - -cPredefAbs :: Ident -cPredefAbs = identC (BS.pack "PredefAbs") - -cPredefCnc :: Ident -cPredefCnc = identC (BS.pack "PredefCnc") - -cPredef :: Ident -cPredef = identC (BS.pack "Predef") - -cInt :: Ident -cInt = identC (BS.pack "Int") - -cFloat :: Ident -cFloat = identC (BS.pack "Float") - -cString :: Ident -cString = identC (BS.pack "String") - -cInts :: Ident -cInts = identC (BS.pack "Ints") - -cPBool :: Ident -cPBool = identC (BS.pack "PBool") - -cErrorType :: Ident -cErrorType = identC (BS.pack "Error") - -cOverload :: Ident -cOverload = identC (BS.pack "overload") - -cUndefinedType :: Ident -cUndefinedType = identC (BS.pack "UndefinedType") - -isPredefCat :: Ident -> Bool -isPredefCat c = elem c [cInt,cString,cFloat] - -cPTrue :: Ident -cPTrue = identC (BS.pack "PTrue") - -cPFalse :: Ident -cPFalse = identC (BS.pack "PFalse") - -cLength :: Ident -cLength = identC (BS.pack "length") - -cDrop :: Ident -cDrop = identC (BS.pack "drop") - -cTake :: Ident -cTake = identC (BS.pack "take") - -cTk :: Ident -cTk = identC (BS.pack "tk") - -cDp :: Ident -cDp = identC (BS.pack "dp") - -cEqStr :: Ident -cEqStr = identC (BS.pack "eqStr") - -cOccur :: Ident -cOccur = identC (BS.pack "occur") - -cOccurs :: Ident -cOccurs = identC (BS.pack "occurs") - -cEqInt :: Ident -cEqInt = identC (BS.pack "eqInt") - -cLessInt :: Ident -cLessInt = identC (BS.pack "lessInt") - -cPlus :: Ident -cPlus = identC (BS.pack "plus") - -cShow :: Ident -cShow = identC (BS.pack "show") - -cRead :: Ident -cRead = identC (BS.pack "read") - -cToStr :: Ident -cToStr = identC (BS.pack "toStr") - -cMapStr :: Ident -cMapStr = identC (BS.pack "mapStr") - -cError :: Ident -cError = identC (BS.pack "error") - - ---- hacks: dummy identifiers used in various places ---- Not very nice! - -cMeta :: Ident -cMeta = identC (BS.singleton '?') - -cAs :: Ident -cAs = identC (BS.singleton '@') - -cChar :: Ident -cChar = identC (BS.singleton '?') - -cChars :: Ident -cChars = identC (BS.pack "[]") - -cSeq :: Ident -cSeq = identC (BS.pack "+") - -cAlt :: Ident -cAlt = identC (BS.pack "|") - -cRep :: Ident -cRep = identC (BS.pack "*") - -cNeg :: Ident -cNeg = identC (BS.pack "-") - -cCNC :: Ident -cCNC = identC (BS.pack "CNC") - -cConflict :: Ident -cConflict = IC (BS.pack "#conflict") diff --git a/src/GF/Grammar/Printer.hs b/src/GF/Grammar/Printer.hs deleted file mode 100644 index 06cac9705..000000000 --- a/src/GF/Grammar/Printer.hs +++ /dev/null @@ -1,317 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Grammar.Printer --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- ------------------------------------------------------------------------------ - -module GF.Grammar.Printer - ( TermPrintQual(..) - , ppIdent - , ppLabel - , ppModule - , ppJudgement - , ppTerm - , ppTermTabular - , ppPatt - , ppValue - , ppConstrs - - , showTerm, TermPrintStyle(..) - ) where - -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Infra.Option -import GF.Grammar.Values -import GF.Grammar.Grammar -import GF.Data.Operations -import Text.PrettyPrint - -import Data.Maybe (maybe) -import Data.List (intersperse) - -data TermPrintQual = Qualified | Unqualified - -ppModule :: TermPrintQual -> SourceModule -> Doc -ppModule q (mn, ModInfo mtype mstat opts exts with opens _ jments _) = - hdr $$ nest 2 (ppOptions opts $$ vcat (map (ppJudgement q) defs)) $$ ftr - where - defs = tree2list jments - - hdr = complModDoc <+> modTypeDoc <+> equals <+> - hsep (intersperse (text "**") $ - filter (not . isEmpty) $ [ commaPunct ppExtends exts - , maybe empty ppWith with - , if null opens - then lbrace - else text "open" <+> commaPunct ppOpenSpec opens <+> text "in" <+> lbrace - ]) - - ftr = rbrace - - complModDoc = - case mstat of - MSComplete -> empty - MSIncomplete -> text "incomplete" - - modTypeDoc = - case mtype of - MTAbstract -> text "abstract" <+> ppIdent mn - MTResource -> text "resource" <+> ppIdent mn - MTConcrete abs -> text "concrete" <+> ppIdent mn <+> text "of" <+> ppIdent abs - MTInterface -> text "interface" <+> ppIdent mn - MTInstance int -> text "instance" <+> ppIdent mn <+> text "of" <+> ppIdent int - - ppExtends (id,MIAll ) = ppIdent id - ppExtends (id,MIOnly incs) = ppIdent id <+> brackets (commaPunct ppIdent incs) - ppExtends (id,MIExcept incs) = ppIdent id <+> char '-' <+> brackets (commaPunct ppIdent incs) - - ppWith (id,ext,opens) = ppExtends (id,ext) <+> text "with" <+> commaPunct ppInstSpec opens - -ppOptions opts = - text "flags" $$ - nest 2 (vcat [text option <+> equals <+> str value <+> semi | (option,value) <- optionsGFO opts]) - -ppJudgement q (id, AbsCat pcont pconstrs) = - text "cat" <+> ppIdent id <+> - (case pcont of - Just cont -> hsep (map (ppDecl q) cont) - Nothing -> empty) <+> semi $$ - case pconstrs of - Just costrs -> text "data" <+> ppIdent id <+> equals <+> fsep (intersperse (char '|') (map (ppTerm q 0) costrs)) <+> semi - Nothing -> empty -ppJudgement q (id, AbsFun ptype _ pexp) = - (case ptype of - Just typ -> text "fun" <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi - Nothing -> empty) $$ - (case pexp of - Just [] -> empty - Just eqs -> text "def" <+> vcat [ppIdent id <+> hsep (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi | (ps,e) <- eqs] - Nothing -> empty) -ppJudgement q (id, ResParam pparams _) = - text "param" <+> ppIdent id <+> - (case pparams of - Just ps -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps)) - _ -> empty) <+> semi -ppJudgement q (id, ResValue pvalue) = empty -ppJudgement q (id, ResOper ptype pexp) = - text "oper" <+> ppIdent id <+> - (case ptype of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty} $$ - case pexp of {Just e -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi -ppJudgement q (id, ResOverload ids defs) = - text "oper" <+> ppIdent id <+> equals <+> - (text "overload" <+> lbrace $$ - nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e) | (ty,e) <- defs]) $$ - rbrace) <+> semi -ppJudgement q (id, CncCat ptype pexp pprn) = - (case ptype of - Just typ -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi - Nothing -> empty) $$ - (case pexp of - Just exp -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi - Nothing -> empty) $$ - (case pprn of - Just prn -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi - Nothing -> empty) -ppJudgement q (id, CncFun ptype pdef pprn) = - (case pdef of - Just e -> let (xs,e') = getAbs e - in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi - Nothing -> empty) $$ - (case pprn of - Just prn -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi - Nothing -> empty) -ppJudgement q (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi - -ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e) - in prec d 0 (char '\\' <> commaPunct ppBind xs <+> text "->" <+> ppTerm q 0 e') -ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of - ([],_) -> text "table" <+> lbrace $$ - nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ - rbrace - (vs,e) -> prec d 0 (text "\\\\" <> commaPunct ppIdent vs <+> text "=>" <+> ppTerm q 0 e) -ppTerm q d (T (TTyped t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$ - nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ - rbrace -ppTerm q d (T (TComp t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$ - nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ - rbrace -ppTerm q d (T (TWild t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$ - nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ - rbrace -ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit - then prec d 0 (ppTerm q 4 a <+> text "->" <+> ppTerm q 0 b) - else prec d 0 (parens (ppBind (bt,x) <+> colon <+> ppTerm q 0 a) <+> text "->" <+> ppTerm q 0 b) -ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> text "=>" <+> ppTerm q 0 vt) -ppTerm q d (Let l e) = let (ls,e') = getLet e - in prec d 0 (text "let" <+> vcat (map (ppLocDef q) (l:ls)) $$ text "in" <+> ppTerm q 0 e') -ppTerm q d (Example e s)=prec d 0 (text "in" <+> ppTerm q 5 e <+> str s) -ppTerm q d (C e1 e2) =prec d 1 (ppTerm q 2 e1 <+> text "++" <+> ppTerm q 1 e2) -ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> char '+' <+> ppTerm q 2 e2) -ppTerm q d (S x y) = case x of - T annot xs -> let e = case annot of - TRaw -> y - TTyped t -> Typed y t - TComp t -> Typed y t - TWild t -> Typed y t - in text "case" <+> ppTerm q 0 e <+> text "of" <+> lbrace $$ - nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ - rbrace - _ -> prec d 3 (ppTerm q 3 x <+> text "!" <+> ppTerm q 4 y) -ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> text "**" <+> ppTerm q 4 y) -ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y) -ppTerm q d (V e es) = text "table" <+> ppTerm q 6 e <+> lbrace $$ - nest 2 (fsep (punctuate semi (map (ppTerm q 0) es))) $$ - rbrace -ppTerm q d (FV es) = text "variants" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es))) -ppTerm q d (Alts (e,xs))=text "pre" <+> braces (ppTerm q 0 e <> semi <+> fsep (punctuate semi (map (ppAltern q) xs))) -ppTerm q d (Strs es) = text "strs" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es))) -ppTerm q d (EPatt p) = prec d 4 (char '#' <+> ppPatt q 2 p) -ppTerm q d (EPattType t)=prec d 4 (text "pattern" <+> ppTerm q 0 t) -ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> char '.' <> ppLabel l) -ppTerm q d (Cn id) = ppIdent id -ppTerm q d (Vr id) = ppIdent id -ppTerm q d (Q m id) = ppQIdent q m id -ppTerm q d (QC m id) = ppQIdent q m id -ppTerm q d (Sort id) = ppIdent id -ppTerm q d (K s) = str s -ppTerm q d (EInt n) = integer n -ppTerm q d (EFloat f) = double f -ppTerm q d (Meta _) = char '?' -ppTerm q d (Empty) = text "[]" -ppTerm q d (R xs) = braces (fsep (punctuate semi [ppLabel l <+> - fsep [case mb_t of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty}, - equals <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs])) -ppTerm q d (RecType xs)= braces (fsep (punctuate semi [ppLabel l <+> colon <+> ppTerm q 0 t | (l,t) <- xs])) -ppTerm q d (Typed e t) = char '<' <> ppTerm q 0 e <+> colon <+> ppTerm q 0 t <> char '>' - -ppTermTabular :: TermPrintQual -> Term -> [(Doc,Doc)] -ppTermTabular q = pr where - pr t = case t of - R rs -> - [(ppLabel lab <+> char '.' <+> path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val] - T _ cs -> - [(ppPatt q 0 patt <+> text "=>" <+> path, str) | (patt, val ) <- cs, (path,str) <- pr val] - V _ cs -> - [(char '#' <> int i <+> text "=>" <+> path, str) | (i, val ) <- zip [0..] cs, (path,str) <- pr val] - _ -> [(empty,ps t)] - ps t = case t of - K s -> text s - C s u -> ps s <+> ps u - FV ts -> hsep (intersperse (char '/') (map ps ts)) - _ -> ppTerm q 0 t - -ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> text "->" <+> ppTerm q 0 e - -ppCase q (p,e) = ppPatt q 0 p <+> text "=>" <+> ppTerm q 0 e - -ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '|' <+> ppPatt q 1 p2) -ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '+' <+> ppPatt q 1 p2) -ppPatt q d (PC f ps) = if null ps - then ppIdent f - else prec d 1 (ppIdent f <+> hsep (map (ppPatt q 2) ps)) -ppPatt q d (PP f g ps) = if null ps - then ppQIdent q f g - else prec d 1 (ppQIdent q f g <+> hsep (map (ppPatt q 2) ps)) -ppPatt q d (PRep p) = prec d 1 (ppPatt q 2 p <> char '*') -ppPatt q d (PAs f p) = prec d 1 (ppIdent f <> char '@' <> ppPatt q 2 p) -ppPatt q d (PNeg p) = prec d 1 (char '-' <> ppPatt q 2 p) -ppPatt q d (PChar) = char '?' -ppPatt q d (PChars s) = brackets (str s) -ppPatt q d (PMacro id) = char '#' <> ppIdent id -ppPatt q d (PM m id) = char '#' <> ppIdent m <> char '.' <> ppIdent id -ppPatt q d PW = char '_' -ppPatt q d (PV id) = ppIdent id -ppPatt q d (PInt n) = integer n -ppPatt q d (PFloat f) = double f -ppPatt q d (PString s) = str s -ppPatt q d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs])) - -ppValue :: TermPrintQual -> Int -> Val -> Doc -ppValue q d (VGen i x) = ppIdent x <> text "{-" <> int i <> text "-}" ---- latter part for debugging -ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v) -ppValue q d (VCn (_,c)) = ppIdent c -ppValue q d (VClos env e) = case e of - Meta _ -> ppTerm q d e <> ppEnv env - _ -> ppTerm q d e ---- ++ prEnv env ---- for debugging -ppValue q d (VRecType xs) = braces (hsep (punctuate comma [ppLabel l <> char '=' <> ppValue q 0 v | (l,v) <- xs])) -ppValue q d VType = text "Type" - -ppConstrs :: Constraints -> [Doc] -ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> text "<>" <+> ppValue Unqualified 0 w)) - -ppEnv :: Env -> Doc -ppEnv e = hcat (map (\(x,t) -> braces (ppIdent x <> text ":=" <> ppValue Unqualified 0 t)) e) - -str s = doubleQuotes (text s) - -ppDecl q (_,id,typ) - | id == identW = ppTerm q 4 typ - | otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ) - -ppDDecl q (_,id,typ) - | id == identW = ppTerm q 6 typ - | otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ) - -ppIdent = text . showIdent - -ppQIdent q m id = - case q of - Qualified -> ppIdent m <> char '.' <> ppIdent id - Unqualified -> ppIdent id - -ppLabel = ppIdent . label2ident - -ppOpenSpec (OSimple id) = ppIdent id -ppOpenSpec (OQualif id n) = parens (ppIdent id <+> equals <+> ppIdent n) - -ppInstSpec (id,n) = parens (ppIdent id <+> equals <+> ppIdent n) - -ppLocDef q (id, (mbt, e)) = - ppIdent id <+> - (case mbt of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty} <+> equals <+> ppTerm q 0 e) <+> semi - -ppBind (Explicit,v) = ppIdent v -ppBind (Implicit,v) = braces (ppIdent v) - -ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y - -ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt) - -commaPunct f ds = (hcat (punctuate comma (map f ds))) - -prec d1 d2 doc - | d1 > d2 = parens doc - | otherwise = doc - -getAbs :: Term -> ([(BindType,Ident)], Term) -getAbs (Abs bt v e) = let (xs,e') = getAbs e - in ((bt,v):xs,e') -getAbs e = ([],e) - -getCTable :: Term -> ([Ident], Term) -getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e - in (v:vs,e') -getCTable (T TRaw [(PW, e)]) = let (vs,e') = getCTable e - in (identW:vs,e') -getCTable e = ([],e) - -getLet :: Term -> ([LocalDef], Term) -getLet (Let l e) = let (ls,e') = getLet e - in (l:ls,e') -getLet e = ([],e) - -showTerm :: TermPrintStyle -> TermPrintQual -> Term -> String -showTerm style q t = render $ - case style of - TermPrintTable -> vcat [p <+> s | (p,s) <- ppTermTabular q t] - TermPrintAll -> vcat [ s | (p,s) <- ppTermTabular q t] - TermPrintDefault -> ppTerm q 0 t - -data TermPrintStyle - = TermPrintTable - | TermPrintAll - | TermPrintDefault diff --git a/src/GF/Grammar/Unify.hs b/src/GF/Grammar/Unify.hs deleted file mode 100644 index 9bb49cfe2..000000000 --- a/src/GF/Grammar/Unify.hs +++ /dev/null @@ -1,97 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Unify --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:31 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- (c) Petri Mäenpää & Aarne Ranta, 1998--2001 --- --- brute-force adaptation of the old-GF program AR 21\/12\/2001 --- --- the only use is in 'TypeCheck.splitConstraints' ------------------------------------------------------------------------------ - -module GF.Grammar.Unify (unifyVal) where - -import GF.Grammar -import GF.Data.Operations - -import Text.PrettyPrint -import Data.List (partition) - -unifyVal :: Constraints -> Err (Constraints,MetaSubst) -unifyVal cs0 = do - let (cs1,cs2) = partition notSolvable cs0 - let (us,vs) = unzip cs2 - 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 = [(MetaId, Term)] -type Constrs = [(Term, Term)] - -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 :: Term -> Term -> 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 - _ -> Bad (render (text "fail unify" <+> ppTerm Unqualified 0 e1)) - (RecType xs,RecType ys) | xs == ys -> return g - _ -> Bad (render (text "fail unify" <+> ppTerm Unqualified 0 e1)) - -extend :: Unifier -> MetaId -> Term -> Err Unifier -extend g s t | (t == Meta s) = return g - | occCheck s t = Bad (render (text "occurs check" <+> ppTerm Unqualified 0 t)) - | True = return ((s, t) : g) - -subst_all :: Unifier -> Term -> Err Term -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 :: [(MetaId,Term)] -> Term -> Term -substMetas subst trm = case trm of - Meta x -> case lookup x subst of - Just t -> t - _ -> trm - _ -> composSafeOp (substMetas subst) trm - -occCheck :: MetaId -> Term -> Bool -occCheck s u = case u of - Meta v -> s == v - App c a -> occCheck s c || occCheck s a - Abs _ x b -> occCheck s b - _ -> False - diff --git a/src/GF/Grammar/Values.hs b/src/GF/Grammar/Values.hs deleted file mode 100644 index 1a68ddc89..000000000 --- a/src/GF/Grammar/Values.hs +++ /dev/null @@ -1,96 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Values --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:32 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.7 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Grammar.Values (-- * values used in TC type checking - Exp, Val(..), Env, - -- * annotated tree used in editing ---Z Tree, TrNode(..), Atom(..), - Binds, Constraints, MetaSubst, - -- * for TC - valAbsInt, valAbsFloat, valAbsString, vType, - isPredefCat, - eType, ---Z tree2exp, loc2treeFocus - ) where - -import GF.Data.Operations ----Z import GF.Data.Zipper - -import GF.Infra.Ident -import GF.Grammar.Grammar -import GF.Grammar.Predef - --- values used in TC type checking - -type Exp = Term - -data Val = VGen Int Ident | VApp Val Val | VCn QIdent | VRecType [(Label,Val)] | 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 MetaId | AtV Ident | AtL String | AtI Integer | AtF Double - deriving (Eq,Show) --} -type Binds = [(Ident,Val)] -type Constraints = [(Val,Val)] -type MetaSubst = [(MetaId,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 - -eType :: Exp -eType = Sort cType - -{- -tree2exp :: Tree -> Exp -tree2exp (Tr (N (bi,at,_,_,_),ts)) = foldr Abs (foldl App at' ts') bi' where - at' = case at of - AtC (m,c) -> Q m c - AtV i -> Vr i - AtM m -> Meta m - AtL s -> K s - AtI s -> EInt s - AtF s -> EFloat s - bi' = map fst bi - ts' = map tree2exp ts - -loc2treeFocus :: Loc TrNode -> Tree -loc2treeFocus (Loc (Tr (a,ts),p)) = - loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p)) - where - (mark, nomark) = (\(N (a,b,c,d,_)) -> N(a,b,c,d,True), - \(N (a,b,c,d,_)) -> N(a,b,c,d,False)) --} diff --git a/src/GF/Infra/CheckM.hs b/src/GF/Infra/CheckM.hs deleted file mode 100644 index 8a1b42cdf..000000000 --- a/src/GF/Infra/CheckM.hs +++ /dev/null @@ -1,77 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CheckM --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:33 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Infra.CheckM - (Check, Message, runCheck, - checkError, checkCond, checkWarn, - checkErr, checkIn, checkMap - ) where - -import GF.Data.Operations -import GF.Infra.Ident -import GF.Grammar.Grammar -import GF.Grammar.Printer - -import qualified Data.Map as Map -import Text.PrettyPrint - -type Message = Doc -data CheckResult a - = Fail [Message] - | Success a [Message] -newtype Check a = Check {unCheck :: Context -> [Message] -> CheckResult a} - -instance Monad Check where - return x = Check (\ctxt msgs -> Success x msgs) - f >>= g = Check (\ctxt msgs -> case unCheck f ctxt msgs of - Success x msgs -> unCheck (g x) ctxt msgs - Fail msgs -> Fail msgs) - -instance ErrorMonad Check where - raise s = checkError (text s) - handle f h = Check (\ctxt msgs -> case unCheck f ctxt msgs of - Success x msgs -> Success x msgs - Fail (msg:msgs) -> unCheck (h (render msg)) ctxt msgs) - -checkError :: Message -> Check a -checkError msg = Check (\ctxt msgs -> Fail (msg : msgs)) - -checkCond :: Message -> Bool -> Check () -checkCond s b = if b then return () else checkError s - --- | warnings should be reversed in the end -checkWarn :: Message -> Check () -checkWarn msg = Check (\ctxt msgs -> Success () ((text "Warning:" <+> msg) : msgs)) - -runCheck :: Check a -> Err (a,String) -runCheck c = - case unCheck c [] [] of - Fail msgs -> Bad ( render (vcat (reverse msgs))) - Success v msgs -> Ok (v, render (vcat (reverse msgs))) - -checkMap :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b) -checkMap f map = do xs <- mapM (\(k,v) -> do v <- f k v - return (k,v)) (Map.toList map) - return (Map.fromAscList xs) - -checkErr :: Err a -> Check a -checkErr (Ok x) = return x -checkErr (Bad err) = checkError (text err) - -checkIn :: Doc -> Check a -> Check a -checkIn msg c = Check $ \ctxt msgs -> - case unCheck c ctxt [] of - Fail msgs' -> Fail ((msg $$ nest 3 (vcat (reverse msgs'))) : msgs) - Success v msgs' | null msgs' -> Success v msgs - | otherwise -> Success v ((msg $$ nest 3 (vcat (reverse msgs'))) : msgs) diff --git a/src/GF/Infra/CompactPrint.hs b/src/GF/Infra/CompactPrint.hs deleted file mode 100644 index 486c9e183..000000000 --- a/src/GF/Infra/CompactPrint.hs +++ /dev/null @@ -1,22 +0,0 @@ -module GF.Infra.CompactPrint where -import Data.Char - -compactPrint = compactPrintCustom keywordGF (const False) - -compactPrintGFCC = compactPrintCustom (const False) keywordGFCC - -compactPrintCustom pre post = dps . concat . map (spaceIf pre post) . words - -dps = dropWhile isSpace - -spaceIf pre post w = case w of - _ | pre w -> "\n" ++ w - _ | post w -> w ++ "\n" - c:_ | isAlpha c || isDigit c -> " " ++ w - '_':_ -> " " ++ w - _ -> w - -keywordGF w = elem w ["cat","fun","lin","lincat","lindef","oper","param"] -keywordGFCC w = - last w == ';' || - elem w ["flags","fun","cat","lin","oper","lincat","lindef","printname","param"] diff --git a/src/GF/Infra/Dependencies.hs b/src/GF/Infra/Dependencies.hs deleted file mode 100644 index af2088711..000000000 --- a/src/GF/Infra/Dependencies.hs +++ /dev/null @@ -1,61 +0,0 @@ -module GF.Infra.Dependencies ( - depGraph - ) where - -import GF.Grammar.Grammar -import GF.Infra.Modules -import GF.Infra.Ident - -depGraph :: SourceGrammar -> String -depGraph = prDepGraph . grammar2moddeps - -prDepGraph :: [(Ident,ModDeps)] -> String -prDepGraph deps = unlines $ [ - "digraph {" - ] ++ - map mkNode deps ++ - concatMap mkArrows deps ++ [ - "}" - ] - where - mkNode (i,dep) = unwords [showIdent i, "[",nodeAttr (modtype dep),"]"] - nodeAttr ty = case ty of - MTAbstract -> "style = \"solid\", shape = \"box\"" - MTConcrete _ -> "style = \"solid\", shape = \"ellipse\"" - _ -> "style = \"dashed\", shape = \"ellipse\"" - mkArrows (i,dep) = - [unwords [showIdent i,"->",showIdent j,"[",arrowAttr "of","]"] | j <- ofs dep] ++ - [unwords [showIdent i,"->",showIdent j,"[",arrowAttr "ex","]"] | j <- extendeds dep] ++ - [unwords [showIdent i,"->",showIdent j,"[",arrowAttr "op","]"] | j <- openeds dep] ++ - [unwords [showIdent i,"->",showIdent j,"[",arrowAttr "ed","]"] | j <- extrads dep] - arrowAttr s = case s of - "of" -> "style = \"solid\", arrowhead = \"empty\"" - "ex" -> "style = \"solid\"" - "op" -> "style = \"dashed\"" - "ed" -> "style = \"dotted\"" - -data ModDeps = ModDeps { - modtype :: ModuleType Ident, - ofs :: [Ident], - extendeds :: [Ident], - openeds :: [Ident], - extrads :: [Ident], - functors :: [Ident], - interfaces :: [Ident], - instances :: [Ident] - } - -noModDeps = ModDeps MTAbstract [] [] [] [] [] [] [] - -grammar2moddeps :: SourceGrammar -> [(Ident,ModDeps)] -grammar2moddeps gr = [(i,depMod m) | (i,m) <- modules gr] where - depMod m = noModDeps{ - modtype = mtype m, - ofs = case mtype m of - MTConcrete i -> [i] - MTInstance i -> [i] - _ -> [], - extendeds = map fst (extend m), - openeds = map openedModule (opens m), - extrads = mexdeps m - } diff --git a/src/GF/Infra/GetOpt.hs b/src/GF/Infra/GetOpt.hs deleted file mode 100644 index ede561c90..000000000 --- a/src/GF/Infra/GetOpt.hs +++ /dev/null @@ -1,381 +0,0 @@ --- This is a version of System.Console.GetOpt which has been hacked to --- support long options with a single dash. Since we don't want the annoying --- clash with short options that start with the same character as a long --- one, we don't allow short options to be given together (e.g. -zxf), --- nor do we allow options to be given as any unique prefix. - ------------------------------------------------------------------------------ --- | --- Module : System.Console.GetOpt --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- This library provides facilities for parsing the command-line options --- in a standalone program. It is essentially a Haskell port of the GNU --- @getopt@ library. --- ------------------------------------------------------------------------------ - -{- -Sven Panne Oct. 1996 (small -changes Dec. 1997) - -Two rather obscure features are missing: The Bash 2.0 non-option hack -(if you don't already know it, you probably don't want to hear about -it...) and the recognition of long options with a single dash -(e.g. '-help' is recognised as '--help', as long as there is no short -option 'h'). - -Other differences between GNU's getopt and this implementation: - -* To enforce a coherent description of options and arguments, there - are explanation fields in the option/argument descriptor. - -* Error messages are now more informative, but no longer POSIX - compliant... :-( - -And a final Haskell advertisement: The GNU C implementation uses well -over 1100 lines, we need only 195 here, including a 46 line example! -:-) --} - ---module System.Console.GetOpt ( -module GF.Infra.GetOpt ( - -- * GetOpt - getOpt, getOpt', - usageInfo, - ArgOrder(..), - OptDescr(..), - ArgDescr(..), - - -- * Examples - - -- |To hopefully illuminate the role of the different data structures, - -- here are the command-line options for a (very simple) compiler, - -- done in two different ways. - -- The difference arises because the type of 'getOpt' is - -- parameterized by the type of values derived from flags. - - -- ** Interpreting flags as concrete values - -- $example1 - - -- ** Interpreting flags as transformations of an options record - -- $example2 -) where - -import Prelude -- necessary to get dependencies right - -import Data.List ( isPrefixOf, find ) - --- |What to do with options following non-options -data ArgOrder a - = RequireOrder -- ^ no option processing after first non-option - | Permute -- ^ freely intersperse options and non-options - | ReturnInOrder (String -> a) -- ^ wrap non-options into options - -{-| -Each 'OptDescr' describes a single option. - -The arguments to 'Option' are: - -* list of short option characters - -* list of long option strings (without \"--\") - -* argument descriptor - -* explanation of option for user --} -data OptDescr a = -- description of a single options: - Option [Char] -- list of short option characters - [String] -- list of long option strings (without "--") - (ArgDescr a) -- argument descriptor - String -- explanation of option for user - --- |Describes whether an option takes an argument or not, and if so --- how the argument is injected into a value of type @a@. -data ArgDescr a - = NoArg a -- ^ no argument expected - | ReqArg (String -> a) String -- ^ option requires argument - | OptArg (Maybe String -> a) String -- ^ optional argument - -data OptKind a -- kind of cmd line arg (internal use only): - = Opt a -- an option - | UnreqOpt String -- an un-recognized option - | NonOpt String -- a non-option - | EndOfOpts -- end-of-options marker (i.e. "--") - | OptErr String -- something went wrong... - --- | Return a string describing the usage of a command, derived from --- the header (first argument) and the options described by the --- second argument. -usageInfo :: String -- header - -> [OptDescr a] -- option descriptors - -> String -- nicely formatted decription of options -usageInfo header optDescr = unlines (header:table) - where (ss,ls,ds) = (unzip3 . concatMap fmtOpt) optDescr - table = zipWith3 paste (sameLen ss) (sameLen ls) ds - paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z - sameLen xs = flushLeft ((maximum . map length) xs) xs - flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ] - -fmtOpt :: OptDescr a -> [(String,String,String)] -fmtOpt (Option sos los ad descr) = - case lines descr of - [] -> [(sosFmt,losFmt,"")] - (d:ds) -> (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ] - where sepBy _ [] = "" - sepBy _ [x] = x - sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs - sosFmt = sepBy ',' (map (fmtShort ad) sos) - losFmt = sepBy ',' (map (fmtLong ad) los) - -fmtShort :: ArgDescr a -> Char -> String -fmtShort (NoArg _ ) so = "-" ++ [so] -fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad -fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]" - -fmtLong :: ArgDescr a -> String -> String -fmtLong (NoArg _ ) lo = "--" ++ lo -fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad -fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" - -{-| -Process the command-line, and return the list of values that matched -(and those that didn\'t). The arguments are: - -* The order requirements (see 'ArgOrder') - -* The option descriptions (see 'OptDescr') - -* The actual command line arguments (presumably got from - 'System.Environment.getArgs'). - -'getOpt' returns a triple consisting of the option arguments, a list -of non-options, and a list of error messages. --} -getOpt :: ArgOrder a -- non-option handling - -> [OptDescr a] -- option descriptors - -> [String] -- the command-line arguments - -> ([a],[String],[String]) -- (options,non-options,error messages) -getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) - where (os,xs,us,es) = getOpt' ordering optDescr args - -{-| -This is almost the same as 'getOpt', but returns a quadruple -consisting of the option arguments, a list of non-options, a list of -unrecognized options, and a list of error messages. --} -getOpt' :: ArgOrder a -- non-option handling - -> [OptDescr a] -- option descriptors - -> [String] -- the command-line arguments - -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) -getOpt' _ _ [] = ([],[],[],[]) -getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering - where procNextOpt (Opt o) _ = (o:os,xs,us,es) - procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) - procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) - procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) - procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) - procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) - procNextOpt EndOfOpts Permute = ([],rest,[],[]) - procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) - procNextOpt (OptErr e) _ = (os,xs,us,e:es) - - (opt,rest) = getNext arg args optDescr - (os,xs,us,es) = getOpt' ordering optDescr rest - --- take a look at the next cmd line arg and decide what to do with it -getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) -getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr -getNext ('-' :xs) rest optDescr = longOpt xs rest optDescr -getNext a rest _ = (NonOpt a,rest) - --- handle long option -longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -longOpt ls rs optDescr = long ads arg rs - where (opt,arg) = break (=='=') ls - options = [ o | o@(Option ss xs _ _) <- optDescr - , opt `elem` map (:[]) ss || opt `elem` xs ] - ads = [ ad | Option _ _ ad _ <- options ] - optStr = ("--"++opt) - - long (_:_:_) _ rest = (errAmbig options optStr,rest) - long [NoArg a ] [] rest = (Opt a,rest) - long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) - long [ReqArg _ d] [] [] = (errReq d optStr,[]) - long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) - long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) - long [OptArg f _] [] rest = (Opt (f Nothing),rest) - long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) - long _ _ rest = (UnreqOpt ("--"++ls),rest) - - --- miscellaneous error formatting - -errAmbig :: [OptDescr a] -> String -> OptKind a -errAmbig ods optStr = OptErr (usageInfo header ods) - where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" - -errReq :: String -> String -> OptKind a -errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") - -errUnrec :: String -> String -errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" - -errNoArg :: String -> OptKind a -errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") - -{- ------------------------------------------------------------------------------------------ --- and here a small and hopefully enlightening example: - -data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show - -options :: [OptDescr Flag] -options = - [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files", - Option ['V','?'] ["version","release"] (NoArg Version) "show version info", - Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump", - Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"] - -out :: Maybe String -> Flag -out Nothing = Output "stdout" -out (Just o) = Output o - -test :: ArgOrder Flag -> [String] -> String -test order cmdline = case getOpt order options cmdline of - (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n" - (_,_,errs) -> concat errs ++ usageInfo header options - where header = "Usage: foobar [OPTION...] files..." - --- example runs: --- putStr (test RequireOrder ["foo","-v"]) --- ==> options=[] args=["foo", "-v"] --- putStr (test Permute ["foo","-v"]) --- ==> options=[Verbose] args=["foo"] --- putStr (test (ReturnInOrder Arg) ["foo","-v"]) --- ==> options=[Arg "foo", Verbose] args=[] --- putStr (test Permute ["foo","--","-v"]) --- ==> options=[] args=["foo", "-v"] --- putStr (test Permute ["-?o","--name","bar","--na=baz"]) --- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[] --- putStr (test Permute ["--ver","foo"]) --- ==> option `--ver' is ambiguous; could be one of: --- -v --verbose verbosely list files --- -V, -? --version, --release show version info --- Usage: foobar [OPTION...] files... --- -v --verbose verbosely list files --- -V, -? --version, --release show version info --- -o[FILE] --output[=FILE] use FILE for dump --- -n USER --name=USER only dump USER's files ------------------------------------------------------------------------------------------ --} - -{- $example1 - -A simple choice for the type associated with flags is to define a type -@Flag@ as an algebraic type representing the possible flags and their -arguments: - -> module Opts1 where -> -> import System.Console.GetOpt -> import Data.Maybe ( fromMaybe ) -> -> data Flag -> = Verbose | Version -> | Input String | Output String | LibDir String -> deriving Show -> -> options :: [OptDescr Flag] -> options = -> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr" -> , Option ['V','?'] ["version"] (NoArg Version) "show version number" -> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE" -> , Option ['c'] [] (OptArg inp "FILE") "input FILE" -> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory" -> ] -> -> inp,outp :: Maybe String -> Flag -> outp = Output . fromMaybe "stdout" -> inp = Input . fromMaybe "stdin" -> -> compilerOpts :: [String] -> IO ([Flag], [String]) -> compilerOpts argv = -> case getOpt Permute options argv of -> (o,n,[] ) -> return (o,n) -> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) -> where header = "Usage: ic [OPTION...] files..." - -Then the rest of the program will use the constructed list of flags -to determine it\'s behaviour. - --} - -{- $example2 - -A different approach is to group the option values in a record of type -@Options@, and have each flag yield a function of type -@Options -> Options@ transforming this record. - -> module Opts2 where -> -> import System.Console.GetOpt -> import Data.Maybe ( fromMaybe ) -> -> data Options = Options -> { optVerbose :: Bool -> , optShowVersion :: Bool -> , optOutput :: Maybe FilePath -> , optInput :: Maybe FilePath -> , optLibDirs :: [FilePath] -> } deriving Show -> -> defaultOptions = Options -> { optVerbose = False -> , optShowVersion = False -> , optOutput = Nothing -> , optInput = Nothing -> , optLibDirs = [] -> } -> -> options :: [OptDescr (Options -> Options)] -> options = -> [ Option ['v'] ["verbose"] -> (NoArg (\ opts -> opts { optVerbose = True })) -> "chatty output on stderr" -> , Option ['V','?'] ["version"] -> (NoArg (\ opts -> opts { optShowVersion = True })) -> "show version number" -> , Option ['o'] ["output"] -> (OptArg ((\ f opts -> opts { optOutput = Just f }) . fromMaybe "output") -> "FILE") -> "output FILE" -> , Option ['c'] [] -> (OptArg ((\ f opts -> opts { optInput = Just f }) . fromMaybe "input") -> "FILE") -> "input FILE" -> , Option ['L'] ["libdir"] -> (ReqArg (\ d opts -> opts { optLibDirs = optLibDirs opts ++ [d] }) "DIR") -> "library directory" -> ] -> -> compilerOpts :: [String] -> IO (Options, [String]) -> compilerOpts argv = -> case getOpt Permute options argv of -> (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n) -> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) -> where header = "Usage: ic [OPTION...] files..." - -Similarly, each flag could yield a monadic function transforming a record, -of type @Options -> IO Options@ (or any other monad), allowing option -processing to perform actions of the chosen monad, e.g. printing help or -version messages, checking that file arguments exist, etc. - --} diff --git a/src/GF/Infra/Ident.hs b/src/GF/Infra/Ident.hs deleted file mode 100644 index efe6f9261..000000000 --- a/src/GF/Infra/Ident.hs +++ /dev/null @@ -1,152 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Ident --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/15 11:43:33 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.8 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Infra.Ident (-- * Identifiers - Ident(..), ident2bs, showIdent, - identC, identV, identA, identAV, identW, - argIdent, varStr, varX, isWildIdent, varIndex, - -- * refreshing identifiers - IdState, initIdStateN, initIdState, - lookVar, refVar, refVarPlus - ) where - -import GF.Data.Operations -import qualified Data.ByteString.Char8 as BS --- import Monad - - --- | the constructors labelled /INTERNAL/ are --- internal representation never returned by the parser -data Ident = - IC {-# UNPACK #-} !BS.ByteString -- ^ raw identifier after parsing, resolved in Rename - | IW -- ^ wildcard --- --- below this constructor: internal representation never returned by the parser - | IV {-# UNPACK #-} !BS.ByteString {-# UNPACK #-} !Int -- ^ /INTERNAL/ variable - | IA {-# UNPACK #-} !BS.ByteString {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat at position - | IAV {-# UNPACK #-} !BS.ByteString {-# UNPACK #-} !Int {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat with bindings at position --- - - deriving (Eq, Ord, Show, Read) - -ident2bs :: Ident -> BS.ByteString -ident2bs i = case i of - IC s -> s - IV s n -> BS.append s (BS.pack ('_':show n)) - IA s j -> BS.append s (BS.pack ('_':show j)) - IAV s b j -> BS.append s (BS.pack ('_':show b ++ '_':show j)) - IW -> BS.pack "_" - -showIdent :: Ident -> String -showIdent i = BS.unpack $! ident2bs i - -identC :: BS.ByteString -> Ident -identV :: BS.ByteString -> Int -> Ident -identA :: BS.ByteString -> Int -> Ident -identAV:: BS.ByteString -> 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 -varStr :: Ident -varStr = identA (BS.pack "str") 0 - --- | refreshing variables -varX :: Int -> Ident -varX = identV (BS.pack "x") - -isWildIdent :: Ident -> Bool -isWildIdent x = case x of - IW -> True - IC s | s == BS.pack "_" -> True - _ -> False - -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 (ident2bs x) m - updateSTM (\(sys,mx) -> ((x, x'):sys, mx + 1)) - return x' - -refVarPlus :: Ident -> STM IdState Ident -----refVarPlus IW = refVar (identC "h") -refVarPlus x = refVar x - - -{- ------------------------------- --- to test - -refreshExp :: Exp -> Err Exp -refreshExp e = err Bad (return . fst) (appSTM (refresh e) initState) - -refresh :: Exp -> STM State Exp -refresh e = case e of - Atom x -> lookVar x >>= return . Atom - App f a -> liftM2 App (refresh f) (refresh a) - Abs x b -> liftM2 Abs (refVar x) (refresh b) - Fun xs a b -> do - a' <- refresh a - xs' <- mapM refVar xs - b' <- refresh b - return $ Fun xs' a' b' - -data Exp = - Atom Ident - | App Exp Exp - | Abs Ident Exp - | Fun [Ident] Exp Exp - deriving Show - -exp1 = Abs (IC "y") (Atom (IC "y")) -exp2 = Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y"))) -exp3 = Abs (IC "y") (Abs (IC "z") (App (Atom (IC "y")) (Atom (IC "z")))) -exp4 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "z")))) -exp5 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y")))) -exp6 = Abs (IC "y") (Fun [IC "x", IC "y"] (Atom (IC "y")) (Atom (IC "y"))) -exp7 = Abs (IL "8") (Atom (IC "y")) - --} diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs deleted file mode 100644 index 0710b8f40..000000000 --- a/src/GF/Infra/Modules.hs +++ /dev/null @@ -1,349 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Modules --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/09 15:14:30 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.26 $ --- --- Datastructures and functions for modules, common to GF and GFC. --- --- AR 29\/4\/2003 --- --- The same structure will be used in both source code and canonical. --- The parameters tell what kind of data is involved. --- Invariant: modules are stored in dependency order ------------------------------------------------------------------------------ - -module GF.Infra.Modules ( - MGrammar(..), ModInfo(..), ModuleType(..), - MInclude (..), - extends, isInherited,inheritAll, - updateMGrammar, updateModule, replaceJudgements, addFlag, - addOpenQualif, flagsModule, allFlags, mapModules, - OpenSpec(..), - ModuleStatus(..), - openedModule, depPathModule, allDepsModule, partOfGrammar, - allExtends, allExtendSpecs, allExtendsPlus, allExtensions, - searchPathModule, addModule, - emptyMGrammar, emptyModInfo, - IdentM(..), - abstractOfConcrete, abstractModOfConcrete, - lookupModule, lookupModuleType, lookupInfo, - lookupPosition, ppPosition, - isModAbs, isModRes, isModCnc, - 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 -import Text.PrettyPrint - --- 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 - -newtype MGrammar i a = MGrammar {modules :: [(i,ModInfo i a)]} - deriving Show - -data ModInfo i a = ModInfo { - mtype :: ModuleType i , - mstatus :: ModuleStatus , - flags :: Options, - extend :: [(i,MInclude i)], - mwith :: Maybe (i,MInclude i,[(i,i)]), - opens :: [OpenSpec i] , - mexdeps :: [i] , - jments :: BinTree i a , - positions :: BinTree i (String,(Int,Int)) -- file, first line, last line - } - deriving Show - --- | encoding the type of the module -data ModuleType i = - MTAbstract - | MTResource - | MTConcrete i - -- ^ up to this, also used in GFC. Below, source only. - | MTInterface - | MTInstance i - deriving (Eq,Ord,Show) - -data MInclude i = MIAll | MIOnly [i] | MIExcept [i] - deriving (Eq,Ord,Show) - -extends :: ModInfo i 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 a -> MGrammar i a -> MGrammar i 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 => ModInfo i t -> i -> t -> ModInfo i t -updateModule (ModInfo mt ms fs me mw ops med js ps) i t = ModInfo mt ms fs me mw ops med (updateTree (i,t) js) ps - -replaceJudgements :: ModInfo i t -> BinTree i t -> ModInfo i t -replaceJudgements (ModInfo mt ms fs me mw ops med _ ps) js = ModInfo mt ms fs me mw ops med js ps - -addOpenQualif :: i -> i -> ModInfo i t -> ModInfo i t -addOpenQualif i j (ModInfo mt ms fs me mw ops med js ps) = ModInfo mt ms fs me mw (OQualif i j : ops) med js ps - -addFlag :: Options -> ModInfo i t -> ModInfo i t -addFlag f mo = mo {flags = flags mo `addOptions` f} - -flagsModule :: (i,ModInfo i a) -> Options -flagsModule (_,mi) = flags mi - -allFlags :: MGrammar i a -> Options -allFlags gr = concatOptions [flags m | (_,m) <- modules gr] - -mapModules :: (ModInfo i a -> ModInfo i a) -> MGrammar i a -> MGrammar i a -mapModules f (MGrammar ms) = MGrammar (map (onSnd f) ms) - -data OpenSpec i = - OSimple i - | OQualif i i - deriving (Eq,Ord,Show) - -data ModuleStatus = - MSComplete - | MSIncomplete - deriving (Eq,Ord,Show) - -openedModule :: OpenSpec i -> i -openedModule o = case o of - OSimple m -> m - OQualif _ m -> m - --- | initial dependency list -depPathModule :: Ord i => ModInfo i a -> [OpenSpec i] -depPathModule m = fors m ++ exts m ++ opens m - where - fors m = - case mtype m of - MTConcrete i -> [OSimple i] - MTInstance i -> [OSimple i] - _ -> [] - exts m = map OSimple (extends m) - --- | all dependencies -allDepsModule :: Ord i => MGrammar i a -> ModInfo i a -> [OpenSpec i] -allDepsModule gr m = iterFix add os0 where - os0 = depPathModule m - add os = [m | o <- os, Just 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 a -> (i,ModInfo i a) -> MGrammar i a -partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor] - where - mods = modules gr - modsFor = (i:) $ map openedModule $ allDepsModule gr m - --- | all modules that a module extends, directly or indirectly, without restricts -allExtends :: (Show i,Ord i) => MGrammar i a -> i -> [i] -allExtends gr i = - case lookupModule gr i of - Ok 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 a -> i -> [(i,MInclude i)] -allExtendSpecs gr i = - case lookupModule gr i of - Ok 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 a -> i -> [i] -allExtendsPlus gr i = - case lookupModule gr i of - Ok 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 a -> i -> [i] -allExtensions gr i = - case lookupModule gr i of - Ok 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 = modules gr - --- | initial search path: the nonqualified dependencies -searchPathModule :: Ord i => ModInfo i 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 a -> i -> ModInfo i a -> MGrammar i a -addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)]) - -emptyMGrammar :: MGrammar i a -emptyMGrammar = MGrammar [] - -emptyModInfo :: ModInfo i a -emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] emptyBinTree emptyBinTree - --- | we store the module type with the identifier -data IdentM i = IdentM { - identM :: i , - typeM :: ModuleType i - } - deriving (Eq,Ord,Show) - -abstractOfConcrete :: (Show i, Eq i) => MGrammar i a -> i -> Err i -abstractOfConcrete gr c = do - n <- lookupModule gr c - case mtype n of - MTConcrete a -> return a - _ -> Bad $ "expected concrete" +++ show c - -abstractModOfConcrete :: (Show i, Eq i) => - MGrammar i a -> i -> Err (ModInfo i a) -abstractModOfConcrete gr c = do - a <- abstractOfConcrete gr c - lookupModule gr a - - --- the canonical file name - ---- canonFileName s = prt s ++ ".gfc" - -lookupModule :: (Show i,Eq i) => MGrammar i a -> i -> Err (ModInfo i 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 a -> i -> Err (ModuleType i) -lookupModuleType gr m = do - mi <- lookupModule gr m - return $ mtype mi - -lookupInfo :: (Show i, Ord i) => ModInfo i a -> i -> Err a -lookupInfo mo i = lookupTree show i (jments mo) - -lookupPosition :: (Show i, Ord i) => ModInfo i a -> i -> Err (String,(Int,Int)) -lookupPosition mo i = lookupTree show i (positions mo) - -ppPosition :: (Show i, Ord i) => ModInfo i a -> i -> Doc -ppPosition mo i = case lookupPosition mo i of - Ok (f,(b,e)) | b == e -> text "in" <+> text f <> text ", line" <+> int b - | otherwise -> text "in" <+> text f <> text ", lines" <+> int b <> text "-" <> int e - _ -> empty - -isModAbs :: ModInfo i a -> Bool -isModAbs m = case mtype m of - MTAbstract -> True ----- MTUnion t -> isModAbs t - _ -> False - -isModRes :: ModInfo i a -> Bool -isModRes m = case mtype m of - MTResource -> True - MTInterface -> True --- - MTInstance _ -> True - _ -> False - -isModCnc :: ModInfo i a -> Bool -isModCnc m = case mtype m of - MTConcrete _ -> True - _ -> 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 - (MTInterface, MTConcrete _) -> 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 a -> Bool -isCompilableModule m = - case mtype m of - MTInterface -> False - _ -> mstatus m == MSComplete - --- | interface and "incomplete M" are not complete -isCompleteModule :: (Eq i) => ModInfo i a -> Bool -isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface - - --- | all abstract modules sorted from least to most dependent -allAbstracts :: (Ord i, Show i) => MGrammar i a -> [i] -allAbstracts gr = - case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of - Left is -> is - Right cycles -> error $ "Cyclic abstract modules: " ++ show cycles - --- | the last abstract in dependency order (head of list) -greatestAbstract :: (Ord i, Show i) => MGrammar i a -> Maybe i -greatestAbstract gr = case allAbstracts gr of - [] -> Nothing - as -> return $ last as - --- | all resource modules -allResources :: MGrammar i a -> [i] -allResources gr = [i | (i,m) <- modules gr, isModRes m || isModCnc m] - --- | the greatest resource in dependency order -greatestResource :: MGrammar i a -> Maybe i -greatestResource gr = case allResources gr of - [] -> Nothing - a -> return $ head a ---- why not last as in Abstract? works though AR 24/5/2008 - --- | all concretes for a given abstract -allConcretes :: Eq i => MGrammar i a -> i -> [i] -allConcretes gr a = - [i | (i, m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m] - --- | all concrete modules for any abstract -allConcreteModules :: Eq i => MGrammar i a -> [i] -allConcreteModules gr = - [i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m] diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs deleted file mode 100644 index dc15d1929..000000000 --- a/src/GF/Infra/Option.hs +++ /dev/null @@ -1,609 +0,0 @@ -module GF.Infra.Option - ( - -- * Option types - Options, - Flags(..), - Mode(..), Phase(..), Verbosity(..), Encoding(..), OutputFormat(..), - SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..), - Dump(..), Printer(..), Recomp(..), BuildParser(..), - -- * Option parsing - parseOptions, parseModuleOptions, fixRelativeLibPaths, - -- * Option pretty-printing - optionsGFO, - optionsPGF, - -- * Option manipulation - addOptions, concatOptions, noOptions, - modifyFlags, - helpMessage, - -- * Checking specific options - flag, cfgTransform, haskellOption, readOutputFormat, - isLexicalCat, encodings, - -- * Setting specific options - setOptimization, setCFGTransform, - -- * Convenience methods for checking options - verbAtLeast, dump - ) where - -import Control.Monad -import Data.Char (toLower) -import Data.List -import Data.Maybe -import GF.Infra.GetOpt ---import System.Console.GetOpt -import System.FilePath - -import GF.Data.ErrM - -import Data.Set (Set) -import qualified Data.Set as Set - - - - -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.", - ".gfo 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, .gfo or .gfe files.", - "For the other input formats, only one file can be given.", - "", - "Command-line options:"] - - -helpMessage :: String -helpMessage = usageInfo usageHeader optDescr - - --- FIXME: do we really want multi-line errors? -errors :: [String] -> Err a -errors = fail . unlines - --- Types - -data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeRun | ModeCompiler - deriving (Show,Eq,Ord) - -data Verbosity = Quiet | Normal | Verbose | Debug - deriving (Show,Eq,Ord,Enum,Bounded) - -data Phase = Preproc | Convert | Compile | Link - deriving (Show,Eq,Ord) - -data Encoding = UTF_8 | ISO_8859_1 | CP_1250 | CP_1251 | CP_1252 - deriving (Eq,Ord) - -data OutputFormat = FmtPGFPretty - | FmtPMCFGPretty - | FmtJavaScript - | FmtHaskell - | FmtProlog - | FmtProlog_Abs - | FmtBNF - | FmtEBNF - | FmtRegular - | FmtNoLR - | FmtSRGS_XML - | FmtSRGS_XML_NonRec - | FmtSRGS_ABNF - | FmtSRGS_ABNF_NonRec - | FmtJSGF - | FmtGSL - | FmtVoiceXML - | FmtSLF - | FmtRegExp - | FmtFA - deriving (Eq,Ord) - -data SISRFormat = - -- | SISR Working draft 1 April 2003 - -- - SISR_WD20030401 - | SISR_1_0 - deriving (Show,Eq,Ord) - -data Optimization = OptStem | OptCSE | OptExpand | OptParametrize - deriving (Show,Eq,Ord) - -data CFGTransform = CFGNoLR - | CFGRegular - | CFGTopDownFilter - | CFGBottomUpFilter - | CFGStartCatOnly - | CFGMergeIdentical - | CFGRemoveCycles - deriving (Show,Eq,Ord) - -data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical - deriving (Show,Eq,Ord) - -data Warning = WarnMissingLincat - deriving (Show,Eq,Ord) - -data Dump = DumpSource | DumpRebuild | DumpExtend | DumpRename | DumpTypeCheck | DumpRefresh | DumpOptimize | DumpCanon - deriving (Show,Eq,Ord) - --- | Pretty-printing options -data Printer = PrinterStrip -- ^ Remove name qualifiers. - deriving (Show,Eq,Ord) - -data Recomp = AlwaysRecomp | RecompIfNewer | NeverRecomp - deriving (Show,Eq,Ord) - -data BuildParser = BuildParser | DontBuildParser | BuildParserOnDemand - deriving (Show,Eq,Ord) - -data Flags = Flags { - optMode :: Mode, - optStopAfterPhase :: Phase, - optVerbosity :: Verbosity, - optProf :: Bool, - optShowCPUTime :: Bool, - optEmitGFO :: Bool, - optOutputFormats :: [OutputFormat], - optSISR :: Maybe SISRFormat, - optHaskellOptions :: Set HaskellOption, - optLexicalCats :: Set String, - optGFODir :: Maybe FilePath, - optOutputFile :: Maybe FilePath, - optOutputDir :: Maybe FilePath, - optGFLibPath :: Maybe FilePath, - optRecomp :: Recomp, - optPrinter :: [Printer], - optProb :: Bool, - optRetainResource :: Bool, - optName :: Maybe String, - optAbsName :: Maybe String, - optCncName :: Maybe String, - optResName :: Maybe String, - optPreprocessors :: [String], - optEncoding :: Encoding, - optOptimizations :: Set Optimization, - optCFGTransforms :: Set CFGTransform, - optLibraryPath :: [FilePath], - optStartCat :: Maybe String, - optSpeechLanguage :: Maybe String, - optLexer :: Maybe String, - optUnlexer :: Maybe String, - optErasing :: Bool, - optBuildParser :: BuildParser, - optWarnings :: [Warning], - optDump :: [Dump] - } - deriving (Show) - -newtype Options = Options (Flags -> Flags) - -instance Show Options where - show (Options o) = show (o defaultFlags) - --- Option parsing - -parseOptions :: [String] -- ^ list of string arguments - -> Err (Options, [FilePath]) -parseOptions args - | not (null errs) = errors errs - | otherwise = do opts <- liftM concatOptions $ sequence optss - return (opts, files) - where - (optss, files, errs) = getOpt RequireOrder optDescr args - -parseModuleOptions :: [String] -- ^ list of string arguments - -> Err Options -parseModuleOptions args = do - (opts,nonopts) <- parseOptions args - if null nonopts - then return opts - else errors $ map ("Non-option among module options: " ++) nonopts - -fixRelativeLibPaths curr_dir lib_dir (Options o) = Options (fixPathFlags . o) - where - fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [curr_dir dir, lib_dir dir]) path} - --- Showing options - --- | Pretty-print the options that are preserved in .gfo files. -optionsGFO :: Options -> [(String,String)] -optionsGFO opts = optionsPGF opts - ++ [("coding", show (flag optEncoding opts))] - --- | Pretty-print the options that are preserved in .pgf files. -optionsPGF :: Options -> [(String,String)] -optionsPGF opts = - maybe [] (\x -> [("language",x)]) (flag optSpeechLanguage opts) - ++ maybe [] (\x -> [("startcat",x)]) (flag optStartCat opts) - ++ (if flag optErasing opts then [("erasing","on")] else []) - ++ (if flag optBuildParser opts == BuildParserOnDemand then [("parser","ondemand")] else []) - --- Option manipulation - -flag :: (Flags -> a) -> Options -> a -flag f (Options o) = f (o defaultFlags) - -addOptions :: Options -> Options -> Options -addOptions (Options o1) (Options o2) = Options (o2 . o1) - -noOptions :: Options -noOptions = Options id - -concatOptions :: [Options] -> Options -concatOptions = foldr addOptions noOptions - -modifyFlags :: (Flags -> Flags) -> Options -modifyFlags = Options - --- Default options - -defaultFlags :: Flags -defaultFlags = Flags { - optMode = ModeInteractive, - optStopAfterPhase = Compile, - optVerbosity = Normal, - optProf = False, - optShowCPUTime = False, - optEmitGFO = True, - optOutputFormats = [], - optSISR = Nothing, - optHaskellOptions = Set.empty, - optLexicalCats = Set.empty, - optGFODir = Nothing, - optOutputFile = Nothing, - optOutputDir = Nothing, - optGFLibPath = Nothing, - optRecomp = RecompIfNewer, - optPrinter = [], - optProb = False, - optRetainResource = False, - - optName = Nothing, - optAbsName = Nothing, - optCncName = Nothing, - optResName = Nothing, - optPreprocessors = [], - optEncoding = ISO_8859_1, - optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize], - optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter, - CFGTopDownFilter, CFGMergeIdentical], - optLibraryPath = [], - optStartCat = Nothing, - optSpeechLanguage = Nothing, - optLexer = Nothing, - optUnlexer = Nothing, - optErasing = True, - optBuildParser = BuildParser, - optWarnings = [], - optDump = [] - } - --- Option descriptions - -optDescr :: [OptDescr (Err Options)] -optDescr = - [ - Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.", - Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.", - Option ['v'] ["verbose"] (OptArg verbosity "N") "Set verbosity (default 1). -v alone is the same as -v 2.", - Option ['q','s'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.", - Option [] ["batch"] (NoArg (mode ModeCompiler)) "Run in batch compiler mode.", - Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).", - Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).", - 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 (default) .", - Option [] ["make"] (NoArg (liftM2 addOptions (mode ModeCompiler) (phase Link))) "Build .pgf file and other output files and exit.", - Option [] ["prof"] (NoArg (prof True)) "Dump profiling information when compiling to PMCFG", - 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: pgf (default), gar, js, prolog, ...", - "Single concrete only: cf, bnf, lbnf, gsl, srgs_xml, srgs_abnf, ...", - "Abstract only: haskell, prolog_abs, ..."]), - Option [] ["sisr"] (ReqArg sisrFmt "FMT") - (unlines ["Include SISR tags in generated speech recognition grammars.", - "FMT can be one of: old, 1.0"]), - Option [] ["haskell"] (ReqArg hsOption "OPTION") - ("Turn on an optional feature when generating Haskell data types. OPTION = " - ++ concat (intersperse " | " (map fst haskellOptionNames))), - Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]") - "Treat CAT as a lexical category.", - 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 .gfo files) in DIR.", - Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR") - "Overides the value of GF_LIB_PATH.", - Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp)) - "Always recompile from source.", - Option [] ["gfo","recomp-if-newer"] (NoArg (recomp RecompIfNewer)) - "(default) Recompile from source if the source is newer than the .gfo file.", - Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp)) - "Never recompile from source, if there is already .gfo file.", - Option [] ["strip"] (NoArg (printer PrinterStrip)) - "Remove name qualifiers when pretty-printing.", - Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.", - Option [] ["prob"] (NoArg (prob True)) "Read probabilities from '--# prob' pragmas.", - Option ['n'] ["name"] (ReqArg name "NAME") - (unlines ["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 [] ["abs"] (ReqArg absName "NAME") - ("Use NAME as the name of the abstract syntax module generated from " - ++ "a grammar in GF 1 format."), - Option [] ["cnc"] (ReqArg cncName "NAME") - ("Use NAME as the name of the concrete syntax module generated from " - ++ "a grammar in GF 1 format."), - Option [] ["res"] (ReqArg resName "NAME") - ("Use NAME as the name of the resource module generated from " - ++ "a grammar in GF 1 format."), - 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 [] ["coding"] (ReqArg coding "ENCODING") - ("Character encoding of the source grammar, ENCODING = " - ++ concat (intersperse " | " (map fst encodings)) ++ "."), - Option [] ["erasing"] (onOff erasing False) "Generate erasing grammar (default off).", - Option [] ["parser"] (ReqArg buildParser "VALUE") "Build parser (default on). VALUE = on | off | ondemand", - Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.", - Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.", - Option [] ["lexer"] (ReqArg lexer "LEXER") "Use lexer LEXER.", - Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.", - Option [] ["optimize"] (ReqArg optimize "OPT") - "Select an optimization package. OPT = all | values | parametrize | none", - Option [] ["stem"] (onOff (toggleOptimize OptStem) True) "Perform stem-suffix analysis (default on).", - Option [] ["cse"] (onOff (toggleOptimize OptCSE) True) "Perform common sub-expression elimination (default on).", - Option [] ["cfg"] (ReqArg cfgTransform "TRANS") "Enable or disable specific CFG transformations. TRANS = merge, no-merge, bottomup, no-bottomup, ...", - dumpOption "source" DumpSource, - dumpOption "rebuild" DumpRebuild, - dumpOption "extend" DumpExtend, - dumpOption "rename" DumpRename, - dumpOption "tc" DumpTypeCheck, - dumpOption "refresh" DumpRefresh, - dumpOption "opt" DumpOptimize, - dumpOption "canon" DumpCanon - - ] - where phase x = set $ \o -> o { optStopAfterPhase = x } - mode x = set $ \o -> o { optMode = x } - verbosity mv = case mv of - Nothing -> set $ \o -> o { optVerbosity = Verbose } - Just v -> case readMaybe v >>= toEnumBounded of - Just i -> set $ \o -> o { optVerbosity = i } - Nothing -> fail $ "Bad verbosity: " ++ show v - prof x = set $ \o -> o { optProf = x } - cpu x = set $ \o -> o { optShowCPUTime = x } - emitGFO x = set $ \o -> o { optEmitGFO = x } - gfoDir x = set $ \o -> o { optGFODir = Just x } - outFmt x = readOutputFormat x >>= \f -> - set $ \o -> o { optOutputFormats = optOutputFormats o ++ [f] } - sisrFmt x = case x of - "old" -> set $ \o -> o { optSISR = Just SISR_WD20030401 } - "1.0" -> set $ \o -> o { optSISR = Just SISR_1_0 } - _ -> fail $ "Unknown SISR format: " ++ show x - hsOption x = case lookup x haskellOptionNames of - Just p -> set $ \o -> o { optHaskellOptions = Set.insert p (optHaskellOptions o) } - Nothing -> fail $ "Unknown Haskell option: " ++ x - ++ " Known: " ++ show (map fst haskellOptionNames) - lexicalCat x = set $ \o -> o { optLexicalCats = foldr Set.insert (optLexicalCats o) (splitBy (==',') x) } - outFile x = set $ \o -> o { optOutputFile = Just x } - outDir x = set $ \o -> o { optOutputDir = Just x } - gfLibPath x = set $ \o -> o { optGFLibPath = Just x } - recomp x = set $ \o -> o { optRecomp = x } - printer x = set $ \o -> o { optPrinter = x : optPrinter o } - prob x = set $ \o -> o { optProb = x } - - name x = set $ \o -> o { optName = Just x } - absName x = set $ \o -> o { optAbsName = Just x } - cncName x = set $ \o -> o { optCncName = Just x } - resName x = set $ \o -> o { optResName = Just x } - addLibDir x = set $ \o -> o { optLibraryPath = x:optLibraryPath o } - setLibPath x = set $ \o -> o { optLibraryPath = splitInModuleSearchPath x } - preproc x = set $ \o -> o { optPreprocessors = optPreprocessors o ++ [x] } - coding x = case lookup x encodings of - Just c -> set $ \o -> o { optEncoding = c } - Nothing -> fail $ "Unknown character encoding: " ++ x - erasing x = set $ \o -> o { optErasing = x } - buildParser x = do v <- case x of - "on" -> return BuildParser - "off" -> return DontBuildParser - "ondemand" -> return BuildParserOnDemand - set $ \o -> o { optBuildParser = v } - startcat x = set $ \o -> o { optStartCat = Just x } - language x = set $ \o -> o { optSpeechLanguage = Just x } - lexer x = set $ \o -> o { optLexer = Just x } - unlexer x = set $ \o -> o { optUnlexer = Just x } - - optimize x = case lookup x optimizationPackages of - Just p -> set $ \o -> o { optOptimizations = p } - Nothing -> fail $ "Unknown optimization package: " ++ x - - toggleOptimize x b = set $ setOptimization' x b - - cfgTransform x = let (x', b) = case x of - 'n':'o':'-':rest -> (rest, False) - _ -> (x, True) - in case lookup x' cfgTransformNames of - Just t -> set $ setCFGTransform' t b - Nothing -> fail $ "Unknown CFG transformation: " ++ x' - ++ " Known: " ++ show (map fst cfgTransformNames) - - dumpOption s d = Option [] ["dump-"++s] (NoArg (set $ \o -> o { optDump = d:optDump o})) ("Dump output of the " ++ s ++ " phase.") - - set = return . Options - -outputFormats :: [(String,OutputFormat)] -outputFormats = - [("pgf_pretty", FmtPGFPretty), - ("pmcfg_pretty", FmtPMCFGPretty), - ("js", FmtJavaScript), - ("haskell", FmtHaskell), - ("prolog", FmtProlog), - ("prolog_abs", FmtProlog_Abs), - ("bnf", FmtBNF), - ("ebnf", FmtEBNF), - ("regular", FmtRegular), - ("nolr", FmtNoLR), - ("srgs_xml", FmtSRGS_XML), - ("srgs_xml_nonrec", FmtSRGS_XML_NonRec), - ("srgs_abnf", FmtSRGS_ABNF), - ("srgs_abnf_nonrec", FmtSRGS_ABNF_NonRec), - ("jsgf", FmtJSGF), - ("gsl", FmtGSL), - ("vxml", FmtVoiceXML), - ("slf", FmtSLF), - ("regexp", FmtRegExp), - ("fa", FmtFA)] - -instance Show OutputFormat where - show = lookupShow outputFormats - -instance Read OutputFormat where - readsPrec = lookupReadsPrec outputFormats - -optimizationPackages :: [(String, Set Optimization)] -optimizationPackages = - [("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), - ("values", Set.fromList [OptStem,OptCSE,OptExpand]), - ("noexpand", Set.fromList [OptStem,OptCSE]), - - -- deprecated - ("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), - ("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), - ("none", Set.fromList [OptStem,OptCSE,OptExpand]) - ] - -cfgTransformNames :: [(String, CFGTransform)] -cfgTransformNames = - [("nolr", CFGNoLR), - ("regular", CFGRegular), - ("topdown", CFGTopDownFilter), - ("bottomup", CFGBottomUpFilter), - ("startcatonly", CFGStartCatOnly), - ("merge", CFGMergeIdentical), - ("removecycles", CFGRemoveCycles)] - -haskellOptionNames :: [(String, HaskellOption)] -haskellOptionNames = - [("noprefix", HaskellNoPrefix), - ("gadt", HaskellGADT), - ("lexical", HaskellLexical)] - -encodings :: [(String,Encoding)] -encodings = - [("utf8", UTF_8), - ("cp1250", CP_1250), - ("cp1251", CP_1251), - ("cp1252", CP_1252), - ("latin1", ISO_8859_1) - ] - -instance Show Encoding where - show = lookupShow encodings - -lookupShow :: Eq a => [(String,a)] -> a -> String -lookupShow xs z = fromMaybe "lookupShow" $ lookup z [(y,x) | (x,y) <- xs] - -lookupReadsPrec :: [(String,a)] -> Int -> ReadS a -lookupReadsPrec xs _ s = [(z,rest) | (x,rest) <- lex s, (y,z) <- xs, y == x] - -onOff :: Monad m => (Bool -> m a) -> Bool -> ArgDescr (m a) -onOff f def = OptArg g "[on,off]" - where g ma = maybe (return def) readOnOff ma >>= f - 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 - --- FIXME: this is a copy of the function in GF.Devel.UseIO. -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 == ';' - --- --- * Convenience functions for checking options --- - -verbAtLeast :: Options -> Verbosity -> Bool -verbAtLeast opts v = flag optVerbosity opts >= v - -dump :: Options -> Dump -> Bool -dump opts d = flag ((d `elem`) . optDump) opts - -cfgTransform :: Options -> CFGTransform -> Bool -cfgTransform opts t = Set.member t (flag optCFGTransforms opts) - -haskellOption :: Options -> HaskellOption -> Bool -haskellOption opts o = Set.member o (flag optHaskellOptions opts) - -isLexicalCat :: Options -> String -> Bool -isLexicalCat opts c = Set.member c (flag optLexicalCats opts) - --- --- * Convenience functions for setting options --- - -setOptimization :: Optimization -> Bool -> Options -setOptimization o b = modifyFlags (setOptimization' o b) - -setOptimization' :: Optimization -> Bool -> Flags -> Flags -setOptimization' o b f = f { optOptimizations = toggle o b (optOptimizations f)} - -setCFGTransform :: CFGTransform -> Bool -> Options -setCFGTransform t b = modifyFlags (setCFGTransform' t b) - -setCFGTransform' :: CFGTransform -> Bool -> Flags -> Flags -setCFGTransform' t b f = f { optCFGTransforms = toggle t b (optCFGTransforms f) } - -toggle :: Ord a => a -> Bool -> Set a -> Set a -toggle o True = Set.insert o -toggle o False = Set.delete o - --- --- * General utilities --- - -readMaybe :: Read a => String -> Maybe a -readMaybe s = case reads s of - [(x,"")] -> Just x - _ -> Nothing - -toEnumBounded :: (Bounded a, Enum a, Ord a) => Int -> Maybe a -toEnumBounded i = let mi = minBound - ma = maxBound `asTypeOf` mi - in if i >= fromEnum mi && i <= fromEnum ma - then Just (toEnum i `asTypeOf` mi) - else Nothing - -splitBy :: (a -> Bool) -> [a] -> [[a]] -splitBy _ [] = [] -splitBy p s = case break p s of - (l, _ : t@(_ : _)) -> l : splitBy p t - (l, _) -> [l] - -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 diff --git a/src/GF/Infra/UseIO.hs b/src/GF/Infra/UseIO.hs deleted file mode 100644 index bb1a75b6e..000000000 --- a/src/GF/Infra/UseIO.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-# OPTIONS -cpp #-} ----------------------------------------------------------------------- --- | --- Module : UseIO --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.17 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Infra.UseIO where - -import GF.Data.Operations -import GF.Infra.Option -import Paths_gf(getDataDir) - -import System.Directory -import System.FilePath -import System.IO -import System.IO.Error -import System.Environment -import System.Exit -import System.CPUTime -import Text.Printf -import Control.Monad -import Control.Exception(evaluate) -import qualified Data.ByteString.Char8 as BS -import Data.List(nub) - -putShow' :: Show a => (c -> a) -> c -> IO () -putShow' f = putStrLn . show . length . show . f - -putIfVerb :: Options -> String -> IO () -putIfVerb opts msg = - when (verbAtLeast opts Verbose) $ putStrLn msg - -putIfVerbW :: Options -> String -> IO () -putIfVerbW opts msg = - when (verbAtLeast opts Verbose) $ putStr (' ' : msg) - -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 - -type FileName = String -type InitPath = String -type FullPath = String - -gfLibraryPath = "GF_LIB_PATH" -gfGrammarPathVar = "GF_GRAMMAR_PATH" - -getLibraryDirectory :: Options -> IO FilePath -getLibraryDirectory opts = - case flag optGFLibPath opts of - Just path -> return path - Nothing -> catch - (getEnv gfLibraryPath) - (\ex -> getDataDir >>= \path -> return (path "lib")) - -getGrammarPath :: FilePath -> IO [FilePath] -getGrammarPath lib_dir = do - catch (fmap splitSearchPath $ getEnv gfGrammarPathVar) (\_ -> return [lib_dir "prelude"]) -- e.g. GF_GRAMMAR_PATH - --- | extends the search path with the --- 'gfLibraryPath' and 'gfGrammarPathVar' --- environment variables. Returns only existing paths. -extendPathEnv :: Options -> IO [FilePath] -extendPathEnv opts = do - opt_path <- return $ flag optLibraryPath opts -- e.g. paths given as options - lib_dir <- getLibraryDirectory opts -- e.g. GF_LIB_PATH - grm_path <- getGrammarPath lib_dir -- e.g. GF_GRAMMAR_PATH - let paths = opt_path ++ [lib_dir] ++ grm_path - ps <- liftM concat $ mapM allSubdirs paths - mapM canonicalizePath ps - 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 == ';' - --- - -putStrFlush :: String -> IO () -putStrFlush s = putStr s >> hFlush stdout - -putStrLnFlush :: String -> IO () -putStrLnFlush s = putStrLn s >> hFlush stdout - --- * 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) - -dieIOE :: IOE a -> IO a -dieIOE x = appIOE x >>= err die return - -die :: String -> IO a -die s = do hPutStrLn stderr s - exitFailure - -putStrLnE :: String -> IOE () -putStrLnE = ioeIO . putStrLnFlush - -putStrE :: String -> IOE () -putStrE = ioeIO . putStrFlush - -putPointE :: Verbosity -> Options -> String -> IOE a -> IOE a -putPointE v opts msg act = do - when (verbAtLeast opts v) $ ioeIO $ putStrFlush msg - - t1 <- ioeIO $ getCPUTime - a <- act >>= ioeIO . evaluate - t2 <- ioeIO $ getCPUTime - - if flag optShowCPUTime opts - then do let msec = (t2 - t1) `div` 1000000000 - putStrLnE (printf " %5d msec" msec) - else when (verbAtLeast opts v) $ putStrLnE "" - - return a diff --git a/src/GF/JavaScript/AbsJS.hs b/src/GF/JavaScript/AbsJS.hs deleted file mode 100644 index 2632ade48..000000000 --- a/src/GF/JavaScript/AbsJS.hs +++ /dev/null @@ -1,60 +0,0 @@ -module GF.JavaScript.AbsJS where - --- Haskell module generated by the BNF converter - -newtype Ident = Ident String deriving (Eq,Ord,Show) -data Program = - Program [Element] - deriving (Eq,Ord,Show) - -data Element = - FunDef Ident [Ident] [Stmt] - | ElStmt Stmt - deriving (Eq,Ord,Show) - -data Stmt = - SCompound [Stmt] - | SReturnVoid - | SReturn Expr - | SDeclOrExpr DeclOrExpr - deriving (Eq,Ord,Show) - -data DeclOrExpr = - Decl [DeclVar] - | DExpr Expr - deriving (Eq,Ord,Show) - -data DeclVar = - DVar Ident - | DInit Ident Expr - deriving (Eq,Ord,Show) - -data Expr = - EAssign Expr Expr - | ENew Ident [Expr] - | EMember Expr Ident - | EIndex Expr Expr - | ECall Expr [Expr] - | EVar Ident - | EInt Int - | EDbl Double - | EStr String - | ETrue - | EFalse - | ENull - | EThis - | EFun [Ident] [Stmt] - | EArray [Expr] - | EObj [Property] - | ESeq [Expr] - deriving (Eq,Ord,Show) - -data Property = - Prop PropertyName Expr - deriving (Eq,Ord,Show) - -data PropertyName = - IdentPropName Ident - | StringPropName String - deriving (Eq,Ord,Show) - diff --git a/src/GF/JavaScript/JS.cf b/src/GF/JavaScript/JS.cf deleted file mode 100644 index fe31a2074..000000000 --- a/src/GF/JavaScript/JS.cf +++ /dev/null @@ -1,55 +0,0 @@ -entrypoints Program; - -Program. Program ::= [Element]; - -FunDef. Element ::= "function" Ident "(" [Ident] ")" "{" [Stmt] "}" ; -ElStmt. Element ::= Stmt; -separator Element "" ; - -separator Ident "," ; - -SCompound. Stmt ::= "{" [Stmt] "}" ; -SReturnVoid. Stmt ::= "return" ";" ; -SReturn. Stmt ::= "return" Expr ";" ; -SDeclOrExpr. Stmt ::= DeclOrExpr ";" ; -separator Stmt "" ; - -Decl. DeclOrExpr ::= "var" [DeclVar]; -DExpr. DeclOrExpr ::= Expr1 ; - -DVar. DeclVar ::= Ident ; -DInit. DeclVar ::= Ident "=" Expr ; -separator DeclVar "," ; - -EAssign. Expr13 ::= Expr14 "=" Expr13 ; - -ENew. Expr14 ::= "new" Ident "(" [Expr] ")" ; - -EMember. Expr15 ::= Expr15 "." Ident ; -EIndex. Expr15 ::= Expr15 "[" Expr "]" ; -ECall. Expr15 ::= Expr15 "(" [Expr] ")" ; - -EVar. Expr16 ::= Ident ; -EInt. Expr16 ::= Integer ; -EDbl. Expr16 ::= Double ; -EStr. Expr16 ::= String ; -ETrue. Expr16 ::= "true" ; -EFalse. Expr16 ::= "false" ; -ENull. Expr16 ::= "null" ; -EThis. Expr16 ::= "this" ; -EFun. Expr16 ::= "function" "(" [Ident] ")" "{" [Stmt] "}" ; -EArray. Expr16 ::= "[" [Expr] "]" ; -EObj. Expr16 ::= "{" [Property] "}" ; - -eseq1. Expr16 ::= "(" Expr "," [Expr] ")"; -internal ESeq. Expr16 ::= "(" [Expr] ")" ; -define eseq1 x xs = ESeq (x:xs); - -separator Expr "," ; -coercions Expr 16 ; - -Prop. Property ::= PropertyName ":" Expr ; -separator Property "," ; - -IdentPropName. PropertyName ::= Ident ; -StringPropName. PropertyName ::= String ; diff --git a/src/GF/JavaScript/LexJS.x b/src/GF/JavaScript/LexJS.x deleted file mode 100644 index 10ba66d69..000000000 --- a/src/GF/JavaScript/LexJS.x +++ /dev/null @@ -1,132 +0,0 @@ --- -*- haskell -*- --- This Alex file was machine-generated by the BNF converter -{ -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module GF.JavaScript.LexJS where - - -} - - -$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME -$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME -$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME -$d = [0-9] -- digit -$i = [$l $d _ '] -- identifier character -$u = [\0-\255] -- universal: any character - -@rsyms = -- symbols and non-identifier-like reserved words - \( | \) | \{ | \} | \, | \; | \= | \. | \[ | \] | \: - -:- - -$white+ ; -@rsyms { tok (\p s -> PT p (TS $ share s)) } - -$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) } -\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) } - -$d+ { tok (\p s -> PT p (TI $ share s)) } -$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ share s)) } - -{ - -tok f p s = f p s - -share :: String -> String -share = id - -data Tok = - TS !String -- reserved words and symbols - | TL !String -- string literals - | TI !String -- integer literals - | TV !String -- identifiers - | TD !String -- double precision float literals - | TC !String -- character literals - - deriving (Eq,Show,Ord) - -data Token = - PT Posn Tok - | Err Posn - deriving (Eq,Show,Ord) - -tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l -tokenPos (Err (Pn _ l _) :_) = "line " ++ show l -tokenPos _ = "end of file" - -posLineCol (Pn _ l c) = (l,c) -mkPosToken t@(PT p _) = (posLineCol p, prToken t) - -prToken t = case t of - PT _ (TS s) -> s - PT _ (TI s) -> s - PT _ (TV s) -> s - PT _ (TD s) -> s - PT _ (TC s) -> s - - _ -> show t - -data BTree = N | B String Tok BTree BTree deriving (Show) - -eitherResIdent :: (String -> Tok) -> String -> Tok -eitherResIdent tv s = treeFind resWords - where - treeFind N = tv s - treeFind (B a t left right) | s < a = treeFind left - | s > a = treeFind right - | s == a = t - -resWords = b "return" (b "new" (b "function" (b "false" N N) N) (b "null" N N)) (b "true" (b "this" N N) (b "var" N N)) - where b s = B s (TS s) - -unescapeInitTail :: String -> String -unescapeInitTail = unesc . tail where - unesc s = case s of - '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs - '\\':'n':cs -> '\n' : unesc cs - '\\':'t':cs -> '\t' : unesc cs - '"':[] -> [] - c:cs -> c : unesc cs - _ -> [] - -------------------------------------------------------------------- --- Alex wrapper code. --- A modified "posn" wrapper. -------------------------------------------------------------------- - -data Posn = Pn !Int !Int !Int - deriving (Eq, Show,Ord) - -alexStartPos :: Posn -alexStartPos = Pn 0 1 1 - -alexMove :: Posn -> Char -> Posn -alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) -alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 -alexMove (Pn a l c) _ = Pn (a+1) l (c+1) - -type AlexInput = (Posn, -- current position, - Char, -- previous char - String) -- current input string - -tokens :: String -> [Token] -tokens str = go (alexStartPos, '\n', str) - where - go :: (Posn, Char, String) -> [Token] - go inp@(pos, _, str) = - case alexScan inp 0 of - AlexEOF -> [] - AlexError (pos, _, _) -> [Err pos] - AlexSkip inp' len -> go inp' - AlexToken inp' len act -> act pos (take len str) : (go inp') - -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (p, c, []) = Nothing -alexGetChar (p, _, (c:s)) = - let p' = alexMove p c - in p' `seq` Just (c, (p', c, s)) - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (p, c, s) = c -} diff --git a/src/GF/JavaScript/Makefile b/src/GF/JavaScript/Makefile deleted file mode 100644 index 10f867b06..000000000 --- a/src/GF/JavaScript/Makefile +++ /dev/null @@ -1,14 +0,0 @@ -all: - happy -gca ParJS.y - alex -g LexJS.x - -bnfc: - (cd ../.. && bnfc -p GF.JavaScript GF/JavaScript/JS.cf) - -rm -f *.bak - -clean: - -rm -f *.log *.aux *.hi *.o *.dvi - -rm -f DocJS.ps -distclean: clean - -rm -f DocJS.* LexJS.* ParJS.* LayoutJS.* SkelJS.* PrintJS.* TestJS.* AbsJS.* TestJS ErrM.* SharedString.* JS.dtd XMLJS.* Makefile* - diff --git a/src/GF/JavaScript/ParJS.y b/src/GF/JavaScript/ParJS.y deleted file mode 100644 index bf0614757..000000000 --- a/src/GF/JavaScript/ParJS.y +++ /dev/null @@ -1,225 +0,0 @@ --- This Happy file was machine-generated by the BNF converter -{ -{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} -module GF.JavaScript.ParJS where -import GF.JavaScript.AbsJS -import GF.JavaScript.LexJS -import GF.Data.ErrM -} - -%name pProgram Program - --- no lexer declaration -%monad { Err } { thenM } { returnM } -%tokentype { Token } - -%token - '(' { PT _ (TS "(") } - ')' { PT _ (TS ")") } - '{' { PT _ (TS "{") } - '}' { PT _ (TS "}") } - ',' { PT _ (TS ",") } - ';' { PT _ (TS ";") } - '=' { PT _ (TS "=") } - '.' { PT _ (TS ".") } - '[' { PT _ (TS "[") } - ']' { PT _ (TS "]") } - ':' { PT _ (TS ":") } - 'false' { PT _ (TS "false") } - 'function' { PT _ (TS "function") } - 'new' { PT _ (TS "new") } - 'null' { PT _ (TS "null") } - 'return' { PT _ (TS "return") } - 'this' { PT _ (TS "this") } - 'true' { PT _ (TS "true") } - 'var' { PT _ (TS "var") } - -L_ident { PT _ (TV $$) } -L_integ { PT _ (TI $$) } -L_doubl { PT _ (TD $$) } -L_quoted { PT _ (TL $$) } -L_err { _ } - - -%% - -Ident :: { Ident } : L_ident { Ident $1 } -Integer :: { Integer } : L_integ { (read $1) :: Integer } -Double :: { Double } : L_doubl { (read $1) :: Double } -String :: { String } : L_quoted { $1 } - -Program :: { Program } -Program : ListElement { Program (reverse $1) } - - -Element :: { Element } -Element : 'function' Ident '(' ListIdent ')' '{' ListStmt '}' { FunDef $2 $4 (reverse $7) } - | Stmt { ElStmt $1 } - - -ListElement :: { [Element] } -ListElement : {- empty -} { [] } - | ListElement Element { flip (:) $1 $2 } - - -ListIdent :: { [Ident] } -ListIdent : {- empty -} { [] } - | Ident { (:[]) $1 } - | Ident ',' ListIdent { (:) $1 $3 } - - -Stmt :: { Stmt } -Stmt : '{' ListStmt '}' { SCompound (reverse $2) } - | 'return' ';' { SReturnVoid } - | 'return' Expr ';' { SReturn $2 } - | DeclOrExpr ';' { SDeclOrExpr $1 } - - -ListStmt :: { [Stmt] } -ListStmt : {- empty -} { [] } - | ListStmt Stmt { flip (:) $1 $2 } - - -DeclOrExpr :: { DeclOrExpr } -DeclOrExpr : 'var' ListDeclVar { Decl $2 } - | Expr1 { DExpr $1 } - - -DeclVar :: { DeclVar } -DeclVar : Ident { DVar $1 } - | Ident '=' Expr { DInit $1 $3 } - - -ListDeclVar :: { [DeclVar] } -ListDeclVar : {- empty -} { [] } - | DeclVar { (:[]) $1 } - | DeclVar ',' ListDeclVar { (:) $1 $3 } - - -Expr13 :: { Expr } -Expr13 : Expr14 '=' Expr13 { EAssign $1 $3 } - | Expr14 { $1 } - - -Expr14 :: { Expr } -Expr14 : 'new' Ident '(' ListExpr ')' { ENew $2 $4 } - | Expr15 { $1 } - - -Expr15 :: { Expr } -Expr15 : Expr15 '.' Ident { EMember $1 $3 } - | Expr15 '[' Expr ']' { EIndex $1 $3 } - | Expr15 '(' ListExpr ')' { ECall $1 $3 } - | Expr16 { $1 } - - -Expr16 :: { Expr } -Expr16 : Ident { EVar $1 } - | Integer { EInt $1 } - | Double { EDbl $1 } - | String { EStr $1 } - | 'true' { ETrue } - | 'false' { EFalse } - | 'null' { ENull } - | 'this' { EThis } - | 'function' '(' ListIdent ')' '{' ListStmt '}' { EFun $3 (reverse $6) } - | '[' ListExpr ']' { EArray $2 } - | '{' ListProperty '}' { EObj $2 } - | '(' Expr ',' ListExpr ')' { eseq1_ $2 $4 } - | '(' Expr ')' { $2 } - - -ListExpr :: { [Expr] } -ListExpr : {- empty -} { [] } - | Expr { (:[]) $1 } - | Expr ',' ListExpr { (:) $1 $3 } - - -Expr :: { Expr } -Expr : Expr1 { $1 } - - -Expr1 :: { Expr } -Expr1 : Expr2 { $1 } - - -Expr2 :: { Expr } -Expr2 : Expr3 { $1 } - - -Expr3 :: { Expr } -Expr3 : Expr4 { $1 } - - -Expr4 :: { Expr } -Expr4 : Expr5 { $1 } - - -Expr5 :: { Expr } -Expr5 : Expr6 { $1 } - - -Expr6 :: { Expr } -Expr6 : Expr7 { $1 } - - -Expr7 :: { Expr } -Expr7 : Expr8 { $1 } - - -Expr8 :: { Expr } -Expr8 : Expr9 { $1 } - - -Expr9 :: { Expr } -Expr9 : Expr10 { $1 } - - -Expr10 :: { Expr } -Expr10 : Expr11 { $1 } - - -Expr11 :: { Expr } -Expr11 : Expr12 { $1 } - - -Expr12 :: { Expr } -Expr12 : Expr13 { $1 } - - -Property :: { Property } -Property : PropertyName ':' Expr { Prop $1 $3 } - - -ListProperty :: { [Property] } -ListProperty : {- empty -} { [] } - | Property { (:[]) $1 } - | Property ',' ListProperty { (:) $1 $3 } - - -PropertyName :: { PropertyName } -PropertyName : Ident { IdentPropName $1 } - | String { StringPropName $1 } - - - -{ - -returnM :: a -> Err a -returnM = return - -thenM :: Err a -> (a -> Err b) -> Err b -thenM = (>>=) - -happyError :: [Token] -> Err a -happyError ts = - Bad $ "syntax error at " ++ tokenPos ts ++ - case ts of - [] -> [] - [Err _] -> " due to lexer error" - _ -> " before " ++ unwords (map prToken (take 4 ts)) - -myLexer = tokens -eseq1_ x_ xs_ = ESeq (x_ : xs_) -} - diff --git a/src/GF/JavaScript/PrintJS.hs b/src/GF/JavaScript/PrintJS.hs deleted file mode 100644 index 4e04e3cbf..000000000 --- a/src/GF/JavaScript/PrintJS.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module GF.JavaScript.PrintJS (printTree, Doc, Print(..)) where - --- pretty-printer generated by the BNF converter - -import GF.JavaScript.AbsJS -import Data.Char - --- the top-level printing method -printTree :: Print a => a -> String -printTree = render . prt 0 - -type Doc = [ShowS] -> [ShowS] - -doc :: ShowS -> Doc -doc = (:) - -render :: Doc -> String -render d = rend 0 (map ($ "") $ d []) "" where - rend i ss = case ss of - t:ts | not (spaceAfter t) -> showString t . rend i ts - t:ts@(t':_) | not (spaceBefore t') -> showString t . rend i ts - t:ts -> space t . rend i ts - [] -> id - new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace - space t = showString t . (\s -> if null s then "" else (' ':s)) - -spaceAfter :: String -> Bool -spaceAfter = (`notElem` [".","(","[","{","\n"]) - -spaceBefore :: String -> Bool -spaceBefore = (`notElem` [",",".",":",";","(",")","[","]","{","}","\n"]) - -parenth :: Doc -> Doc -parenth ss = doc (showChar '(') . ss . doc (showChar ')') - -concatS :: [ShowS] -> ShowS -concatS = foldr (.) id - -concatD :: [Doc] -> Doc -concatD = foldr (.) id - -replicateS :: Int -> ShowS -> ShowS -replicateS n f = concatS (replicate n f) - --- the printer class does the job -class Print a where - prt :: Int -> a -> Doc - prtList :: [a] -> Doc - prtList = concatD . map (prt 0) - -instance Print a => Print [a] where - prt _ = prtList - -instance Print Char where - prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'') - prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') - -mkEsc :: Char -> Char -> ShowS -mkEsc q s = case s of - _ | s == q -> showChar '\\' . showChar s - '\\'-> showString "\\\\" - '\n' -> showString "\\n" - '\t' -> showString "\\t" - _ -> showChar s - -prPrec :: Int -> Int -> Doc -> Doc -prPrec i j = if j (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - - - -instance Print Program where - prt i e = case e of - Program elements -> prPrec i 0 (concatD [prt 0 elements]) - - -instance Print Element where - prt i e = case e of - FunDef id ids stmts -> prPrec i 0 (concatD [doc (showString "function") , prt 0 id , doc (showString "(") , prt 0 ids , doc (showString ")") , doc (showString "{") , prt 0 stmts , doc (showString "}")]) - ElStmt stmt -> prPrec i 0 (concatD [prt 0 stmt]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , doc (showString "\n"), prt 0 xs]) -- HACKED! - -instance Print Stmt where - prt i e = case e of - SCompound stmts -> prPrec i 0 (concatD [doc (showString "{") , prt 0 stmts , doc (showString "}")]) - SReturnVoid -> prPrec i 0 (concatD [doc (showString "return") , doc (showString ";")]) - SReturn expr -> prPrec i 0 (concatD [doc (showString "return") , prt 0 expr , doc (showString ";")]) - SDeclOrExpr declorexpr -> prPrec i 0 (concatD [prt 0 declorexpr , doc (showString ";")]) - - prtList es = case es of - [] -> (concatD []) - x:xs -> (concatD [prt 0 x , prt 0 xs]) - -instance Print DeclOrExpr where - prt i e = case e of - Decl declvars -> prPrec i 0 (concatD [doc (showString "var") , prt 0 declvars]) - DExpr expr -> prPrec i 0 (concatD [prt 1 expr]) - - -instance Print DeclVar where - prt i e = case e of - DVar id -> prPrec i 0 (concatD [prt 0 id]) - DInit id expr -> prPrec i 0 (concatD [prt 0 id , doc (showString "=") , prt 0 expr]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print Expr where - prt i e = case e of - EAssign expr0 expr -> prPrec i 13 (concatD [prt 14 expr0 , doc (showString "=") , prt 13 expr]) - ENew id exprs -> prPrec i 14 (concatD [doc (showString "new") , prt 0 id , doc (showString "(") , prt 0 exprs , doc (showString ")")]) - EMember expr id -> prPrec i 15 (concatD [prt 15 expr , doc (showString ".") , prt 0 id]) - EIndex expr0 expr -> prPrec i 15 (concatD [prt 15 expr0 , doc (showString "[") , prt 0 expr , doc (showString "]")]) - ECall expr exprs -> prPrec i 15 (concatD [prt 15 expr , doc (showString "(") , prt 0 exprs , doc (showString ")")]) - EVar id -> prPrec i 16 (concatD [prt 0 id]) - EInt n -> prPrec i 16 (concatD [prt 0 n]) - EDbl d -> prPrec i 16 (concatD [prt 0 d]) - EStr str -> prPrec i 16 (concatD [prt 0 str]) - ETrue -> prPrec i 16 (concatD [doc (showString "true")]) - EFalse -> prPrec i 16 (concatD [doc (showString "false")]) - ENull -> prPrec i 16 (concatD [doc (showString "null")]) - EThis -> prPrec i 16 (concatD [doc (showString "this")]) - EFun ids stmts -> prPrec i 16 (concatD [doc (showString "function") , doc (showString "(") , prt 0 ids , doc (showString ")") , doc (showString "{") , prt 0 stmts , doc (showString "}")]) - EArray exprs -> prPrec i 16 (concatD [doc (showString "[") , prt 0 exprs , doc (showString "]")]) - EObj propertys -> prPrec i 16 (concatD [doc (showString "{") , prt 0 propertys , doc (showString "}")]) - ESeq exprs -> prPrec i 16 (concatD [doc (showString "(") , prt 0 exprs , doc (showString ")")]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print Property where - prt i e = case e of - Prop propertyname expr -> prPrec i 0 (concatD [prt 0 propertyname , doc (showString ":") , prt 0 expr]) - - prtList es = case es of - [] -> (concatD []) - [x] -> (concatD [prt 0 x]) - x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) - -instance Print PropertyName where - prt i e = case e of - IdentPropName id -> prPrec i 0 (concatD [prt 0 id]) - StringPropName str -> prPrec i 0 (concatD [prt 0 str]) - - - diff --git a/src/GF/Quiz.hs b/src/GF/Quiz.hs deleted file mode 100644 index 52d9dee6b..000000000 --- a/src/GF/Quiz.hs +++ /dev/null @@ -1,98 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : TeachYourself --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:46:13 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.7 $ --- --- translation and morphology quiz. AR 10\/5\/2000 -- 12\/4\/2002 -- 14\/6\/2008 --------------------------------------------------------------------------------- - -module GF.Quiz ( - mkQuiz, - translationList, - morphologyList - ) where - -import PGF -import PGF.ShowLinearize -import GF.Data.Operations -import GF.Infra.UseIO -import GF.Infra.Option -import GF.Text.Coding - -import System.Random - -import Data.List (nub) - --- translation and morphology quiz. AR 10/5/2000 -- 12/4/2002 - --- generic quiz function - -mkQuiz :: Encoding -> String -> [(String,[String])] -> IO () -mkQuiz cod msg tts = do - let qas = [ (encodeUnicode cod q, mkAnswer cod as) | (q,as) <- tts] - teachDialogue qas msg - -translationList :: - PGF -> Language -> Language -> Type -> Int -> IO [(String,[String])] -translationList pgf ig og typ number = do - ts <- generateRandom pgf typ >>= return . take number - return $ map mkOne $ ts - where - mkOne t = (norml (linearize pgf ig t), map (norml . linearize pgf og) (homonyms t)) - homonyms = nub . parse pgf ig typ . linearize pgf ig - -morphologyList :: PGF -> Language -> Type -> Int -> IO [(String,[String])] -morphologyList pgf ig typ number = do - ts <- generateRandom pgf typ >>= return . take (max 1 number) - gen <- newStdGen - let ss = map (tabularLinearize pgf ig) ts - let size = length (head ss) - let forms = take number $ randomRs (0,size-1) gen - return [(head (snd (head pws)) +++ par, ws) | - (pws,i) <- zip ss forms, let (par,ws) = pws !! i] - --- | compare answer to the list of right answers, increase score and give feedback -mkAnswer :: Encoding -> [String] -> String -> (Integer, String) -mkAnswer cod as s = - if (elem (norm s) as) - then (1,"Yes.") - else (0,"No, not" +++ s ++ ", but" ++++ enc (unlines as)) - where - norm = unwords . words . decodeUnicode cod - enc = encodeUnicode cod - -norml = unwords . words - - --- * 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" diff --git a/src/GF/Speech/CFG.hs b/src/GF/Speech/CFG.hs deleted file mode 100644 index 9ec8416c5..000000000 --- a/src/GF/Speech/CFG.hs +++ /dev/null @@ -1,372 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Speech.CFG --- --- Context-free grammar representation and manipulation. ----------------------------------------------------------------------- -module GF.Speech.CFG where - -import GF.Data.Utilities -import PGF.CId -import GF.Infra.Option -import GF.Data.Relation - -import Control.Monad -import Control.Monad.State (State, get, put, evalState) -import qualified Data.ByteString.Char8 as BS -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 - --- --- * Types --- - -type Cat = String -type Token = String - -data Symbol c t = NonTerminal c | Terminal t - deriving (Eq, Ord, Show) - -type CFSymbol = Symbol Cat Token - -data CFRule = CFRule { - lhsCat :: Cat, - ruleRhs :: [CFSymbol], - ruleName :: CFTerm - } - deriving (Eq, Ord, Show) - -data CFTerm - = CFObj CId [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 CId -- ^ A metavariable - deriving (Eq, Ord, Show) - -data CFG = CFG { cfgStartCat :: Cat, - cfgExternalCats :: Set Cat, - cfgRules :: Map Cat (Set CFRule) } - deriving (Eq, Ord, Show) - --- --- * 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 :: CFG -> CFG -removeCycles = onRules f - where f rs = filter (not . isCycle) rs - where alias = transitiveClosure $ mkRel [(c,c') | CFRule c [NonTerminal c'] _ <- rs] - isCycle (CFRule c [NonTerminal c'] _) = isRelatedTo alias c' c - isCycle _ = False - --- | Better bottom-up filter that also removes categories which contain no finite --- strings. -bottomUpFilter :: CFG -> CFG -bottomUpFilter gr = fix grow (gr { cfgRules = Map.empty }) - where grow g = g `unionCFG` filterCFG (all (okSym g) . ruleRhs) gr - okSym g = symbol (`elem` allCats g) (const True) - --- | Removes categories which are not reachable from any external category. -topDownFilter :: CFG -> CFG -topDownFilter cfg = filterCFGCats (`Set.member` keep) cfg - where - rhsCats = [ (lhsCat r, c') | r <- allRules cfg, c' <- filterCats (ruleRhs r) ] - uses = reflexiveClosure_ (allCats cfg) $ transitiveClosure $ mkRel rhsCats - keep = Set.unions $ map (allRelated uses) $ Set.toList $ cfgExternalCats cfg - --- | Merges categories with identical right-hand-sides. --- FIXME: handle probabilities -mergeIdentical :: CFG -> CFG -mergeIdentical g = onRules (map subst) g - where - -- maps categories to their replacement - m = Map.fromList [(y,concat (intersperse "+" xs)) - | (_,xs) <- buildMultiMap [(rulesKey rs,c) | (c,rs) <- Map.toList (cfgRules 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 - --- | Keeps only the start category as an external category. -purgeExternalCats :: CFG -> CFG -purgeExternalCats cfg = cfg { cfgExternalCats = Set.singleton (cfgStartCat cfg) } - --- --- * Removing left recursion --- - --- The LC_LR algorithm from --- http://research.microsoft.com/users/bobmoore/naacl2k-proc-rev.pdf -removeLeftRecursion :: CFG -> CFG -removeLeftRecursion gr - = gr { cfgRules = groupProds $ concat [scheme1, scheme2, scheme3, scheme4] } - where - scheme1 = [CFRule a [x,NonTerminal a_x] n' | - a <- retainedLeftRecursive, - x <- properLeftCornersOf a, - not (isLeftRecursive x), - let a_x = mkCat (NonTerminal 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++[NonTerminal a_b]) n' | - a <- retainedLeftRecursive, - b@(NonTerminal b') <- properLeftCornersOf a, - isLeftRecursive b, - CFRule _ (x:beta) n <- catRules gr b', - let a_x = mkCat (NonTerminal a) x, - let a_b = mkCat (NonTerminal 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 (NonTerminal a) x, - let n' = symbol (\_ -> CFAbs 1 (shiftTerm n)) - (\_ -> n) x] - scheme4 = catSetRules gr $ Set.fromList $ filter (not . isLeftRecursive . NonTerminal) 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 [(NonTerminal c,t) | CFRule c (t:_) _ <- allRules gr] - leftCorner = reflexiveClosure_ (map NonTerminal cats) $ transitiveClosure directLeftCorner - properLeftCorner = transitiveClosure directLeftCorner - properLeftCornersOf = Set.toList . allRelated properLeftCorner . NonTerminal - isProperLeftCornerOf = flip (isRelatedTo properLeftCorner) - - leftRecursive = reflexiveElements properLeftCorner - isLeftRecursive = (`Set.member` leftRecursive) - - retained = cfgStartCat gr `Set.insert` - Set.fromList [a | r <- allRules (filterCFGCats (not . isLeftRecursive . NonTerminal) gr), - NonTerminal a <- ruleRhs r] - isRetained = (`Set.member` retained) - - retainedLeftRecursive = filter (isLeftRecursive . NonTerminal) $ Set.toList retained - - mkCat :: CFSymbol -> CFSymbol -> Cat - mkCat x y = showSymbol x ++ "-" ++ showSymbol y - where showSymbol = symbol id show - --- | 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. - -> CFG -> [Set Cat] -mutRecCats incAll g = equivalenceClasses $ refl $ symmetricSubrelation $ transitiveClosure r - where r = mkRel [(c,c') | CFRule c ss _ <- allRules g, NonTerminal c' <- ss] - refl = if incAll then reflexiveClosure_ (allCats g) else reflexiveSubrelation - --- --- * Approximate context-free grammars with regular grammars. --- - -makeSimpleRegular :: CFG -> CFG -makeSimpleRegular = makeRegular . topDownFilter . bottomUpFilter . removeCycles - --- Use the transformation algorithm from \"Regular Approximation of Context-free --- Grammars through Approximation\", Mohri and Nederhof, 2000 --- to create an over-generating regular grammar for a context-free --- grammar -makeRegular :: CFG -> CFG -makeRegular g = g { cfgRules = groupProds $ concatMap trSet (mutRecCats True g) } - where trSet cs | allXLinear cs rs = rs - | otherwise = concatMap handleCat (Set.toList cs) - where 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 ++ [NonTerminal (newCat c)]) n -- no non-terminals left - (NonTerminal b:zs) -> newRule b' (xs ++ [NonTerminal 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 == [NonTerminal c] = [] - | otherwise = [CFRule c rhs n] - newCat c = c ++ "$" - --- --- * CFG Utilities --- - -mkCFG :: Cat -> Set Cat -> [CFRule] -> CFG -mkCFG start ext rs = CFG { cfgStartCat = start, cfgExternalCats = ext, cfgRules = groupProds rs } - -groupProds :: [CFRule] -> Map Cat (Set CFRule) -groupProds = Map.fromListWith Set.union . map (\r -> (lhsCat r,Set.singleton r)) - --- | Gets all rules in a CFG. -allRules :: CFG -> [CFRule] -allRules = concat . map Set.toList . Map.elems . cfgRules - --- | Gets all rules in a CFG, grouped by their LHS categories. -allRulesGrouped :: CFG -> [(Cat,[CFRule])] -allRulesGrouped = Map.toList . Map.map Set.toList . cfgRules - --- | Gets all categories which have rules. -allCats :: CFG -> [Cat] -allCats = Map.keys . cfgRules - --- | Gets all categories which have rules or occur in a RHS. -allCats' :: CFG -> [Cat] -allCats' cfg = Set.toList (Map.keysSet (cfgRules cfg) `Set.union` - Set.fromList [c | rs <- Map.elems (cfgRules cfg), - r <- Set.toList rs, - NonTerminal c <- ruleRhs r]) - --- | Gets all rules for the given category. -catRules :: CFG -> Cat -> [CFRule] -catRules gr c = Set.toList $ Map.findWithDefault Set.empty c (cfgRules gr) - --- | Gets all rules for categories in the given set. -catSetRules :: CFG -> Set Cat -> [CFRule] -catSetRules gr cs = allRules $ filterCFGCats (`Set.member` cs) gr - -mapCFGCats :: (Cat -> Cat) -> CFG -> CFG -mapCFGCats f cfg = mkCFG (f (cfgStartCat cfg)) - (Set.map f (cfgExternalCats cfg)) - [CFRule (f lhs) (map (mapSymbol f id) rhs) t | CFRule lhs rhs t <- allRules cfg] - -onCFG :: (Map Cat (Set CFRule) -> Map Cat (Set CFRule)) -> CFG -> CFG -onCFG f cfg = cfg { cfgRules = f (cfgRules cfg) } - -onRules :: ([CFRule] -> [CFRule]) -> CFG -> CFG -onRules f cfg = cfg { cfgRules = groupProds $ f $ allRules cfg } - --- | Clean up CFG after rules have been removed. -cleanCFG :: CFG -> CFG -cleanCFG = onCFG (Map.filter (not . Set.null)) - --- | Combine two CFGs. -unionCFG :: CFG -> CFG -> CFG -unionCFG x y = onCFG (\rs -> Map.unionWith Set.union rs (cfgRules y)) x - -filterCFG :: (CFRule -> Bool) -> CFG -> CFG -filterCFG p = cleanCFG . onCFG (Map.map (Set.filter p)) - -filterCFGCats :: (Cat -> Bool) -> CFG -> CFG -filterCFGCats p = onCFG (Map.filterWithKey (\c _ -> p c)) - -countCats :: CFG -> Int -countCats = Map.size . cfgRules . cleanCFG - -countRules :: CFG -> Int -countRules = length . allRules - -prCFG :: CFG -> String -prCFG = prProductions . map prRule . allRules - where - prRule r = (lhsCat r, unwords (map prSym (ruleRhs r))) - prSym = symbol id (\t -> "\""++ t ++"\"") - -prProductions :: [(Cat,String)] -> String -prProductions prods = - unlines [rpad maxLHSWidth lhs ++ " ::= " ++ rhs | (lhs,rhs) <- prods] - where - maxLHSWidth = maximum $ 0:(map (length . fst) prods) - rpad n s = s ++ replicate (n - length s) ' ' - -prCFTerm :: CFTerm -> String -prCFTerm = pr 0 - where - pr p (CFObj f args) = paren p (showCId f ++ " (" ++ concat (intersperse "," (map (pr 0) args)) ++ ")") - pr p (CFAbs i t) = paren p ("\\x" ++ show i ++ ". " ++ pr 0 t) - pr p (CFApp t1 t2) = paren p (pr 1 t1 ++ "(" ++ pr 0 t2 ++ ")") - pr _ (CFRes i) = "$" ++ show i - pr _ (CFVar i) = "x" ++ show i - pr _ (CFMeta c) = "?" ++ showCId c - paren 0 x = x - paren 1 x = "(" ++ x ++ ")" - --- --- * CFRule Utilities --- - -ruleFun :: CFRule -> CId -ruleFun (CFRule _ _ t) = f t - where f (CFObj n _) = n - f (CFApp _ x) = f x - f (CFAbs _ x) = f x - f _ = mkCId "" - --- | Check if any of the categories used on the right-hand side --- are in the given list of categories. -anyUsedBy :: [Cat] -> CFRule -> Bool -anyUsedBy cs (CFRule _ ss _) = any (`elem` cs) (filterCats ss) - -mkCFTerm :: String -> CFTerm -mkCFTerm n = CFObj (mkCId n) [] - -ruleIsNonRecursive :: Set Cat -> CFRule -> Bool -ruleIsNonRecursive cs = noCatsInSet cs . ruleRhs - --- | Check if all the rules are right-linear, or all the rules are --- left-linear, with respect to given categories. -allXLinear :: Set Cat -> [CFRule] -> Bool -allXLinear cs rs = all (isRightLinear cs) rs || all (isLeftLinear cs) rs - --- | Checks if a context-free rule is right-linear. -isRightLinear :: Set Cat -- ^ The categories to consider - -> CFRule -- ^ The rule to check for right-linearity - -> Bool -isRightLinear cs = noCatsInSet cs . safeInit . ruleRhs - --- | Checks if a context-free rule is left-linear. -isLeftLinear :: Set Cat -- ^ The categories to consider - -> CFRule -- ^ The rule to check for left-linearity - -> Bool -isLeftLinear cs = noCatsInSet cs . drop 1 . ruleRhs - - --- --- * Symbol utilities --- - -symbol :: (c -> a) -> (t -> a) -> Symbol c t -> a -symbol fc ft (NonTerminal cat) = fc cat -symbol fc ft (Terminal tok) = ft tok - -mapSymbol :: (c -> c') -> (t -> t') -> Symbol c t -> Symbol c' t' -mapSymbol fc ft = symbol (NonTerminal . fc) (Terminal . ft) - -filterCats :: [Symbol c t] -> [c] -filterCats syms = [ cat | NonTerminal cat <- syms ] - -filterToks :: [Symbol c t] -> [t] -filterToks syms = [ tok | Terminal tok <- syms ] - --- | 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 - -noCatsInSet :: Ord c => Set c -> [Symbol c t] -> Bool -noCatsInSet cs = not . any (`catElem` cs) diff --git a/src/GF/Speech/CFGToFA.hs b/src/GF/Speech/CFGToFA.hs deleted file mode 100644 index 3045ac842..000000000 --- a/src/GF/Speech/CFGToFA.hs +++ /dev/null @@ -1,244 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Speech.CFGToFA --- --- Approximates CFGs with finite state networks. ----------------------------------------------------------------------- -module GF.Speech.CFGToFA (cfgToFA, makeSimpleRegular, - MFA(..), 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 PGF.CId -import PGF.Data -import GF.Data.Utilities -import GF.Speech.CFG -import GF.Speech.PGFToCFG -import GF.Infra.Ident (Ident) - -import GF.Data.Graph -import GF.Data.Relation -import GF.Speech.FiniteState -import GF.Speech.CFG - -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 --- - -data MFA = MFA Cat [(Cat,DFA CFSymbol)] - - - -cfgToFA :: CFG -> DFA Token -cfgToFA = minimize . compileAutomaton . makeSimpleRegular - - --- --- * Compile strongly regular grammars to NFAs --- - --- Convert a strongly regular grammar to a finite automaton. -compileAutomaton :: CFG -> NFA Token -compileAutomaton g = make_fa (g,ns) s [NonTerminal (cfgStartCat g)] 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 :: (CFG,MutRecSets) -> State -> [CFSymbol] -> State - -> NFA Token -> NFA Token -make_fa c@(g,ns) q0 alpha q1 fa = - case alpha of - [] -> newTransition q0 q1 Nothing fa - [Terminal t] -> newTransition q0 q1 (Just t) fa - [NonTerminal a] -> - case Map.lookup a ns of - -- a is recursive - Just n@(MutRecSet { mrCats = ni, mrNonRecRules = nrs, mrRecRules = rs} ) -> - case mrRec n of - -- the set Ni is right-recursive or cyclic - RightR -> - let new = [(getState c, xs, q1) | CFRule c xs _ <- nrs] - ++ [(getState c, xs, getState d) | CFRule c ss _ <- rs, - let (xs,NonTerminal d) = (init ss,last ss)] - in make_fas new $ newTransition q0 (getState a) Nothing fa' - -- the set Ni is left-recursive - LeftR -> - let new = [(q0, xs, getState c) | CFRule c xs _ <- nrs] - ++ [(getState d, xs, getState c) | CFRule c (NonTerminal 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 :: CFG -> MFA -cfgToMFA = buildMFA . makeSimpleRegular - --- | Build a DFA by building and expanding an MFA -cfgToFA' :: CFG -> DFA Token -cfgToFA' = mfaToDFA . cfgToMFA - -buildMFA :: CFG -> MFA -buildMFA g = sortSubLats $ removeUnusedSubLats mfa - where fas = compileAutomata g - mfa = MFA (cfgStartCat g) [(c, minimize fa) | (c,fa) <- fas] - -mfaStartDFA :: MFA -> DFA CFSymbol -mfaStartDFA (MFA start subs) = - fromMaybe (error $ "Bad start MFA: " ++ start) $ lookup start subs - -mfaToDFA :: MFA -> DFA Token -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 (Terminal s) -> newTransition f t (Just s) fa - Just (NonTerminal l) -> insertNFA fa (f,t) (expand $ getSub l) - -removeUnusedSubLats :: MFA -> MFA -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 -> Map Cat (Set Cat) -subLatUseMap (MFA _ subs) = Map.fromList [(c,usedSubLats n) | (c,n) <- subs] - -usedSubLats :: DFA CFSymbol -> Set Cat -usedSubLats fa = Set.fromList [s | (_,_,NonTerminal s) <- transitions fa] - --- | Sort sub-networks topologically. -sortSubLats :: MFA -> MFA -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 :: CFG - -> [(Cat,NFA CFSymbol)] - -- ^ 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 [NonTerminal 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 - -> [CFSymbol] -- ^ Symbols to accept - -> State -- ^ State to end up in - -> NFA CFSymbol -- ^ FA to add to. - -> NFA CFSymbol -make_fa1 mr q0 alpha q1 fa = - case alpha of - [] -> newTransition q0 q1 Nothing fa - [t@(Terminal _)] -> newTransition q0 q1 (Just t) fa - [c@(NonTerminal a)] | not (a `Set.member` mrCats mr) -> newTransition q0 q1 (Just c) fa - [NonTerminal 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,NonTerminal 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 (NonTerminal 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 :: CFG -> [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)) - -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] diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs deleted file mode 100644 index 136d773a2..000000000 --- a/src/GF/Speech/FiniteState.hs +++ /dev/null @@ -1,329 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : FiniteState --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/10 16:43:44 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.16 $ --- --- A simple finite state network module. ------------------------------------------------------------------------------ -module GF.Speech.FiniteState (FA(..), State, NFA, DFA, - startState, finalStates, - states, transitions, - isInternal, - newFA, newFA_, - addFinalState, - newState, newStates, - newTransition, newTransitions, - insertTransitionWith, insertTransitionsWith, - mapStates, mapTransitions, - modifyTransitions, - nonLoopTransitionsTo, nonLoopTransitionsFrom, - loops, - removeState, - oneFinalState, - insertNFA, - onGraph, - moveLabelsToNodes, removeTrivialEmptyNodes, - minimize, - dfa2nfa, - unusedNames, renameStates, - prFAGraphviz, faToGraphviz) where - -import Data.List -import Data.Maybe -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set - -import GF.Data.Utilities -import GF.Data.Graph -import qualified GF.Data.Graphviz as Dot - -type State = Int - --- | Type parameters: node id type, state label type, edge label type --- Data constructor arguments: nodes and edges, start state, final states -data FA n a b = FA !(Graph n a b) !n ![n] - -type NFA a = FA State () (Maybe a) - -type DFA a = FA State () a - - -startState :: FA n a b -> n -startState (FA _ s _) = s - -finalStates :: FA n a b -> [n] -finalStates (FA _ _ ss) = ss - -states :: FA n a b -> [(n,a)] -states (FA g _ _) = nodes g - -transitions :: FA n a b -> [(n,n,b)] -transitions (FA g _ _) = edges g - -newFA :: Enum n => a -- ^ Start node label - -> FA n a b -newFA l = FA g s [] - where (g,s) = newNode l (newGraph [toEnum 0..]) - --- | Create a new finite automaton with an initial and a final state. -newFA_ :: Enum n => (FA n () b, n, n) -newFA_ = (fa'', s, f) - where fa = newFA () - s = startState fa - (fa',f) = newState () fa - fa'' = addFinalState f fa' - -addFinalState :: n -> FA n a b -> FA n a b -addFinalState f (FA g s ss) = FA g s (f:ss) - -newState :: a -> FA n a b -> (FA n a b, n) -newState x (FA g s ss) = (FA g' s ss, n) - where (g',n) = newNode x g - -newStates :: [a] -> FA n a b -> (FA n a b, [(n,a)]) -newStates xs (FA g s ss) = (FA g' s ss, ns) - where (g',ns) = newNodes xs g - -newTransition :: n -> n -> b -> FA n a b -> FA n a b -newTransition f t l = onGraph (newEdge (f,t,l)) - -newTransitions :: [(n, n, b)] -> FA n a b -> FA n a b -newTransitions es = onGraph (newEdges es) - -insertTransitionWith :: Eq n => - (b -> b -> b) -> (n, n, b) -> FA n a b -> FA n a b -insertTransitionWith f t = onGraph (insertEdgeWith f t) - -insertTransitionsWith :: Eq n => - (b -> b -> b) -> [(n, n, b)] -> FA n a b -> FA n a b -insertTransitionsWith f ts fa = - foldl' (flip (insertTransitionWith f)) fa ts - -mapStates :: (a -> c) -> FA n a b -> FA n c b -mapStates f = onGraph (nmap f) - -mapTransitions :: (b -> c) -> FA n a b -> FA n a c -mapTransitions f = onGraph (emap f) - -modifyTransitions :: ([(n,n,b)] -> [(n,n,b)]) -> FA n a b -> FA n a b -modifyTransitions f = onGraph (\ (Graph r ns es) -> Graph r ns (f es)) - -removeState :: Ord n => n -> FA n a b -> FA n a b -removeState n = onGraph (removeNode n) - -minimize :: Ord a => NFA a -> DFA a -minimize = determinize . reverseNFA . dfa2nfa . determinize . reverseNFA - -unusedNames :: FA n a b -> [n] -unusedNames (FA (Graph names _ _) _ _) = names - --- | Gets all incoming transitions to a given state, excluding --- transtions from the state itself. -nonLoopTransitionsTo :: Eq n => n -> FA n a b -> [(n,b)] -nonLoopTransitionsTo s fa = - [(f,l) | (f,t,l) <- transitions fa, t == s && f /= s] - -nonLoopTransitionsFrom :: Eq n => n -> FA n a b -> [(n,b)] -nonLoopTransitionsFrom s fa = - [(t,l) | (f,t,l) <- transitions fa, f == s && t /= s] - -loops :: Eq n => n -> FA n a b -> [b] -loops s fa = [l | (f,t,l) <- transitions fa, f == s && t == s] - --- | Give new names to all nodes. -renameStates :: Ord x => [y] -- ^ Infinite supply of new names - -> FA x a b - -> FA y a b -renameStates supply (FA g s fs) = FA (renameNodes newName rest g) s' fs' - where (ns,rest) = splitAt (length (nodes g)) supply - newNodes = Map.fromList (zip (map fst (nodes g)) ns) - newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes - s' = newName s - fs' = map newName fs - --- | Insert an NFA into another -insertNFA :: NFA a -- ^ NFA to insert into - -> (State, State) -- ^ States to insert between - -> NFA a -- ^ NFA to insert. - -> NFA a -insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2) - = FA (newEdges es g') s1 fs1 - where - es = (f,ren s2,Nothing):[(ren f2,t,Nothing) | f2 <- fs2] - (g',ren) = mergeGraphs g1 g2 - -onGraph :: (Graph n a b -> Graph n c d) -> FA n a b -> FA n c d -onGraph f (FA g s ss) = FA (f g) s ss - - --- | Make the finite automaton have a single final state --- by adding a new final state and adding an edge --- from the old final states to the new state. -oneFinalState :: a -- ^ Label to give the new node - -> b -- ^ Label to give the new edges - -> FA n a b -- ^ The old network - -> FA n a b -- ^ The new network -oneFinalState nl el fa = - let (FA g s fs,nf) = newState nl fa - es = [ (f,nf,el) | f <- fs ] - in FA (newEdges es g) s [nf] - --- | Transform a standard finite automaton with labelled edges --- to one where the labels are on the nodes instead. This can add --- up to one extra node per edge. -moveLabelsToNodes :: (Ord n,Eq a) => FA n () (Maybe a) -> FA n (Maybe a) () -moveLabelsToNodes = onGraph f - where f g@(Graph c _ _) = Graph c' ns (concat ess) - where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)] - (c',is') = mapAccumL fixIncoming c is - (ns,ess) = unzip (concat is') - - --- | Remove empty nodes which are not start or final, and have --- exactly one outgoing edge or exactly one incoming edge. -removeTrivialEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) () -removeTrivialEmptyNodes = pruneUnusable . skipSimpleEmptyNodes - --- | Move edges to empty nodes to point to the next node(s). --- This is not done if the pointed-to node is a final node. -skipSimpleEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) () -skipSimpleEmptyNodes fa = onGraph og fa - where - og g@(Graph c ns es) = if es' == es then g else og (Graph c ns es') - where - es' = concatMap changeEdge es - info = nodeInfo g - changeEdge e@(f,t,()) - | isNothing (getNodeLabel info t) - -- && (i * o <= i + o) - && not (isFinal fa t) - = [ (f,t',()) | (_,t',()) <- getOutgoing info t] - | otherwise = [e] --- where i = inDegree info t --- o = outDegree info t - -isInternal :: Eq n => FA n a b -> n -> Bool -isInternal (FA _ start final) n = n /= start && n `notElem` final - -isFinal :: Eq n => FA n a b -> n -> Bool -isFinal (FA _ _ final) n = n `elem` final - --- | Remove all internal nodes with no incoming edges --- or no outgoing edges. -pruneUnusable :: Ord n => FA n (Maybe a) () -> FA n (Maybe a) () -pruneUnusable fa = onGraph f fa - where - f g = if Set.null rns then g else f (removeNodes rns g) - where info = nodeInfo g - rns = Set.fromList [ n | (n,_) <- nodes g, - isInternal fa n, - inDegree info n == 0 - || outDegree info n == 0] - -fixIncoming :: (Ord n, Eq a) => [n] - -> (Node n (),[Edge n (Maybe a)]) -- ^ A node and its incoming edges - -> ([n],[(Node n (Maybe a),[Edge n ()])]) -- ^ Replacement nodes with their - -- incoming edges. -fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts) - where ls = nub $ map edgeLabel es - (cs',cs'') = splitAt (length ls) cs - newNodes = zip cs' ls - es' = [ (x,n,()) | x <- map fst newNodes ] - -- separate cyclic and non-cyclic edges - (cyc,ncyc) = partition (\ (f,_,_) -> f == n) es - -- keep all incoming non-cyclic edges with the right label - to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l'] - -- for each cyclic edge with the right label, - -- add an edge from each of the new nodes (including this one) - ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes] - newContexts = [ (v, to v) | v <- newNodes ] - -alphabet :: Eq b => Graph n a (Maybe b) -> [b] -alphabet = nub . catMaybes . map edgeLabel . edges - -determinize :: Ord a => NFA a -> DFA a -determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.empty - (ns',es') = (Set.toList ns, Set.toList es) - final = filter isDFAFinal ns' - fa = FA (Graph undefined [(n,()) | n <- ns'] es') start final - in renameStates [0..] fa - where info = nodeInfo g --- reach = nodesReachable out - start = closure info $ Set.singleton s - isDFAFinal n = not (Set.null (Set.fromList f `Set.intersection` n)) - h currentStates oldStates es - | Set.null currentStates = (oldStates,es) - | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es' - where - allOldStates = oldStates `Set.union` currentStates - (newStates,es') = new (Set.toList currentStates) Set.empty es - uniqueNewStates = newStates Set.\\ allOldStates - -- Get the sets of states reachable from the given states - -- by consuming one symbol, and the associated edges. - new [] rs es = (rs,es) - new (n:ns) rs es = new ns rs' es' - where cs = reachable info n --reachable reach n - rs' = rs `Set.union` Set.fromList (map snd cs) - es' = es `Set.union` Set.fromList [(n,s,c) | (c,s) <- cs] - - --- | Get all the nodes reachable from a list of nodes by only empty edges. -closure :: Ord n => NodeInfo n a (Maybe b) -> Set n -> Set n -closure info x = closure_ x x - where closure_ acc check | Set.null check = acc - | otherwise = closure_ acc' check' - where - reach = Set.fromList [y | x <- Set.toList check, - (_,y,Nothing) <- getOutgoing info x] - acc' = acc `Set.union` reach - check' = reach Set.\\ acc - --- | Get a map of labels to sets of all nodes reachable --- from a the set of nodes by one edge with the given --- label and then any number of empty edges. -reachable :: (Ord n,Ord b) => NodeInfo n a (Maybe b) -> Set n -> [(b,Set n)] -reachable info ns = Map.toList $ Map.map (closure info . Set.fromList) $ reachable1 info ns -reachable1 info ns = Map.fromListWith (++) [(c, [y]) | n <- Set.toList ns, (_,y,Just c) <- getOutgoing info n] - -reverseNFA :: NFA a -> NFA a -reverseNFA (FA g s fs) = FA g''' s' [s] - where g' = reverseGraph g - (g'',s') = newNode () g' - g''' = newEdges [(s',f,Nothing) | f <- fs] g'' - -dfa2nfa :: DFA a -> NFA a -dfa2nfa = mapTransitions Just - --- --- * Visualization --- - -prFAGraphviz :: (Eq n,Show n) => FA n String String -> String -prFAGraphviz = Dot.prGraphviz . faToGraphviz - -prFAGraphviz_ :: (Eq n,Show n,Show a, Show b) => FA n a b -> String -prFAGraphviz_ = Dot.prGraphviz . faToGraphviz . mapStates show . mapTransitions show - -faToGraphviz :: (Eq n,Show n) => FA n String String -> Dot.Graph -faToGraphviz (FA (Graph _ ns es) s f) - = Dot.Graph Dot.Directed Nothing [] (map mkNode ns) (map mkEdge es) [] - where mkNode (n,l) = Dot.Node (show n) attrs - where attrs = [("label",l)] - ++ if n == s then [("shape","box")] else [] - ++ if n `elem` f then [("style","bold")] else [] - mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)] - --- --- * Utilities --- - -lookups :: Ord k => [k] -> Map k a -> [a] -lookups xs m = mapMaybe (flip Map.lookup m) xs diff --git a/src/GF/Speech/GSL.hs b/src/GF/Speech/GSL.hs deleted file mode 100644 index 8f26ea64c..000000000 --- a/src/GF/Speech/GSL.hs +++ /dev/null @@ -1,95 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Speech.GSL --- --- This module prints a CFG as a Nuance GSL 2.0 grammar. --- ------------------------------------------------------------------------------ - -module GF.Speech.GSL (gslPrinter) where - -import GF.Data.Utilities -import GF.Speech.CFG -import GF.Speech.SRG -import GF.Speech.RegExp -import GF.Infra.Option -import GF.Infra.Ident -import PGF.CId -import PGF.Data - -import Data.Char (toUpper,toLower) -import Data.List (partition) -import Text.PrettyPrint.HughesPJ - -width :: Int -width = 75 - -gslPrinter :: Options -> PGF -> CId -> String -gslPrinter opts pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG opts pgf cnc - where st = style { lineLength = width } - -prGSL :: SRG -> Doc -prGSL srg = header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules srg)) - where - header = text ";GSL2.0" $$ - comment ("Nuance speech recognition grammar for " ++ srgName srg) $$ - comment ("Generated by GF") - mainCat = text ".MAIN" <+> prCat (srgStartCat srg) - prRule (SRGRule cat rhs) = 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 = symbol (prCat . fst) (doubleQuotes . showToken) - --- GSL requires an upper case letter in category names -prCat :: Cat -> Doc -prCat = text . firstToUpper - - -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 = text . map toLower - -isPunct :: Char -> Bool -isPunct c = c `elem` "-_.:;.,?!()[]{}" - -comment :: String -> Doc -comment s = text ";" <+> text s - - --- Pretty-printing utilities - -emptyLine :: Doc -emptyLine = text "" - -($++$) :: Doc -> Doc -> Doc -x $++$ y = x $$ emptyLine $$ y diff --git a/src/GF/Speech/JSGF.hs b/src/GF/Speech/JSGF.hs deleted file mode 100644 index 2cfeea5f5..000000000 --- a/src/GF/Speech/JSGF.hs +++ /dev/null @@ -1,113 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Speech.JSGF --- --- 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.JSGF (jsgfPrinter) where - -import GF.Data.Utilities -import GF.Infra.Option -import GF.Speech.CFG -import GF.Speech.RegExp -import GF.Speech.SISR -import GF.Speech.SRG -import PGF.CId -import PGF.Data - -import Data.Char -import Data.List -import Data.Maybe -import Text.PrettyPrint.HughesPJ -import Debug.Trace - -width :: Int -width = 75 - -jsgfPrinter :: Options - -> PGF - -> CId -> String -jsgfPrinter opts pgf cnc = renderStyle st $ prJSGF sisr $ makeNonLeftRecursiveSRG opts pgf cnc - where st = style { lineLength = width } - sisr = flag optSISR opts - -prJSGF :: Maybe SISRFormat -> SRG -> Doc -prJSGF sisr srg - = header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules srg)) - where - header = text "#JSGF" <+> text "V1.0" <+> text "UTF-8" <+> lang <> char ';' $$ - comment ("JSGF speech recognition grammar for " ++ srgName srg) $$ - comment "Generated by GF" $$ - text ("grammar " ++ srgName srg ++ ";") - lang = maybe empty text (srgLanguage srg) - mainCat = rule True "MAIN" [prCat (srgStartCat srg)] - prRule (SRGRule cat rhs) = rule (isExternalCat srg cat) cat (map prAlt rhs) - prAlt (SRGAlt mp n rhs) = sep [initTag, p (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 - -prCat :: Cat -> 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 - -prSymbol :: Maybe SISRFormat -> CFTerm -> SRGSymbol -> Doc -prSymbol sisr cn (NonTerminal n@(c,_)) = prCat c <+> tag sisr (catSISR cn n) -prSymbol _ cn (Terminal t) | all isPunct t = empty -- removes punctuation - | otherwise = text 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 -> Cat -> [Doc] -> Doc -rule pub c xs = p <+> prCat c <+> char '=' <+> nest 2 (alts xs) <+> char ';' - where p = if pub then text "public" else empty - --- Pretty-printing utilities - -emptyLine :: Doc -emptyLine = text "" - -prepunctuate :: Doc -> [Doc] -> [Doc] -prepunctuate _ [] = [] -prepunctuate p (x:xs) = x : map (p <>) xs - -($++$) :: Doc -> Doc -> Doc -x $++$ y = x $$ emptyLine $$ y - diff --git a/src/GF/Speech/PGFToCFG.hs b/src/GF/Speech/PGFToCFG.hs deleted file mode 100644 index d22a4ea8d..000000000 --- a/src/GF/Speech/PGFToCFG.hs +++ /dev/null @@ -1,116 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Speech.PGFToCFG --- --- Approximates PGF grammars with context-free grammars. ----------------------------------------------------------------------- -module GF.Speech.PGFToCFG (bnfPrinter, pgfToCFG) where - -import PGF.CId -import PGF.Data as PGF -import PGF.Macros -import GF.Infra.Ident -import GF.Speech.CFG - -import Data.Array.IArray as Array -import Data.List -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as Set - -bnfPrinter :: PGF -> CId -> String -bnfPrinter = toBNF id - -toBNF :: (CFG -> CFG) -> PGF -> CId -> String -toBNF f pgf cnc = prCFG $ f $ pgfToCFG pgf cnc - - -pgfToCFG :: PGF - -> CId -- ^ Concrete syntax name - -> CFG -pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ concatMap fruleToCFRule rules) - where - pinfo = fromMaybe (error "pgfToCFG: No parser.") (lookParser pgf lang) - - rules :: [(FCat,Production)] - rules = [(fcat,prod) | (fcat,set) <- IntMap.toList (PGF.productions pinfo) - , prod <- Set.toList set] - - fcatCats :: Map FCat Cat - fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i) - | (c,fcs) <- Map.toList (startCats pinfo), - (fc,i) <- zip fcs [1..]] - - fcatCat :: FCat -> Cat - fcatCat c = Map.findWithDefault ("Unknown_" ++ show c) c fcatCats - - fcatToCat :: FCat -> FIndex -> Cat - fcatToCat c l = fcatCat c ++ row - where row = if catLinArity c == 1 then "" else "_" ++ show l - - -- gets the number of fields in the lincat for the given category - catLinArity :: FCat -> Int - catLinArity c = maximum (1:[rangeSize (bounds rhs) | (FFun _ _ rhs, _) <- topdownRules c]) - - topdownRules cat = f cat [] - where - f cat rules = maybe rules (Set.fold g rules) (IntMap.lookup cat (productions pinfo)) - - g (FApply funid args) rules = (functions pinfo ! funid,args) : rules - g (FCoerce cat) rules = f cat rules - - - extCats :: Set Cat - extCats = Set.fromList $ map lhsCat startRules - - startRules :: [CFRule] - startRules = [CFRule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0) - | (c,fcs) <- Map.toList (startCats pinfo), - fc <- fcs, not (isLiteralFCat fc), - r <- [0..catLinArity fc-1]] - - fruleToCFRule :: (FCat,Production) -> [CFRule] - fruleToCFRule (c,FApply funid args) = - [CFRule (fcatToCat c l) (mkRhs row) (profilesToTerm (map (fixProfile row) ps)) - | (l,seqid) <- Array.assocs rhs - , let row = sequences pinfo ! seqid - , not (containsLiterals row)] - where - FFun f ps rhs = functions pinfo ! funid - - mkRhs :: Array FPointPos FSymbol -> [CFSymbol] - mkRhs = concatMap fsymbolToSymbol . Array.elems - - containsLiterals :: Array FPointPos FSymbol -> Bool - containsLiterals row = any isLiteralFCat [args!!n | FSymCat n _ <- Array.elems row] || - not (null [n | FSymLit n _ <- Array.elems row]) -- only this is needed for PMCFG. - -- The first line is for backward compat. - - fsymbolToSymbol :: FSymbol -> [CFSymbol] - fsymbolToSymbol (FSymCat n l) = [NonTerminal (fcatToCat (args!!n) l)] - fsymbolToSymbol (FSymLit n l) = [NonTerminal (fcatToCat (args!!n) l)] - fsymbolToSymbol (FSymKS ts) = map Terminal ts - - fixProfile :: Array FPointPos FSymbol -> Profile -> Profile - fixProfile row = concatMap positions - where - nts = zip [0..] [j | nt <- Array.elems row, j <- getPos nt] - positions i = [k | (k,j) <- nts, j == i] - - getPos (FSymCat j _) = [j] - getPos (FSymLit j _) = [j] - getPos _ = [] - - profilesToTerm :: [Profile] -> CFTerm - profilesToTerm ps = CFObj f (zipWith profileToTerm argTypes ps) - where (argTypes,_) = catSkeleton $ lookType pgf f - - profileToTerm :: CId -> Profile -> CFTerm - profileToTerm t [] = CFMeta t - profileToTerm _ xs = CFRes (last xs) -- FIXME: unify - fruleToCFRule (c,FCoerce c') = - [CFRule (fcatToCat c l) [NonTerminal (fcatToCat c' l)] (CFRes 0) - | l <- [0..catLinArity c-1]] diff --git a/src/GF/Speech/PrRegExp.hs b/src/GF/Speech/PrRegExp.hs deleted file mode 100644 index 0fc35d541..000000000 --- a/src/GF/Speech/PrRegExp.hs +++ /dev/null @@ -1,27 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Speech.PrRegExp --- --- This module prints a grammar as a regular expression. ------------------------------------------------------------------------------ - -module GF.Speech.PrRegExp (regexpPrinter,multiRegexpPrinter) where - -import GF.Speech.CFG -import GF.Speech.CFGToFA -import GF.Speech.PGFToCFG -import GF.Speech.RegExp -import PGF - -regexpPrinter :: PGF -> CId -> String -regexpPrinter pgf cnc = (++"\n") $ prRE id $ dfa2re $ cfgToFA $ pgfToCFG pgf cnc - -multiRegexpPrinter :: PGF -> CId -> String -multiRegexpPrinter pgf cnc = prREs $ mfa2res $ cfgToMFA $ pgfToCFG pgf cnc - -prREs :: [(String,RE CFSymbol)] -> String -prREs res = unlines [l ++ " = " ++ prRE id (mapRE showLabel re) | (l,re) <- res] - where showLabel = symbol (\l -> "<" ++ l ++ ">") id - -mfa2res :: MFA -> [(String,RE CFSymbol)] -mfa2res (MFA _ dfas) = [(l, minimizeRE (dfa2re dfa)) | (l,dfa) <- dfas] diff --git a/src/GF/Speech/RegExp.hs b/src/GF/Speech/RegExp.hs deleted file mode 100644 index 2592b3d57..000000000 --- a/src/GF/Speech/RegExp.hs +++ /dev/null @@ -1,144 +0,0 @@ -module GF.Speech.RegExp (RE(..), - epsilonRE, nullRE, - isEpsilon, isNull, - unionRE, concatRE, seqRE, - repeatRE, minimizeRE, - mapRE, mapRE', joinRE, - symbolsRE, - dfa2re, prRE) where - -import Data.List - -import GF.Data.Utilities -import GF.Speech.FiniteState - -data RE a = - REUnion [RE a] -- ^ REUnion [] is null - | REConcat [RE a] -- ^ REConcat [] is epsilon - | RERepeat (RE a) - | RESymbol a - deriving (Eq,Ord,Show) - - -dfa2re :: (Ord a) => DFA a -> RE a -dfa2re = finalRE . elimStates . modifyTransitions merge . addLoops - . oneFinalState () epsilonRE . mapTransitions RESymbol - where addLoops fa = newTransitions [(s,s,nullRE) | (s,_) <- states fa] fa - merge es = [(f,t,unionRE ls) - | ((f,t),ls) <- buildMultiMap [((f,t),l) | (f,t,l) <- es]] - -elimStates :: (Ord a) => DFA (RE a) -> DFA (RE a) -elimStates fa = - case [s | (s,_) <- states fa, isInternal fa s] of - [] -> fa - sE:_ -> elimStates $ insertTransitionsWith (\x y -> unionRE [x,y]) ts $ removeState sE fa - where sAs = nonLoopTransitionsTo sE fa - sBs = nonLoopTransitionsFrom sE fa - r2 = unionRE $ loops sE fa - ts = [(sA, sB, r r1 r3) | (sA,r1) <- sAs, (sB,r3) <- sBs] - r r1 r3 = concatRE [r1, repeatRE r2, r3] - -epsilonRE :: RE a -epsilonRE = REConcat [] - -nullRE :: RE a -nullRE = REUnion [] - -isNull :: RE a -> Bool -isNull (REUnion []) = True -isNull _ = False - -isEpsilon :: RE a -> Bool -isEpsilon (REConcat []) = True -isEpsilon _ = False - -unionRE :: Ord a => [RE a] -> RE a -unionRE = unionOrId . sortNub . concatMap toList - where - toList (REUnion xs) = xs - toList x = [x] - unionOrId [r] = r - unionOrId rs = REUnion rs - -concatRE :: [RE a] -> RE a -concatRE xs | any isNull xs = nullRE - | otherwise = case concatMap toList xs of - [r] -> r - rs -> REConcat rs - where - toList (REConcat xs) = xs - toList x = [x] - -seqRE :: [a] -> RE a -seqRE = concatRE . map RESymbol - -repeatRE :: RE a -> RE a -repeatRE x | isNull x || isEpsilon x = epsilonRE - | otherwise = RERepeat x - -finalRE :: Ord a => DFA (RE a) -> RE a -finalRE fa = concatRE [repeatRE r1, r2, - repeatRE (unionRE [r3, concatRE [r4, repeatRE r1, r2]])] - where - s0 = startState fa - [sF] = finalStates fa - r1 = unionRE $ loops s0 fa - r2 = unionRE $ map snd $ nonLoopTransitionsTo sF fa - r3 = unionRE $ loops sF fa - r4 = unionRE $ map snd $ nonLoopTransitionsFrom sF fa - -reverseRE :: RE a -> RE a -reverseRE (REConcat xs) = REConcat $ map reverseRE $ reverse xs -reverseRE (REUnion xs) = REUnion (map reverseRE xs) -reverseRE (RERepeat x) = RERepeat (reverseRE x) -reverseRE x = x - -minimizeRE :: Ord a => RE a -> RE a -minimizeRE = reverseRE . mergeForward . reverseRE . mergeForward - -mergeForward :: Ord a => RE a -> RE a -mergeForward (REUnion xs) = - unionRE [concatRE [mergeForward y,mergeForward (unionRE rs)] | (y,rs) <- buildMultiMap (map firstRE xs)] -mergeForward (REConcat (x:xs)) = concatRE [mergeForward x,mergeForward (REConcat xs)] -mergeForward (RERepeat r) = repeatRE (mergeForward r) -mergeForward r = r - -firstRE :: RE a -> (RE a, RE a) -firstRE (REConcat (x:xs)) = (x, REConcat xs) -firstRE r = (r,epsilonRE) - -mapRE :: (a -> b) -> RE a -> RE b -mapRE f = mapRE' (RESymbol . f) - -mapRE' :: (a -> RE b) -> RE a -> RE b -mapRE' f (REConcat xs) = REConcat (map (mapRE' f) xs) -mapRE' f (REUnion xs) = REUnion (map (mapRE' f) xs) -mapRE' f (RERepeat x) = RERepeat (mapRE' f x) -mapRE' f (RESymbol s) = f s - -joinRE :: RE (RE a) -> RE a -joinRE (REConcat xs) = REConcat (map joinRE xs) -joinRE (REUnion xs) = REUnion (map joinRE xs) -joinRE (RERepeat xs) = RERepeat (joinRE xs) -joinRE (RESymbol ss) = ss - -symbolsRE :: RE a -> [a] -symbolsRE (REConcat xs) = concatMap symbolsRE xs -symbolsRE (REUnion xs) = concatMap symbolsRE xs -symbolsRE (RERepeat x) = symbolsRE x -symbolsRE (RESymbol x) = [x] - --- Debugging - -prRE :: (a -> String) -> RE a -> String -prRE = prRE' 0 - -prRE' :: Int -> (a -> String) -> RE a -> String -prRE' _ _ (REUnion []) = "" -prRE' n f (REUnion xs) = p n 1 (concat (intersperse " | " (map (prRE' 1 f) xs))) -prRE' n f (REConcat xs) = p n 2 (unwords (map (prRE' 2 f) xs)) -prRE' n f (RERepeat x) = p n 3 (prRE' 3 f x) ++ "*" -prRE' _ f (RESymbol s) = f s - -p n m s | n >= m = "(" ++ s ++ ")" - | True = s diff --git a/src/GF/Speech/SISR.hs b/src/GF/Speech/SISR.hs deleted file mode 100644 index f966d96b9..000000000 --- a/src/GF/Speech/SISR.hs +++ /dev/null @@ -1,77 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Speech.SISR --- --- 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.Data.Utilities -import GF.Infra.Ident -import GF.Infra.Option (SISRFormat(..)) -import GF.Speech.CFG -import GF.Speech.SRG (SRGNT) -import PGF.CId - -import qualified GF.JavaScript.AbsJS as JS -import qualified GF.JavaScript.PrintJS as JS - -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 (showCId 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 (showCId typ))] - -fmtOut SISR_WD20030401 = JS.EVar (JS.Ident "$") -fmtOut SISR_1_0 = JS.EVar (JS.Ident "out") - -fmtRef SISR_WD20030401 c = JS.EVar (JS.Ident ("$" ++ c)) -fmtRef SISR_1_0 c = field (JS.EVar (JS.Ident "rules")) c - -args = JS.Ident "a" - -var v = JS.Ident ("x" ++ show v) - -field x y = JS.EMember x (JS.Ident y) - -ass = JS.EAssign - -tree n xs = obj [("name", JS.EStr n), ("args", JS.EArray xs)] - -obj ps = JS.EObj [JS.Prop (JS.StringPropName x) y | (x,y) <- ps] - diff --git a/src/GF/Speech/SLF.hs b/src/GF/Speech/SLF.hs deleted file mode 100644 index 84633149b..000000000 --- a/src/GF/Speech/SLF.hs +++ /dev/null @@ -1,178 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Speech.SLF --- --- 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. --- ------------------------------------------------------------------------------ - -module GF.Speech.SLF (slfPrinter,slfGraphvizPrinter, - slfSubPrinter,slfSubGraphvizPrinter) where - -import GF.Data.Utilities -import GF.Speech.CFG -import GF.Speech.FiniteState -import GF.Speech.CFG -import GF.Speech.CFGToFA -import GF.Speech.PGFToCFG -import qualified GF.Data.Graphviz as Dot -import PGF -import PGF.CId - -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 CFSymbol) () - -mkFAs :: PGF -> CId -> (SLF_FA, [(String,SLF_FA)]) -mkFAs pgf cnc = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs]) - where MFA start subs = {- renameSubs $ -} cfgToMFA $ pgfToCFG pgf cnc - main = let (fa,s,f) = newFA_ in newTransition s f (NonTerminal 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 -> MFA -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 :: PGF -> CId -> String -slfGraphvizPrinter pgf cnc - = prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA' $ pgfToCFG pgf cnc - where - gvFA = mapStates (fromMaybe "") . mapTransitions (const "") - --- --- * SLF graphviz printing (with sub-networks) --- - -slfSubGraphvizPrinter :: PGF -> CId -> String -slfSubGraphvizPrinter pgf cnc = Dot.prGraphviz g - where (main, subs) = mkFAs pgf cnc - 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 :: PGF -> CId -> String -slfPrinter pgf cnc - = prSLF $ automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA' $ pgfToCFG pgf cnc - --- --- * SLF printing (with sub-networks) --- - --- | Make a network with subnetworks in SLF -slfSubPrinter :: PGF -> CId -> String -slfSubPrinter pgf cnc = prSLFs slfs - where - (main,subs) = mkFAs pgf cnc - 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 CFSymbol -> SLFNode -mfaNodeToSLFNode i l = case l of - Nothing -> mkSLFNode i Nothing - Just (Terminal x) -> mkSLFNode i (Just x) - Just (NonTerminal s) -> mkSLFSubLat i s - -mkSLFNode :: Int -> Maybe String -> SLFNode -mkSLFNode i Nothing = SLFNode { nId = i, nWord = Nothing, nTag = Nothing } -mkSLFNode i (Just w) - | isNonWord w = SLFNode { nId = i, - nWord = Nothing, - nTag = Just w } - | otherwise = SLFNode { nId = i, - nWord = Just (map toUpper w), - nTag = Just w } - -mkSLFSubLat :: Int -> String -> SLFNode -mkSLFSubLat i sub = SLFSubLat { nId = i, nLat = sub } - -mkSLFEdge :: Int -> (Int,Int) -> SLFEdge -mkSLFEdge i (f,t) = SLFEdge { eId = i, eStart = f, eEnd = t } - -prSLFs :: SLFs -> String -prSLFs (SLFs subs main) = unlinesS (map prSub subs ++ [prOneSLF main]) "" - where prSub (n,s) = showString "SUBLAT=" . shows n - . nl . prOneSLF s . showString "." . nl - -prSLF :: SLF -> String -prSLF slf = prOneSLF slf "" - -prOneSLF :: SLF -> ShowS -prOneSLF (SLF { slfNodes = ns, slfEdges = es}) - = header . unlinesS (map prNode ns) . nl . unlinesS (map prEdge es) . nl - where - header = prFields [("N",show (length ns)),("L", show (length es))] . nl - prNode (SLFNode { nId = i, nWord = w, nTag = t }) - = prFields $ [("I",show i),("W",showWord w)] - ++ maybe [] (\t -> [("s",t)]) t - prNode (SLFSubLat { nId = i, nLat = l }) - = prFields [("I",show i),("L",show l)] - prEdge e = prFields [("J",show (eId e)),("S",show (eStart e)),("E",show (eEnd e))] - --- | Check if a word should not correspond to a word in the SLF file. -isNonWord :: String -> Bool -isNonWord = any isPunct - -isPunct :: Char -> Bool -isPunct c = c `elem` "-_.;.,?!()[]{}" - -showWord :: SLFWord -> String -showWord Nothing = "!NULL" -showWord (Just w) | null w = "!NULL" - | otherwise = w - -prFields :: [(String,String)] -> ShowS -prFields fs = unwordsS [ showString l . showChar '=' . showString v | (l,v) <- fs ] diff --git a/src/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs deleted file mode 100644 index 2270ec7a1..000000000 --- a/src/GF/Speech/SRG.hs +++ /dev/null @@ -1,205 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : SRG --- --- 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, SRGSymbol - , SRGNT, CFTerm - , ebnfPrinter - , makeNonLeftRecursiveSRG - , makeNonRecursiveSRG - , getSpeechLanguage - , isExternalCat - , lookupFM_ - ) where - -import GF.Data.Operations -import GF.Data.Utilities -import GF.Infra.Ident -import GF.Infra.Option -import GF.Speech.CFG -import GF.Speech.PGFToCFG -import GF.Data.Relation -import GF.Speech.FiniteState -import GF.Speech.RegExp -import GF.Speech.CFGToFA -import GF.Infra.Option -import PGF.CId -import PGF.Data -import PGF.Macros - -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 { srgName :: String -- ^ grammar name - , srgStartCat :: Cat -- ^ start category name - , srgExternalCats :: Set Cat - , srgLanguage :: Maybe String -- ^ The language for which the grammar - -- is intended, e.g. en-UK - , srgRules :: [SRGRule] - } - deriving (Eq,Show) - -data SRGRule = SRGRule Cat [SRGAlt] - 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 SRGSymbol - -type SRGSymbol = Symbol SRGNT Token - --- | An SRG non-terminal. Category name and its number in the profile. -type SRGNT = (Cat, Int) - -ebnfPrinter :: Options -> PGF -> CId -> String -ebnfPrinter opts pgf cnc = prSRG opts $ makeSRG opts pgf cnc - --- | Create a compact filtered non-left-recursive SRG. -makeNonLeftRecursiveSRG :: Options -> PGF -> CId -> SRG -makeNonLeftRecursiveSRG opts = makeSRG opts' - where - opts' = setDefaultCFGTransform opts CFGNoLR True - -makeSRG :: Options -> PGF -> CId -> SRG -makeSRG opts = mkSRG cfgToSRG preprocess - where - cfgToSRG cfg = [cfRulesToSRGRule rs | (_,rs) <- allRulesGrouped cfg] - preprocess = maybeTransform opts CFGMergeIdentical mergeIdentical - . maybeTransform opts CFGNoLR removeLeftRecursion - . maybeTransform opts CFGRegular makeRegular - . maybeTransform opts CFGTopDownFilter topDownFilter - . maybeTransform opts CFGBottomUpFilter bottomUpFilter - . maybeTransform opts CFGRemoveCycles removeCycles - . maybeTransform opts CFGStartCatOnly purgeExternalCats - -setDefaultCFGTransform :: Options -> CFGTransform -> Bool -> Options -setDefaultCFGTransform opts t b = setCFGTransform t b `addOptions` opts - -maybeTransform :: Options -> CFGTransform -> (CFG -> CFG) -> (CFG -> CFG) -maybeTransform opts t f = if cfgTransform opts t then f else id - -traceStats s g = trace ("---- " ++ s ++ ": " ++ stats g {- ++ "\n" ++ prCFRules g ++ "----" -}) g - -stats g = "Categories: " ++ show (countCats g) - ++ ", External categories: " ++ show (Set.size (cfgExternalCats g)) - ++ ", Rules: " ++ show (countRules g) - -makeNonRecursiveSRG :: Options - -> PGF - -> CId -- ^ Concrete syntax name. - -> SRG -makeNonRecursiveSRG opts = mkSRG cfgToSRG id - where - cfgToSRG cfg = [SRGRule l [SRGAlt Nothing dummyCFTerm (dfaToSRGItem dfa)] | (l,dfa) <- dfas] - where - MFA _ dfas = cfgToMFA cfg - dfaToSRGItem = mapRE dummySRGNT . minimizeRE . dfa2re - dummyCFTerm = CFMeta (mkCId "dummy") - dummySRGNT = mapSymbol (\c -> (c,0)) id - -mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG -mkSRG mkRules preprocess pgf cnc = - SRG { srgName = showCId cnc, - srgStartCat = cfgStartCat cfg, - srgExternalCats = cfgExternalCats cfg, - srgLanguage = getSpeechLanguage pgf cnc, - srgRules = mkRules cfg } - where cfg = renameCats (showCId cnc) $ preprocess $ pgfToCFG pgf cnc - --- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string), --- to C_N where N is an integer. -renameCats :: String -> CFG -> CFG -renameCats prefix cfg = mapCFGCats renameCat cfg - where renameCat c | isExternal c = c ++ "_cat" - | otherwise = Map.findWithDefault (badCat c) c names - isExternal c = c `Set.member` cfgExternalCats cfg - catsByPrefix = buildMultiMap [(takeWhile (/='_') cat, cat) | cat <- allCats' cfg, not (isExternal cat)] - names = Map.fromList [(c,pref++"_"++show i) | (pref,cs) <- catsByPrefix, (c,i) <- zip cs [1..]] - badCat c = error ("GF.Speech.SRG.renameCats: " ++ c ++ "\n" ++ prCFG cfg) - -getSpeechLanguage :: PGF -> CId -> Maybe String -getSpeechLanguage pgf cnc = fmap (replace '_' '-') $ lookConcrFlag pgf cnc (mkCId "language") - -cfRulesToSRGRule :: [CFRule] -> SRGRule -cfRulesToSRGRule rs@(r:_) = SRGRule (lhsCat r) rhs - where - alts = [((n,Nothing),mkSRGSymbols 0 ss) | CFRule c ss n <- rs] - rhs = [SRGAlt p n (srgItem sss) | ((n,p),sss) <- buildMultiMap alts ] - - mkSRGSymbols _ [] = [] - mkSRGSymbols i (NonTerminal c:ss) = NonTerminal (c,i) : mkSRGSymbols (i+1) ss - mkSRGSymbols i (Terminal t:ss) = Terminal t : mkSRGSymbols i ss - -srgLHSCat :: SRGRule -> Cat -srgLHSCat (SRGRule c _) = c - -isExternalCat :: SRG -> Cat -> Bool -isExternalCat srg c = c `Set.member` srgExternalCats srg - --- --- * Size-optimized EBNF SRGs --- - -srgItem :: [[SRGSymbol]] -> 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 :: [[SRGSymbol]] -> SRGItem -mergeItems = minimizeRE . ungroupTokens . minimizeRE . unionRE . map seqRE . map groupTokens - -groupTokens :: [SRGSymbol] -> [Symbol SRGNT [Token]] -groupTokens [] = [] -groupTokens (Terminal t:ss) = case groupTokens ss of - Terminal ts:ss' -> Terminal (t:ts):ss' - ss' -> Terminal [t]:ss' -groupTokens (NonTerminal c:ss) = NonTerminal c : groupTokens ss - -ungroupTokens :: RE (Symbol SRGNT [Token]) -> RE SRGSymbol -ungroupTokens = joinRE . mapRE (symbol (RESymbol . NonTerminal) (REConcat . map (RESymbol . Terminal))) - --- --- * Utilities for building and printing SRGs --- - -prSRG :: Options -> SRG -> String -prSRG opts srg = prProductions $ map prRule $ ext ++ int - where - sisr = flag optSISR opts - (ext,int) = partition (isExternalCat srg . srgLHSCat) (srgRules srg) - prRule (SRGRule c alts) = (c,unwords (intersperse "|" (concatMap prAlt alts))) - prAlt (SRGAlt _ t rhs) = - -- FIXME: hack: we high-jack the --sisr flag to add - -- a simple lambda calculus format for semantic interpretation - -- Maybe the --sisr flag should be renamed. - case sisr of - Just _ -> - -- copy tags to each part of a top-level union, - -- to get simpler output - case rhs of - REUnion xs -> map prOneAlt xs - _ -> [prOneAlt rhs] - where prOneAlt a = prRE prSym a ++ " { " ++ prCFTerm t ++ " }" - Nothing -> [prRE prSym rhs] - prSym = symbol fst (\t -> "\""++ t ++"\"") - -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) diff --git a/src/GF/Speech/SRGS_ABNF.hs b/src/GF/Speech/SRGS_ABNF.hs deleted file mode 100644 index 2df1316a8..000000000 --- a/src/GF/Speech/SRGS_ABNF.hs +++ /dev/null @@ -1,127 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PrJSRGS_ABNF --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/01 20:09:04 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.16 $ --- --- This module prints a CFG as a JSGF grammar. --- --- FIXME: remove \/ warn \/ fail if there are int \/ string literal --- categories in the grammar --- --- FIXME: convert to UTF-8 ------------------------------------------------------------------------------ - -module GF.Speech.SRGS_ABNF (srgsAbnfPrinter, srgsAbnfNonRecursivePrinter) where - -import GF.Data.Utilities -import GF.Infra.Option -import GF.Speech.CFG -import GF.Speech.SISR as SISR -import GF.Speech.SRG -import GF.Speech.RegExp -import PGF (PGF, CId) - -import Data.Char -import Data.List -import Data.Maybe -import Text.PrettyPrint.HughesPJ -import Debug.Trace - -width :: Int -width = 75 - -srgsAbnfPrinter :: Options - -> PGF -> CId -> String -srgsAbnfPrinter opts pgf cnc = showDoc $ prABNF sisr $ makeNonLeftRecursiveSRG opts pgf cnc - where sisr = flag optSISR opts - -srgsAbnfNonRecursivePrinter :: Options -> PGF -> CId -> String -srgsAbnfNonRecursivePrinter opts pgf cnc = showDoc $ prABNF Nothing $ makeNonRecursiveSRG opts pgf cnc - -showDoc = renderStyle (style { lineLength = width }) - -prABNF :: Maybe SISRFormat -> SRG -> Doc -prABNF sisr srg - = header $++$ foldr ($++$) empty (map prRule (srgRules srg)) - where - header = text "#ABNF 1.0 UTF-8;" $$ - meta "description" ("Speech recognition grammar for " ++ srgName srg) $$ - meta "generator" "Grammatical Framework" $$ - language $$ tagFormat $$ mainCat - language = maybe empty (\l -> text "language" <+> text l <> char ';') (srgLanguage srg) - tagFormat | isJust sisr = text "tag-format" <+> text "" <> char ';' - | otherwise = empty - mainCat = text "root" <+> prCat (srgStartCat srg) <> char ';' - prRule (SRGRule cat alts) = rule (isExternalCat srg cat) cat (map prAlt alts) - 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 - -prCat :: Cat -> 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 -> SRGSymbol -> Doc -prSymbol sisr cn (NonTerminal n@(c,_)) = prCat c <+> tag sisr (catSISR cn n) -prSymbol _ cn (Terminal t) - | all isPunct t = empty -- removes punctuation - | otherwise = text 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 -> Cat -> [Doc] -> Doc -rule pub c xs = p <+> prCat c <+> char '=' <+> nest 2 (alts xs) <+> char ';' - where p = if pub then text "public" else empty - -meta :: String -> String -> Doc -meta n v = text "meta" <+> text (show n) <+> text "is" <+> text (show v) <> char ';' - --- Pretty-printing utilities - -emptyLine :: Doc -emptyLine = text "" - -prepunctuate :: Doc -> [Doc] -> [Doc] -prepunctuate _ [] = [] -prepunctuate p (x:xs) = x : map (p <>) xs - -($++$) :: Doc -> Doc -> Doc -x $++$ y = x $$ emptyLine $$ y - diff --git a/src/GF/Speech/SRGS_XML.hs b/src/GF/Speech/SRGS_XML.hs deleted file mode 100644 index 1f94de66d..000000000 --- a/src/GF/Speech/SRGS_XML.hs +++ /dev/null @@ -1,105 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Speech.SRGS_XML --- --- Prints an SRGS XML speech recognition grammars. ----------------------------------------------------------------------- -module GF.Speech.SRGS_XML (srgsXmlPrinter, srgsXmlNonRecursivePrinter) where - -import GF.Data.Utilities -import GF.Data.XML -import GF.Infra.Option -import GF.Speech.CFG -import GF.Speech.RegExp -import GF.Speech.SISR as SISR -import GF.Speech.SRG -import PGF (PGF, CId) - -import Control.Monad -import Data.Char (toUpper,toLower) -import Data.List -import Data.Maybe -import qualified Data.Map as Map - -srgsXmlPrinter :: Options - -> PGF -> CId -> String -srgsXmlPrinter opts pgf cnc = prSrgsXml sisr $ makeNonLeftRecursiveSRG opts pgf cnc - where sisr = flag optSISR opts - -srgsXmlNonRecursivePrinter :: Options -> PGF -> CId -> String -srgsXmlNonRecursivePrinter opts pgf cnc = prSrgsXml Nothing $ makeNonRecursiveSRG opts pgf cnc - - -prSrgsXml :: Maybe SISRFormat -> SRG -> String -prSrgsXml sisr srg = showXMLDoc (optimizeSRGS xmlGr) - where - xmlGr = grammar sisr (srgStartCat srg) (srgLanguage srg) $ - [meta "description" - ("SRGS XML speech recognition grammar for " ++ srgName srg ++ "."), - meta "generator" "Grammatical Framework"] - ++ map ruleToXML (srgRules srg) - ruleToXML (SRGRule cat alts) = Tag "rule" ([("id",cat)]++pub) (prRhs alts) - where pub = if isExternalCat srg cat then [("scope","public")] else [] - prRhs rhss = [oneOf (map (mkProd sisr) rhss)] - -mkProd :: Maybe SISRFormat -> SRGAlt -> XML -mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf) - where x = mkItem sisr n rhs - 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 - -symItem :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> XML -symItem sisr cn (NonTerminal n@(c,_)) = - Tag "item" [] $ [ETag "ruleref" [("uri","#" ++ c)]] ++ tag sisr (catSISR cn n) -symItem _ _ (Terminal 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)]] - -showToken :: Token -> String -showToken t = t - -oneOf :: [XML] -> XML -oneOf = Tag "one-of" [] - -grammar :: Maybe SISRFormat - -> String -- ^ root - -> Maybe String -- ^language - -> [XML] -> XML -grammar sisr root ml = - Tag "grammar" $ [("xmlns","http://www.w3.org/2001/06/grammar"), - ("version","1.0"), - ("mode","voice"), - ("root",root)] - ++ (if isJust sisr then [("tag-format","semantics/1.0")] else []) - ++ maybe [] (\l -> [("xml:lang", l)]) ml - -meta :: String -> String -> XML -meta n c = ETag "meta" [("name",n),("content",c)] - -optimizeSRGS :: XML -> XML -optimizeSRGS = bottomUpXML f - where f (Tag "item" [] [x@(Tag "item" _ _)]) = x - f (Tag "item" [] [x@(Tag "one-of" _ _)]) = x - f (Tag "item" as [Tag "item" [] xs]) = Tag "item" as xs - f (Tag "item" as xs) = Tag "item" as (map g xs) - where g (Tag "item" [] [x@(ETag "ruleref" _)]) = x - g x = x - f (Tag "one-of" [] [x]) = x - f x = x diff --git a/src/GF/Speech/VoiceXML.hs b/src/GF/Speech/VoiceXML.hs deleted file mode 100644 index 134964062..000000000 --- a/src/GF/Speech/VoiceXML.hs +++ /dev/null @@ -1,243 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Speech.VoiceXML --- --- Creates VoiceXML dialogue systems from PGF grammars. ------------------------------------------------------------------------------ -module GF.Speech.VoiceXML (grammar2vxml) where - -import GF.Data.Operations -import GF.Data.Str (sstrV) -import GF.Data.Utilities -import GF.Data.XML -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Speech.SRG (getSpeechLanguage) -import PGF.CId -import PGF.Data -import PGF.Macros -import PGF.Linearize (realize) - -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 :: PGF -> CId -> String -grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name language start skel qs) "" - where skel = pgfSkeleton pgf - name = showCId cnc - qs = catQuestions pgf cnc (map fst skel) - language = getSpeechLanguage pgf cnc - start = lookStartCat pgf - --- --- * VSkeleton: a simple description of the abstract syntax. --- - -type Skeleton = [(CId, [(CId, [CId])])] - -pgfSkeleton :: PGF -> Skeleton -pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType pgf f))) | f <- fs]) - | (c,fs) <- Map.toList (catfuns (abstract pgf)), - not (isLiteralCat c)] - --- --- * Questions to ask --- - -type CatQuestions = [(CId,String)] - -catQuestions :: PGF -> CId -> [CId] -> CatQuestions -catQuestions pgf cnc cats = [(c,catQuestion pgf cnc c) | c <- cats] - -catQuestion :: PGF -> CId -> CId -> String -catQuestion pgf cnc cat = realize (lookPrintName pgf cnc cat) - - -{- -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 :: CId -> CatQuestions -> String -getCatQuestion c qs = - fromMaybe (error "No question for category " ++ showCId c) (lookup c qs) - --- --- * Generate VoiceXML --- - -skel2vxml :: String -> Maybe String -> CId -> Skeleton -> 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 -> CId -> [(CId, [CId])] -> [XML] -catForms gr qs cat fs = - comments [showCId cat ++ " category."] - ++ [cat2form gr qs cat fs] - -cat2form :: String -> CatQuestions -> CId -> [(CId, [CId])] -> 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 -> CId -> CId -> [CId] -> [XML] -fun2sub gr cat fun args = - comments [showCId fun ++ " : (" - ++ concat (intersperse ", " (map showCId args)) - ++ ") " ++ showCId cat] ++ ss - where - ss = zipWith mkSub [0..] args - mkSub n t = subdialog s [("src","#"++catFormId t), - ("cond","term.name == "++string (showCId fun))] - [param "old" v, - filled [] [assign v (s++".term")]] - where s = showCId fun ++ "_" ++ show n - v = "term.args["++show n++"]" - -catFormId :: CId -> String -catFormId c = showCId 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 :: (CId, [(CId, [CId])]) -> Bool -isListCat (cat,rules) = "List" `isPrefixOf` showIdent cat && length rules == 2 - && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs - where c = drop 4 (showIdent cat) - fs = map (showIdent . fst) rules - -isBaseFun :: CId -> Bool -isBaseFun f = "Base" `isPrefixOf` showIdent f - -isConsFun :: CId -> Bool -isConsFun f = "Cons" `isPrefixOf` showIdent f - -baseSize :: (CId, [(CId, [CId])]) -> Int -baseSize (_,rules) = length bs - where Just (_,bs) = find (isBaseFun . fst) rules --} diff --git a/src/GF/System/NoReadline.hs b/src/GF/System/NoReadline.hs deleted file mode 100644 index 1f1050e8c..000000000 --- a/src/GF/System/NoReadline.hs +++ /dev/null @@ -1,33 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.System.NoReadline --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/10 15:04:01 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.1 $ --- --- Do not use readline. ------------------------------------------------------------------------------ - -module GF.System.NoReadline (fetchCommand, setCompletionFunction, filenameCompletionFunction) 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 - -setCompletionFunction :: Maybe (String -> String -> Int -> IO [String]) -> IO () -setCompletionFunction _ = return () - -filenameCompletionFunction :: String -> IO [String] -filenameCompletionFunction _ = return [] diff --git a/src/GF/System/NoSignal.hs b/src/GF/System/NoSignal.hs deleted file mode 100644 index 5d82a431e..000000000 --- a/src/GF/System/NoSignal.hs +++ /dev/null @@ -1,29 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.System.NoSignal --- Maintainer : Bjorn Bringert --- Stability : (stability) --- Portability : (portability) --- --- > CVS $Date: 2005/11/11 11:12:50 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.1 $ --- --- Dummy implementation of signal handling. ------------------------------------------------------------------------------ - -module GF.System.NoSignal where - -import Control.Exception (Exception,catch) -import Prelude hiding (catch) - -{-# NOINLINE runInterruptibly #-} -runInterruptibly :: IO a -> IO (Either Exception a) ---runInterruptibly = fmap Right -runInterruptibly a = - p `catch` h - where p = a >>= \x -> return $! Right $! x - h e = return $ Left e - -blockInterrupt :: IO a -> IO a -blockInterrupt = id diff --git a/src/GF/System/Readline.hs b/src/GF/System/Readline.hs deleted file mode 100644 index ee38cdc0b..000000000 --- a/src/GF/System/Readline.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# OPTIONS -cpp #-} - ----------------------------------------------------------------------- --- | --- Module : GF.System.Readline --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/10 15:04:01 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ --- --- Uses the right readline library to read user input. ------------------------------------------------------------------------------ - -module GF.System.Readline (fetchCommand, setCompletionFunction, filenameCompletionFunction) where - -#ifdef USE_HASKELINE - -import GF.System.UseHaskeline - -#elif USE_READLINE - -import GF.System.UseReadline - -#elif USE_EDITLINE - -import GF.System.UseEditline - -#else - -import GF.System.NoReadline - -#endif diff --git a/src/GF/System/Signal.hs b/src/GF/System/Signal.hs deleted file mode 100644 index fe8a12483..000000000 --- a/src/GF/System/Signal.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# OPTIONS -cpp #-} - ----------------------------------------------------------------------- --- | --- Module : GF.System.Signal --- Maintainer : Bjorn Bringert --- Stability : (stability) --- Portability : (portability) --- --- > CVS $Date: 2005/11/11 11:12:50 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.3 $ --- --- Import the right singal handling module. ------------------------------------------------------------------------------ - -module GF.System.Signal (runInterruptibly,blockInterrupt) where - -#ifdef USE_INTERRUPT - -import GF.System.UseSignal (runInterruptibly,blockInterrupt) - -#else - -import GF.System.NoSignal (runInterruptibly,blockInterrupt) - -#endif diff --git a/src/GF/System/UseEditline.hs b/src/GF/System/UseEditline.hs deleted file mode 100644 index 6d51a1be3..000000000 --- a/src/GF/System/UseEditline.hs +++ /dev/null @@ -1,36 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.System.UseReadline --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/10 15:04:01 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.1 $ --- --- Use GNU readline ------------------------------------------------------------------------------ - -module GF.System.UseEditline (fetchCommand, setCompletionFunction, filenameCompletionFunction) where - -import System.Console.Editline.Readline - -fetchCommand :: String -> IO (String) -fetchCommand s = do - setCompletionAppendCharacter Nothing - --setBasicQuoteCharacters "" - res <- readline s - case res of - Nothing -> return "q" - Just s -> do addHistory s - return s - -setCompletionFunction :: Maybe (String -> String -> Int -> IO [String]) -> IO () -setCompletionFunction Nothing = setCompletionEntryFunction Nothing -setCompletionFunction (Just fn) = setCompletionEntryFunction (Just my_fn) - where - my_fn prefix = do - s <- getLineBuffer - p <- getPoint - fn s prefix p diff --git a/src/GF/System/UseHaskeline.hs b/src/GF/System/UseHaskeline.hs deleted file mode 100644 index 140407439..000000000 --- a/src/GF/System/UseHaskeline.hs +++ /dev/null @@ -1,43 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.System.UseReadline --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/10 15:04:01 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.1 $ --- --- Use GNU readline ------------------------------------------------------------------------------ - -module GF.System.UseHaskeline (fetchCommand, setCompletionFunction, filenameCompletionFunction) where - -import System.Console.Haskeline -import System.Directory - -fetchCommand :: String -> IO (String) -fetchCommand s = do - settings <- getGFSettings - res <- runInputT settings (getInputLine s) - case res of - Nothing -> return "q" - Just s -> return s - -getGFSettings :: IO (Settings IO) -getGFSettings = do - path <- getAppUserDataDirectory "gf_history" - return $ - Settings { - complete = completeFilename, - historyFile = Just path, - autoAddHistory = True - } - - -setCompletionFunction :: Maybe (String -> String -> Int -> IO [String]) -> IO () -setCompletionFunction _ = return () - -filenameCompletionFunction :: String -> IO [String] -filenameCompletionFunction _ = return [] diff --git a/src/GF/System/UseReadline.hs b/src/GF/System/UseReadline.hs deleted file mode 100644 index a0e051601..000000000 --- a/src/GF/System/UseReadline.hs +++ /dev/null @@ -1,36 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.System.UseReadline --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/10 15:04:01 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.1 $ --- --- Use GNU readline ------------------------------------------------------------------------------ - -module GF.System.UseReadline (fetchCommand, setCompletionFunction, filenameCompletionFunction) where - -import System.Console.Readline - -fetchCommand :: String -> IO (String) -fetchCommand s = do - setCompletionAppendCharacter Nothing - setBasicQuoteCharacters "" - res <- readline s - case res of - Nothing -> return "q" - Just s -> do addHistory s - return s - -setCompletionFunction :: Maybe (String -> String -> Int -> IO [String]) -> IO () -setCompletionFunction Nothing = setCompletionEntryFunction Nothing -setCompletionFunction (Just fn) = setCompletionEntryFunction (Just my_fn) - where - my_fn prefix = do - s <- getLineBuffer - p <- getPoint - fn s prefix p diff --git a/src/GF/System/UseSignal.hs b/src/GF/System/UseSignal.hs deleted file mode 100644 index 20c70a568..000000000 --- a/src/GF/System/UseSignal.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# OPTIONS -cpp #-} ----------------------------------------------------------------------- --- | --- 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 (SomeException,catch) -import Prelude hiding (catch) -import System.IO - -#ifdef mingw32_HOST_OS -import GHC.ConsoleHandler - -myInstallHandler handler = installHandler handler -myCatch = Catch . const -myIgnore = Ignore -#else -import System.Posix.Signals - -myInstallHandler handler = installHandler sigINT handler Nothing -myCatch = Catch -myIgnore = Ignore -#endif - -{-# 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 SomeException a) -runInterruptibly a = - do t <- myThreadId - oldH <- myInstallHandler (myCatch (killThread t)) - x <- p `catch` h - myInstallHandler oldH - 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 <- myInstallHandler myIgnore - x <- a - myInstallHandler oldH - return x diff --git a/src/GF/Text/CP1250.hs b/src/GF/Text/CP1250.hs deleted file mode 100644 index 474c04ace..000000000 --- a/src/GF/Text/CP1250.hs +++ /dev/null @@ -1,77 +0,0 @@ -module GF.Text.CP1250 where - -import Data.Char - -decodeCP1250 = map convert where - convert c - | c == '\x80' = chr 0x20AC - | c == '\x82' = chr 0x201A - | c == '\x84' = chr 0x201E - | c == '\x85' = chr 0x2026 - | c == '\x86' = chr 0x2020 - | c == '\x87' = chr 0x2021 - | c == '\x89' = chr 0x2030 - | c == '\x8A' = chr 0x0160 - | c == '\x8B' = chr 0x2039 - | c == '\x8C' = chr 0x015A - | c == '\x8D' = chr 0x0164 - | c == '\x8E' = chr 0x017D - | c == '\x8F' = chr 0x0179 - | c == '\x91' = chr 0x2018 - | c == '\x92' = chr 0x2019 - | c == '\x93' = chr 0x201C - | c == '\x94' = chr 0x201D - | c == '\x95' = chr 0x2022 - | c == '\x96' = chr 0x2013 - | c == '\x97' = chr 0x2014 - | c == '\x99' = chr 0x2122 - | c == '\x9A' = chr 0x0161 - | c == '\x9B' = chr 0x203A - | c == '\x9C' = chr 0x015B - | c == '\x9D' = chr 0x0165 - | c == '\x9E' = chr 0x017E - | c == '\x9F' = chr 0x017A - | c == '\xA1' = chr 0x02C7 - | c == '\xA5' = chr 0x0104 - | c == '\xB9' = chr 0x0105 - | c == '\xBC' = chr 0x013D - | c == '\xBE' = chr 0x013E - | otherwise = c - - -encodeCP1250 = map convert where - convert c - | oc == 0x20AC = '\x80' - | oc == 0x201A = '\x82' - | oc == 0x201E = '\x84' - | oc == 0x2026 = '\x85' - | oc == 0x2020 = '\x86' - | oc == 0x2021 = '\x87' - | oc == 0x2030 = '\x89' - | oc == 0x0160 = '\x8A' - | oc == 0x2039 = '\x8B' - | oc == 0x015A = '\x8C' - | oc == 0x0164 = '\x8D' - | oc == 0x017D = '\x8E' - | oc == 0x0179 = '\x8F' - | oc == 0x2018 = '\x91' - | oc == 0x2019 = '\x92' - | oc == 0x201C = '\x93' - | oc == 0x201D = '\x94' - | oc == 0x2022 = '\x95' - | oc == 0x2013 = '\x96' - | oc == 0x2014 = '\x97' - | oc == 0x2122 = '\x99' - | oc == 0x0161 = '\x9A' - | oc == 0x203A = '\x9B' - | oc == 0x015B = '\x9C' - | oc == 0x0165 = '\x9D' - | oc == 0x017E = '\x9E' - | oc == 0x017A = '\x9F' - | oc == 0x02C7 = '\xA1' - | oc == 0x0104 = '\xA5' - | oc == 0x0105 = '\xB9' - | oc == 0x013D = '\xBC' - | oc == 0x013E = '\xBE' - | otherwise = c - where oc = ord c diff --git a/src/GF/Text/CP1251.hs b/src/GF/Text/CP1251.hs deleted file mode 100644 index 7c277abab..000000000 --- a/src/GF/Text/CP1251.hs +++ /dev/null @@ -1,74 +0,0 @@ -module GF.Text.CP1251 where - -import Data.Char - -decodeCP1251 = map convert where - convert c - | c >= '\xC0' && c <= '\xFF' = chr (ord c + (0x410-0xC0)) - | c == '\xA8' = chr 0x401 -- cyrillic capital letter lo - | c == '\x80' = chr 0x402 - | c == '\x81' = chr 0x403 - | c == '\xAA' = chr 0x404 - | c == '\xBD' = chr 0x405 - | c == '\xB2' = chr 0x406 - | c == '\xAF' = chr 0x407 - | c == '\xA3' = chr 0x408 - | c == '\x8A' = chr 0x409 - | c == '\x8C' = chr 0x40A - | c == '\x8E' = chr 0x40B - | c == '\x8D' = chr 0x40C - | c == '\xA1' = chr 0x40E - | c == '\x8F' = chr 0x40F - | c == '\xB8' = chr 0x451 -- cyrillic small letter lo - | c == '\x90' = chr 0x452 - | c == '\x83' = chr 0x453 - | c == '\xBA' = chr 0x454 - | c == '\xBE' = chr 0x455 - | c == '\xB3' = chr 0x456 - | c == '\xBF' = chr 0x457 - | c == '\xBC' = chr 0x458 - | c == '\x9A' = chr 0x459 - | c == '\x9C' = chr 0x45A - | c == '\x9E' = chr 0x45B - | c == '\x9D' = chr 0x45C - | c == '\xA2' = chr 0x45E - | c == '\x9F' = chr 0x45F - | c == '\xA5' = chr 0x490 - | c == '\xB4' = chr 0x491 - | otherwise = c - -encodeCP1251 = map convert where - convert c - | oc >= 0x410 && oc <= 0x44F = chr (oc - (0x410-0xC0)) - | oc == 0x401 = '\xA8' -- cyrillic capital letter lo - | oc == 0x402 = '\x80' - | oc == 0x403 = '\x81' - | oc == 0x404 = '\xAA' - | oc == 0x405 = '\xBD' - | oc == 0x406 = '\xB2' - | oc == 0x407 = '\xAF' - | oc == 0x408 = '\xA3' - | oc == 0x409 = '\x8A' - | oc == 0x40A = '\x8C' - | oc == 0x40B = '\x8E' - | oc == 0x40C = '\x8D' - | oc == 0x40E = '\xA1' - | oc == 0x40F = '\x8F' - | oc == 0x451 = '\xB8' -- cyrillic small letter lo - | oc == 0x452 = '\x90' - | oc == 0x453 = '\x83' - | oc == 0x454 = '\xBA' - | oc == 0x455 = '\xBE' - | oc == 0x456 = '\xB3' - | oc == 0x457 = '\xBF' - | oc == 0x458 = '\xBC' - | oc == 0x459 = '\x9A' - | oc == 0x45A = '\x9C' - | oc == 0x45B = '\x9E' - | oc == 0x45C = '\x9D' - | oc == 0x45E = '\xA2' - | oc == 0x45F = '\x9F' - | oc == 0x490 = '\xA5' - | oc == 0x491 = '\xB4' - | otherwise = c - where oc = ord c diff --git a/src/GF/Text/CP1252.hs b/src/GF/Text/CP1252.hs deleted file mode 100644 index 1e5affe53..000000000 --- a/src/GF/Text/CP1252.hs +++ /dev/null @@ -1,6 +0,0 @@ -module GF.Text.CP1252 where - -import Data.Char - -decodeCP1252 = map id -encodeCP1252 = map (\x -> if x <= '\255' then x else '?') diff --git a/src/GF/Text/Coding.hs b/src/GF/Text/Coding.hs deleted file mode 100644 index e3cd7b0ea..000000000 --- a/src/GF/Text/Coding.hs +++ /dev/null @@ -1,21 +0,0 @@ -module GF.Text.Coding where - -import GF.Infra.Option -import GF.Text.UTF8 -import GF.Text.CP1250 -import GF.Text.CP1251 -import GF.Text.CP1252 - -encodeUnicode e = case e of - UTF_8 -> encodeUTF8 - CP_1250 -> encodeCP1250 - CP_1251 -> encodeCP1251 - CP_1252 -> encodeCP1252 - _ -> id - -decodeUnicode e = case e of - UTF_8 -> decodeUTF8 - CP_1250 -> decodeCP1250 - CP_1251 -> decodeCP1251 - CP_1252 -> decodeCP1252 - _ -> id diff --git a/src/GF/Text/Lexing.hs b/src/GF/Text/Lexing.hs deleted file mode 100644 index 3300d311e..000000000 --- a/src/GF/Text/Lexing.hs +++ /dev/null @@ -1,131 +0,0 @@ -module GF.Text.Lexing (stringOp,opInEnv) where - -import GF.Text.Transliterations -import GF.Text.UTF8 -import GF.Text.CP1251 - -import Data.Char -import Data.List (intersperse) - --- lexers and unlexers - they work on space-separated word strings - -stringOp :: String -> Maybe (String -> String) -stringOp name = case name of - "chars" -> Just $ appLexer (filter (not . all isSpace) . map return) - "lextext" -> Just $ appLexer lexText - "lexcode" -> Just $ appLexer lexCode - "lexmixed" -> Just $ appLexer lexMixed - "words" -> Just $ appLexer words - "bind" -> Just $ appUnlexer bindTok - "unchars" -> Just $ appUnlexer concat - "unlextext" -> Just $ appUnlexer unlexText - "unlexcode" -> Just $ appUnlexer unlexCode - "unlexmixed" -> Just $ appUnlexer unlexMixed - "unwords" -> Just $ appUnlexer unwords - "to_html" -> Just wrapHTML - "to_utf8" -> Just encodeUTF8 - "from_utf8" -> Just decodeUTF8 - "to_cp1251" -> Just encodeCP1251 - "from_cp1251" -> Just decodeCP1251 - _ -> transliterate name - --- perform op in environments beg--end, t.ex. between "--" ---- suboptimal implementation -opInEnv :: String -> String -> (String -> String) -> (String -> String) -opInEnv beg end op = concat . altern False . chop (lbeg, beg) [] where - chop mk@(lg, mark) s0 s = - let (tag,rest) = splitAt lg s in - if tag==mark then (reverse s0) : mark : chop (switch mk) [] rest - else case s of - c:cs -> chop mk (c:s0) cs - [] -> [reverse s0] - switch (lg,mark) = if mark==beg then (lend,end) else (lbeg,beg) - (lbeg,lend) = (length beg, length end) - altern m ts = case ts of - t:ws | not m && t==beg -> t : altern True ws - t:ws | m && t==end -> t : altern False ws - t:ws -> (if m then op t else t) : altern m ws - [] -> [] - -appLexer :: (String -> [String]) -> String -> String -appLexer f = unwords . filter (not . null) . f - -appUnlexer :: ([String] -> String) -> String -> String -appUnlexer f = unlines . map (f . words) . lines - -wrapHTML :: String -> String -wrapHTML = unlines . tag . intersperse "
" . lines where - tag ss = "":"":"":"":"" : ss ++ ["",""] - -lexText :: String -> [String] -lexText = uncap . lext where - lext s = case s of - c:cs | isMajorPunct c -> [c] : uncap (lext cs) - c:cs | isMinorPunct c -> [c] : lext cs - c:cs | isSpace c -> lext cs - _:_ -> let (w,cs) = break (\x -> isSpace x || isPunct x) s in w : lext cs - _ -> [s] - uncap s = case s of - (c:cs):ws -> (toLower c : cs):ws - _ -> s - --- | Haskell lexer, usable for much code -lexCode :: String -> [String] -lexCode ss = case lex ss of - [(w@(_:_),ws)] -> w : lexCode ws - _ -> [] - --- | LaTeX style lexer, with "math" environment using Code between $...$ -lexMixed :: String -> [String] -lexMixed = concat . alternate False where - alternate env s = case s of - _:_ -> case break (=='$') s of - (t,[]) -> lex env t : [] - (t,c:m) -> lex env t : [[c]] : alternate (not env) m - _ -> [] - lex env = if env then lexCode else lexText - -bindTok :: [String] -> String -bindTok ws = case ws of - w:"&+":ws2 -> w ++ bindTok ws2 - w:[] -> w - w:ws2 -> w ++ " " ++ bindTok ws2 - [] -> "" - -unlexText :: [String] -> String -unlexText = cap . unlext where - unlext s = case s of - w:[] -> w - w:[c]:[] | isPunct c -> w ++ [c] - w:[c]:cs | isMajorPunct c -> w ++ [c] ++ " " ++ cap (unlext cs) - w:[c]:cs | isMinorPunct c -> w ++ [c] ++ " " ++ unlext cs - w:ws -> w ++ " " ++ unlext ws - _ -> [] - cap s = case s of - c:cs -> toUpper c : cs - _ -> s - -unlexCode :: [String] -> String -unlexCode s = case s of - w:[] -> w - [c]:cs | isParen c -> [c] ++ unlexCode cs - w:cs@([c]:_) | isClosing c -> w ++ unlexCode cs - w:ws -> w ++ " " ++ unlexCode ws - _ -> [] - - -unlexMixed :: [String] -> String -unlexMixed = concat . alternate False where - alternate env s = case s of - _:_ -> case break (=="$") s of - (t,[]) -> unlex env t : [] - (t,c:m) -> unlex env t : sep env c : alternate (not env) m - _ -> [] - unlex env = if env then unlexCode else unlexText - sep env c = if env then c ++ " " else " " ++ c - -isPunct = flip elem ".?!,:;" -isMajorPunct = flip elem ".?!" -isMinorPunct = flip elem ",:;" -isParen = flip elem "()[]{}" -isClosing = flip elem ")]}" diff --git a/src/GF/Text/Transliterations.hs b/src/GF/Text/Transliterations.hs deleted file mode 100644 index e2747f506..000000000 --- a/src/GF/Text/Transliterations.hs +++ /dev/null @@ -1,206 +0,0 @@ -module GF.Text.Transliterations ( - transliterate, - transliteration, - characterTable, - transliterationPrintNames - ) where - -import GF.Text.UTF8 - -import Data.Char -import Numeric -import qualified Data.Map as Map - --- transliterations between ASCII and a Unicode character set - --- current transliterations: devanagari, thai - --- to add a new one: define the Unicode range and the corresponding ASCII strings, --- which may be one or more characters long - --- conventions to be followed: --- each character is either [letter] or [letter+nonletters] --- when using a sparse range of unicodes, mark missing codes as "-" in transliterations --- characters can be invisible: ignored in translation to unicode - -transliterate :: String -> Maybe (String -> String) -transliterate s = case s of - 'f':'r':'o':'m':'_':t -> fmap appTransFromUnicode $ transliteration t - 't':'o':'_':t -> fmap appTransToUnicode $ transliteration t - _ -> Nothing - -transliteration :: String -> Maybe Transliteration -transliteration s = Map.lookup s allTransliterations - -allTransliterations = Map.fromAscList [ - ("ancientgreek", transAncientGreek), - ("arabic", transArabic), - ("devanagari", transDevanagari), - ("greek", transGreek), - ("hebrew", transHebrew), - ("persian", transPersian), - ("telugu", transTelugu), - ("thai", transThai) - ---- "urdu", transUrdu - ] - --- used in command options and help -transliterationPrintNames = [(t,printname p) | (t,p) <- Map.toList allTransliterations] - -characterTable :: Transliteration -> String -characterTable = unlines . map prOne . Map.assocs . trans_from_unicode where - prOne (i,s) = unwords ["|", showHex i "", "|", [toEnum i], "|", s, "|"] - -data Transliteration = Trans { - trans_to_unicode :: Map.Map String Int, - trans_from_unicode :: Map.Map Int String, - invisible_chars :: [String], - printname :: String - } - -appTransToUnicode :: Transliteration -> String -> String -appTransToUnicode trans = - concat . - map (\c -> maybe c (return . toEnum) $ - Map.lookup c (trans_to_unicode trans) - ) . - filter (flip notElem (invisible_chars trans)) . - unchar - -appTransFromUnicode :: Transliteration -> String -> String -appTransFromUnicode trans = - concat . - map (maybe "?" id . - flip Map.lookup (trans_from_unicode trans) - ) . - map fromEnum - - -mkTransliteration :: String -> [String] -> [Int] -> Transliteration -mkTransliteration name ts us = - Trans (Map.fromList (tzip ts us)) (Map.fromList (uzip us ts)) [] name - where - tzip ts us = [(t,u) | (t,u) <- zip ts us, t /= "-"] - uzip us ts = [(u,t) | (u,t) <- zip us ts, t /= "-"] - - -unchar :: String -> [String] -unchar s = case s of - c:d:cs - | isAlpha d -> [c] : unchar (d:cs) - | isSpace d -> [c]:[d]: unchar cs - | otherwise -> let (ds,cs2) = break (\x -> isAlpha x || isSpace x) cs in - (c:d:ds) : unchar cs2 - [_] -> [s] - _ -> [] - -transThai :: Transliteration -transThai = mkTransliteration "Thai" allTrans allCodes where - allTrans = 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 - - - - - - " - allCodes = [0x0e00 .. 0x0e7f] - -transDevanagari :: Transliteration -transDevanagari = - (mkTransliteration "Devanagari" - allTransUrduHindi allCodes){invisible_chars = ["a"]} where - allCodes = [0x0900 .. 0x095f] - -allTransUrduHindi = words $ - "- M N - - a- A- i- I- u- U- R- - - - e- " ++ - "E- - - o- O- k K g G N: c C j J n: t. " ++ - "T. d. D. n. t T d D n - p P b B m y " ++ - "r - l - - v S s. s h - - r: - A i " ++ - "I u U R - - - e E o O - - - - - " ++ - "- - - - - - - - - - - z r. - - - " - -transUrdu :: Transliteration -transUrdu = - (mkTransliteration "Urdu" allTransUrduHindi allCodes){invisible_chars = ["a"]} where - allCodes = [0x0900 .. 0x095f] ---- TODO: this is devanagari - -transArabic :: Transliteration -transArabic = mkTransliteration "Arabic" allTrans allCodes where - allTrans = words $ - " V A: A? w? A- y? A b t. t v g H K d " ++ -- 0621 - 062f - "W r z s C S D T Z c G " ++ -- 0630 - 063a - " f q k l m n h w y. y a. u. i. a u " ++ -- 0641 - 064f - "i v2 o a: V+ V- i: a+ " ++ -- 0650 - 0657 - "A* " -- 0671 (used by AED) - allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++ - [0x0641..0x064f] ++ [0x0650..0x0657] ++ [0x0671] - -transPersian :: Transliteration -transPersian = (mkTransliteration "Persian/Farsi" allTrans allCodes) - {invisible_chars = ["a","u","i"]} where - allTrans = words $ - " V A: A? w? A- y? A b t. t t- j H K d " ++ -- 0621 - 062f - "W r z s C S D T Z c G " ++ -- 0630 - 063a - " f q k l m n h v y. y a. u. i. a u " ++ -- 0641 - 064f - "i v2 o a: V+ V- i: a+ " ++ -- 0650 - 0657 - "p c^ J g " - allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++ - [0x0641..0x064f] ++ [0x0650..0x0657] ++ - [0x067e,0x0686,0x0698,0x06af] - -transHebrew :: Transliteration -transHebrew = mkTransliteration "unvocalized Hebrew" allTrans allCodes where - allTrans = words $ - "A b g d h w z H T y K k l M m N " ++ - "n S O P p Z. Z q r s t - - - - - " ++ - "w2 w3 y2 g1 g2" - allCodes = [0x05d0..0x05f4] - -transTelugu :: Transliteration -transTelugu = mkTransliteration "Telugu" allTrans allCodes where - allTrans = words $ - "- c1 c2 c3 - A A: I I: U U: R_ L_ - E E: " ++ - "A' - O O: A_ k k. g g. n. c c. j j. n' T " ++ - "T. d d. N t t. d d. n - p p. b b. m y " ++ - "r R l L - v s' S s h - - - c5 a: i " ++ - "i: u u: r_ r. - e e: a' - o o: a_ c6 - - " ++ - "- - - - - c7 c8 z Z - - - - - - - " ++ - "R+ L+ l+ l* - - n0 n1 n2 n3 n4 n5 n6 n7 n8 n9 " - allCodes = [0x0c00 .. 0x0c7f] - -transGreek :: Transliteration -transGreek = mkTransliteration "modern Greek" allTrans allCodes where - allTrans = words $ - "- - - - - - A' - E' H' I' - O' - Y' W' " ++ - "i= A B G D E Z H V I K L M N X O " ++ - "P R - S T Y F C Q W I- Y- a' e' h' i' " ++ - "y= a b g d e z h v i k l m n x o " ++ - "p r s* s t y f c q w i- y- o' y' w' - " - allCodes = [0x0380 .. 0x03cf] - -transAncientGreek :: Transliteration -transAncientGreek = mkTransliteration "ancient Greek" allTrans allCodes where - allTrans = words $ - "- - - - - - - - - - - - - - - - " ++ - "i= A B G D E Z H V I K L M N X O " ++ - "P R - S T Y F C Q W I- Y- - - - - " ++ - "y= a b g d e z h v i k l m n x o " ++ - "p r s* s t y f c q w i- y- - - - - " ++ - "a) a( a)` a(` a)' a(' a)~ a(~ A) A( A)` A(` A)' A(' A)~ A(~ " ++ - "e) e( e)` e(` e)' e(' - - E) E( E)` E(` E)' E(' - - " ++ - "h) h( h)` h(` h)' h(' h)~ h(~ H) H( H)` H(` H)' H(' H)~ H(~ " ++ - "i) i( i)` i(` i)' i(' i)~ i(~ I) I( I)` I(` I)' I(' I)~ I(~ " ++ - "o) o( o)` o(` o)' o(' - - O) O( O)` O(` O)' O(' - - " ++ - "y) y( y)` y(` y)' y(' y)~ y(~ - Y( - Y(` - Y(' - Y(~ " ++ - "w) w( w)` w(` w)' w(' w)~ w(~ W) W( W)` W(` W)' W(' W)~ W(~ " ++ - "a` a' e` e' h` h' i` i' o` o' y` y' w` w' - - " ++ - "a|( a|) a|)` a|(` a|)' a|(' a|)~ a|(~ - - - - - - - - " ++ -- 1f80- - "h|( h|) h|)` h|(` h|)' h|(' h|)~ h|(~ - - - - - - - - " ++ -- 1f90- - "w|( w|) w|)` w|(` w|)' w|(' w|)~ w|(~ - - - - - - - - " ++ -- 1fa0- - "a. a_ a|` a| a|' - a~ a|~ - - - - - - - - " ++ -- 1fb0- - "- - h|` h| h|' - h~ h|~ - - - - - - - - " ++ -- 1fc0- - "i. i_ i=` i=' - - i~ i=~ - - - - - - - - " ++ -- 1fd0- - "y. y_ y=` y=' r) r( y~ y|~ - - - - - - - - " ++ -- 1fe0- - "- - w|` w| w|' - w~ w|~ - - - - - - - - " -- 1ff0- - allCodes = [0x0380 .. 0x03cf] ++ [0x1f00 .. 0x1fff] - diff --git a/src/GF/Text/UTF8.hs b/src/GF/Text/UTF8.hs deleted file mode 100644 index 5e9687684..000000000 --- a/src/GF/Text/UTF8.hs +++ /dev/null @@ -1,48 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : UTF8 --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:42 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- From the Char module supplied with HBC. --- code by Thomas Hallgren (Jul 10 1999) ------------------------------------------------------------------------------ - -module GF.Text.UTF8 (decodeUTF8, encodeUTF8) where - --- | Take a Unicode string and encode it as a string --- with the UTF8 method. -decodeUTF8 :: String -> String -decodeUTF8 "" = "" -decodeUTF8 (c:cs) | c < '\x80' = c : decodeUTF8 cs -decodeUTF8 (c:c':cs) | '\xc0' <= c && c <= '\xdf' && - '\x80' <= c' && c' <= '\xbf' = - toEnum ((fromEnum c `mod` 0x20) * 0x40 + fromEnum c' `mod` 0x40) : decodeUTF8 cs -decodeUTF8 (c:c':c'':cs) | '\xe0' <= c && c <= '\xef' && - '\x80' <= c' && c' <= '\xbf' && - '\x80' <= c'' && c'' <= '\xbf' = - toEnum ((fromEnum c `mod` 0x10 * 0x1000) + (fromEnum c' `mod` 0x40) * 0x40 + fromEnum c'' `mod` 0x40) : decodeUTF8 cs -decodeUTF8 s = s ---- AR workaround 22/6/2006 -----decodeUTF8 _ = error "UniChar.decodeUTF8: bad data" - -encodeUTF8 :: String -> String -encodeUTF8 "" = "" -encodeUTF8 (c:cs) = - if c > '\x0000' && c < '\x0080' then - c : encodeUTF8 cs - else if c < toEnum 0x0800 then - let i = fromEnum c - in toEnum (0xc0 + i `div` 0x40) : - toEnum (0x80 + i `mod` 0x40) : - encodeUTF8 cs - else - let i = fromEnum c - in toEnum (0xe0 + i `div` 0x1000) : - toEnum (0x80 + (i `mod` 0x1000) `div` 0x40) : - toEnum (0x80 + i `mod` 0x40) : - encodeUTF8 cs diff --git a/src/GFC.hs b/src/GFC.hs deleted file mode 100644 index 8037d4f1a..000000000 --- a/src/GFC.hs +++ /dev/null @@ -1,88 +0,0 @@ -module GFC (mainGFC) where --- module Main where - -import PGF -import PGF.CId -import PGF.Data -import GF.Compile -import GF.Compile.Export - -import GF.Grammar.CF ---- should this be on a deeper level? AR 15/10/2008 - -import GF.Infra.UseIO -import GF.Infra.Option -import GF.Data.ErrM - -import Data.Maybe -import Data.Binary -import System.FilePath -import System.IO - - -mainGFC :: Options -> [FilePath] -> IOE () -mainGFC opts fs = - case () of - _ | null fs -> fail $ "No input files." - _ | all (extensionIs ".cf") fs -> compileCFFiles opts fs - _ | all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f) fs -> compileSourceFiles opts fs - _ | all (extensionIs ".pgf") fs -> unionPGFFiles opts fs - _ -> fail $ "Don't know what to do with these input files: " ++ unwords fs - where extensionIs ext = (== ext) . takeExtension - -compileSourceFiles :: Options -> [FilePath] -> IOE () -compileSourceFiles opts fs = - do gr <- batchCompile opts fs - let cnc = justModuleName (last fs) - if flag optStopAfterPhase opts == Compile - then return () - else do pgf <- link opts cnc gr - writePGF opts pgf - writeOutputs opts pgf - -compileCFFiles :: Options -> [FilePath] -> IOE () -compileCFFiles opts fs = - do s <- ioeIO $ fmap unlines $ mapM readFile fs - let cnc = justModuleName (last fs) - gf <- ioeErr $ getCF cnc s - gr <- compileSourceGrammar opts gf - if flag optStopAfterPhase opts == Compile - then return () - else do pgf <- link opts cnc gr - writePGF opts pgf - writeOutputs opts pgf - -unionPGFFiles :: Options -> [FilePath] -> IOE () -unionPGFFiles opts fs = - do pgfs <- mapM readPGFVerbose fs - let pgf = foldl1 unionPGF pgfs - pgfFile = grammarName opts pgf <.> "pgf" - if pgfFile `elem` fs - then putStrLnE $ "Refusing to overwrite " ++ pgfFile - else writePGF opts pgf - writeOutputs opts pgf - where readPGFVerbose f = putPointE Normal opts ("Reading " ++ f ++ "...") $ ioeIO $ readPGF f - -writeOutputs :: Options -> PGF -> IOE () -writeOutputs opts pgf = do - sequence_ [writeOutput opts name str - | fmt <- flag optOutputFormats opts, - (name,str) <- exportPGF opts fmt pgf] - -writePGF :: Options -> PGF -> IOE () -writePGF opts pgf = do - let outfile = grammarName opts pgf <.> "pgf" - putPointE Normal opts ("Writing " ++ outfile ++ "...") $ ioeIO $ encodeFile outfile pgf - -grammarName :: Options -> PGF -> String -grammarName opts pgf = fromMaybe (showCId (absname pgf)) (flag optName opts) - -writeOutput :: Options -> FilePath-> String -> IOE () -writeOutput opts file str = - do let path = case flag optOutputDir opts of - Nothing -> file - Just dir -> dir file - writeOutputFile opts path str - -writeOutputFile :: Options -> FilePath -> String -> IOE () -writeOutputFile opts outfile output = - do putPointE Normal opts ("Writing " ++ outfile ++ "...") $ ioeIO $ writeFile outfile output diff --git a/src/GFI.hs b/src/GFI.hs deleted file mode 100644 index 2ea22efa6..000000000 --- a/src/GFI.hs +++ /dev/null @@ -1,363 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, CPP #-} -module GFI (mainGFI,mainRunGFI) where - -import GF.Command.Interpreter -import GF.Command.Importing -import GF.Command.Commands -import GF.Command.Abstract -import GF.Command.Parse -import GF.Data.ErrM -import GF.Grammar hiding (Ident) -import GF.Grammar.Parser (runP, pExp) -import GF.Compile.Rename -import GF.Compile.Concrete.Compute (computeConcrete) -import GF.Compile.Concrete.TypeCheck (inferLType) -import GF.Infra.Dependencies -import GF.Infra.CheckM -import GF.Infra.UseIO -import GF.Infra.Option -import GF.Infra.Modules (greatestResource) -import GF.System.Readline - -import GF.Text.Coding -import GF.Compile.Coding - -import PGF -import PGF.Data -import PGF.Macros - -import Data.Char -import Data.Maybe -import Data.List(isPrefixOf) -import qualified Data.Map as Map -import qualified Data.ByteString.Char8 as BS -import qualified Text.ParserCombinators.ReadP as RP -import System.Cmd -import System.CPUTime -import System.Directory -import Control.Exception -import Control.Monad -import Data.Version -import GF.System.Signal ---import System.IO.Error (try) -#ifdef mingw32_HOST_OS -import System.Win32.Console -import System.Win32.NLS -#endif - -import Paths_gf - -mainRunGFI :: Options -> [FilePath] -> IO () -mainRunGFI opts files = do - let opts1 = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet})) opts - gfenv <- emptyGFEnv - gfenv <- importInEnv gfenv opts1 files - loop opts1 gfenv - return () - -mainGFI :: Options -> [FilePath] -> IO () -mainGFI opts files = do - putStrLn welcome - gfenv <- emptyGFEnv - gfenv <- importInEnv gfenv opts files - loop opts gfenv - return () - -loopOptNewCPU opts gfenv' - | not (verbAtLeast opts Normal) = return gfenv' - | otherwise = do - cpu' <- getCPUTime - putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec") - return $ gfenv' {cputime = cpu'} - -loop :: Options -> GFEnv -> IO GFEnv -loop opts gfenv0 = do - let loopNewCPU = loopOptNewCPU opts - let isv = verbAtLeast opts Normal - let ifv act = if isv then act else return () - let env = commandenv gfenv0 - let sgr = sourcegrammar gfenv0 - setCompletionFunction (Just (wordCompletion gfenv0)) - let fetch = case flag optMode opts of - ModeRun -> tryGetLine - _ -> fetchCommand (prompt env) - s0 <- fetch - let gfenv = gfenv0 {history = s0 : history gfenv0} - let - enc = encode gfenv - s = decode gfenv s0 - pwords = case words s of - w:ws -> getCommandOp w :ws - ws -> ws - - -- special commands, requiring source grammar in env - - case pwords of - - "q":_ -> ifv (putStrLn "See you.") >> return gfenv - - _ -> do - r <- runInterruptibly $ case pwords of - - "!":ws -> do - system $ unwords ws - loopNewCPU gfenv - "cc":ws -> do - let - pOpts style q ("-table" :ws) = pOpts TermPrintTable q ws - pOpts style q ("-all" :ws) = pOpts TermPrintAll q ws - pOpts style q ("-default":ws) = pOpts TermPrintDefault q ws - pOpts style q ("-unqual" :ws) = pOpts style Unqualified ws - pOpts style q ("-qual" :ws) = pOpts style Qualified ws - pOpts style q ws = (style,q,unwords ws) - - (style,q,s) = pOpts TermPrintDefault Qualified (tail (words s0)) - - checkComputeTerm gr t = do - mo <- maybe (Bad "no source grammar in scope") return $ greatestResource gr - ((t,_),_) <- runCheck $ do t <- renameSourceTerm gr mo t - inferLType gr [] t - computeConcrete sgr t - - case runP pExp (BS.pack s) of - Left (_,msg) -> putStrLn msg - Right t -> case checkComputeTerm sgr (codeTerm (decode gfenv) t) of - Ok x -> putStrLn $ enc (showTerm style q x) - Bad s -> putStrLn $ enc s - loopNewCPU gfenv - "dg":ws -> do - writeFile "_gfdepgraph.dot" (depGraph sgr) - putStrLn "wrote graph in file _gfdepgraph.dot" - loopNewCPU gfenv - "i":args -> do - gfenv' <- case parseOptions args of - Ok (opts',files) -> do - curr_dir <- getCurrentDirectory - lib_dir <- getLibraryDirectory (addOptions opts opts') - importInEnv gfenv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files - Bad err -> do - putStrLn $ "Command parse error: " ++ err - return gfenv - loopNewCPU gfenv' - - -- other special commands, working on GFEnv - "e":_ -> loopNewCPU $ gfenv { - commandenv=emptyCommandEnv, sourcegrammar = emptySourceGrammar - } - - "dc":f:ws -> do - case readCommandLine (unwords ws) of - Just comm -> loopNewCPU $ gfenv { - commandenv = env { - commandmacros = Map.insert f comm (commandmacros env) - } - } - _ -> putStrLn "command definition not parsed" >> loopNewCPU gfenv - - "dt":f:ws -> do - case readExpr (unwords ws) of - Just exp -> loopNewCPU $ gfenv { - commandenv = env { - expmacros = Map.insert f exp (expmacros env) - } - } - _ -> putStrLn "value definition not parsed" >> loopNewCPU gfenv - - "ph":_ -> - mapM_ (putStrLn . enc) (reverse (history gfenv0)) >> loopNewCPU gfenv - "se":c:_ -> - case lookup c encodings of - Just cod -> do -#ifdef mingw32_HOST_OS - case c of - 'c':'p':c -> case reads c of - [(cp,"")] -> setConsoleCP cp >> setConsoleOutputCP cp - _ -> return () - "utf8" -> setConsoleCP 65001 >> setConsoleOutputCP 65001 - _ -> return () -#endif - loopNewCPU $ gfenv {coding = cod} - Nothing -> do putStrLn "unknown encoding" - loopNewCPU gfenv - - -- ordinary commands, working on CommandEnv - _ -> do - interpretCommandLine enc env s - loopNewCPU gfenv --- gfenv' <- return $ either (const gfenv) id r - gfenv' <- either (\e -> (print e >> return gfenv)) return r - loop opts gfenv' - -importInEnv :: GFEnv -> Options -> [FilePath] -> IO GFEnv -importInEnv gfenv opts files - | flag optRetainResource opts = - do src <- importSource (sourcegrammar gfenv) opts files - return $ gfenv {sourcegrammar = src} - | otherwise = - do let opts' = addOptions (setOptimization OptCSE False) opts - pgf0 = multigrammar (commandenv gfenv) - pgf1 <- importGrammar pgf0 opts' files - if (verbAtLeast opts Normal) - then putStrLnFlush $ unwords $ "\nLanguages:" : map showCId (languages pgf1) - else return () - return $ gfenv { commandenv = mkCommandEnv (coding gfenv) pgf1 } - -tryGetLine = do - res <- try getLine - case res of - Left (e :: SomeException) -> return "q" - Right l -> return l - -welcome = unlines [ - " ", - " * * * ", - " * * ", - " * * ", - " * ", - " * ", - " * * * * * * * ", - " * * * ", - " * * * * * * ", - " * * * ", - " * * * ", - " ", - "This is GF version "++showVersion version++". ", - "License: see help -license. ", - "Differences from GF 2.9: see help -changes.", - "Bug reports: http://code.google.com/p/grammatical-framework/issues/list" - ] - -prompt env - | abs == wildCId = "> " - | otherwise = showCId abs ++ "> " - where - abs = abstractName (multigrammar env) - -data GFEnv = GFEnv { - sourcegrammar :: SourceGrammar, -- gfo grammar -retain - commandenv :: CommandEnv, - history :: [String], - cputime :: Integer, - coding :: Encoding - } - -emptyGFEnv :: IO GFEnv -emptyGFEnv = do -#ifdef mingw32_HOST_OS - codepage <- getACP - let coding = fromMaybe UTF_8 (lookup ("cp"++show codepage) encodings) -#else - let coding = UTF_8 -#endif - return $ GFEnv emptySourceGrammar (mkCommandEnv coding emptyPGF) [] 0 coding - -encode = encodeUnicode . coding -decode = decodeUnicode . coding - -wordCompletion gfenv line0 prefix0 p = - case wc_type (take p line) of - CmplCmd pref - -> ret ' ' [name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name] - CmplStr (Just (Command _ opts _)) s - -> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optType opts))) - case mb_state0 of - Right state0 -> let ws = words (take (length s - length prefix) s) - in case loop state0 ws of - Nothing -> ret ' ' [] - Just state -> let compls = getCompletions state prefix - in ret ' ' (map (encode gfenv) (Map.keys compls)) - Left (_ :: SomeException) -> ret ' ' [] - CmplOpt (Just (Command n _ _)) pref - -> case Map.lookup n (commands cmdEnv) of - Just inf -> do let flg_compls = ['-':flg | (flg,_) <- flags inf, isPrefixOf pref flg] - opt_compls = ['-':opt | (opt,_) <- options inf, isPrefixOf pref opt] - ret (if null flg_compls then ' ' else '=') - (flg_compls++opt_compls) - Nothing -> ret ' ' [] - CmplIdent (Just (Command "i" _ _)) _ -- HACK: file name completion for command i - -> filenameCompletionFunction prefix - CmplIdent _ pref - -> do mb_abs <- try (evaluate (abstract pgf)) - case mb_abs of - Right abs -> ret ' ' [name | cid <- Map.keys (funs abs), let name = showCId cid, isPrefixOf pref name] - Left (_ :: SomeException) -> ret ' ' [] - _ -> ret ' ' [] - where - line = decode gfenv line0 - prefix = decode gfenv prefix0 - - pgf = multigrammar cmdEnv - cmdEnv = commandenv gfenv - optLang opts = valCIdOpts "lang" (head (languages pgf)) opts - optType opts = - let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts - in case readType str of - Just ty -> ty - Nothing -> error ("Can't parse '"++str++"' as type") - - loop ps [] = Just ps - loop ps (t:ts) = case nextState ps t of - Left es -> Nothing - Right ps -> loop ps ts - - ret c [x] = return [x++[c]] - ret _ xs = return xs - - -data CompletionType - = CmplCmd Ident - | CmplStr (Maybe Command) String - | CmplOpt (Maybe Command) Ident - | CmplIdent (Maybe Command) Ident - deriving Show - -wc_type :: String -> CompletionType -wc_type = cmd_name - where - cmd_name cs = - let cs1 = dropWhile isSpace cs - in go cs1 cs1 - where - go x [] = CmplCmd x - go x (c:cs) - | isIdent c = go x cs - | otherwise = cmd x cs - - cmd x [] = ret CmplIdent x "" 0 - cmd _ ('|':cs) = cmd_name cs - cmd _ (';':cs) = cmd_name cs - cmd x ('"':cs) = str x cs cs - cmd x ('-':cs) = option x cs cs - cmd x (c :cs) - | isIdent c = ident x (c:cs) cs - | otherwise = cmd x cs - - option x y [] = ret CmplOpt x y 1 - option x y ('=':cs) = optValue x y cs - option x y (c :cs) - | isIdent c = option x y cs - | otherwise = cmd x cs - - optValue x y ('"':cs) = str x y cs - optValue x y cs = cmd x cs - - ident x y [] = ret CmplIdent x y 0 - ident x y (c:cs) - | isIdent c = ident x y cs - | otherwise = cmd x cs - - str x y [] = ret CmplStr x y 1 - str x y ('\"':cs) = cmd x cs - str x y ('\\':c:cs) = str x y cs - str x y (c:cs) = str x y cs - - ret f x y d = f cmd y - where - x1 = take (length x - length y - d) x - x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1 - - cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of - [x] -> Just x - _ -> Nothing - - isIdent c = c == '_' || c == '\'' || isAlphaNum c diff --git a/src/HelpFile b/src/HelpFile deleted file mode 100644 index c6b38b313..000000000 --- a/src/HelpFile +++ /dev/null @@ -1,693 +0,0 @@ --- GF help file updated for GF 2.6, 17/6/2006. --- *: Commands and options marked with * are currently not implemented. --- --- Each command has a long and a short name, options, and zero or more --- arguments. Commands are sorted by functionality. The short name is --- given first. - --- Type "h -all" for full help file, "h " for full help on a command. - --- commands that change the state - -i, import: i File - Reads a grammar from File and compiles it into a GF runtime grammar. - Files "include"d in File are read recursively, nubbing repetitions. - If a grammar with the same language name is already in the state, - it is overwritten - but only if compilation succeeds. - The grammar parser depends on the file name suffix: - .gf normal GF source - .gfc canonical GF - .gfr precompiled GF resource - .gfcm multilingual canonical GF - .gfe example-based grammar files (only with the -ex option) - .gfwl multilingual word list (preprocessed to abs + cncs) - .ebnf Extended BNF format - .cf Context-free (BNF) format - .trc TransferCore format - options: - -old old: parse in GF<2.0 format (not necessary) - -v verbose: give lots of messages - -s silent: don't give error messages - -src from source: ignore precompiled gfc and gfr files - -gfc from gfc: use compiled modules whenever they exist - -retain retain operations: read resource modules (needed in comm cc) - -nocf don't build old-style context-free grammar (default without HOAS) - -docf do build old-style context-free grammar (default with HOAS) - -nocheckcirc don't eliminate circular rules from CF - -cflexer build an optimized parser with separate lexer trie - -noemit do not emit code (default with old grammar format) - -o do emit code (default with new grammar format) - -ex preprocess .gfe files if needed - -prob read probabilities from top grammar file (format --# prob Fun Double) - -treebank read a treebank file to memory (xml format) - flags: - -abs set the name used for abstract syntax (with -old option) - -cnc set the name used for concrete syntax (with -old option) - -res set the name used for resource (with -old option) - -path use the (colon-separated) search path to find modules - -optimize select an optimization to override file-defined flags - -conversion select parsing method (values strict|nondet) - -probs read probabilities from file (format (--# prob) Fun Double) - -preproc use a preprocessor on each source file - -noparse read nonparsable functions from file (format --# noparse Funs) - examples: - i English.gf -- ordinary import of Concrete - i -retain german/ParadigmsGer.gf -- import of Resource to test - -r, reload: r - Executes the previous import (i) command. - -rl, remove_language: rl Language - Takes away the language from the state. - -e, empty: e - Takes away all languages and resets all global flags. - -sf, set_flags: sf Flag* - The values of the Flags are set for Language. If no language - is specified, the flags are set globally. - examples: - sf -nocpu -- stop showing CPU time - sf -lang=Swe -- make Swe the default concrete - -s, strip: s - Prune the state by removing source and resource modules. - -dc, define_command Name Anything - Add a new defined command. The Name must star with '%'. Later, - if 'Name X' is used, it is replaced by Anything where #1 is replaced - by X. - Restrictions: Currently at most one argument is possible, and a defined - command cannot appear in a pipe. - To see what definitions are in scope, use help -defs. - examples: - dc %tnp p -cat=NP -lang=Eng #1 | l -lang=Swe -- translate NPs - %tnp "this man" -- translate and parse - -dt, define_term Name Tree - Add a constant for a tree. The constant can later be called by - prefixing it with '$'. - Restriction: These terms are not yet usable as a subterm. - To see what definitions are in scope, use help -defs. - examples: - p -cat=NP "this man" | dt tm -- define tm as parse result - l -all $tm -- linearize tm in all forms - --- commands that give information about the state - -pg, print_grammar: pg - Prints the actual grammar (overridden by the -lang=X flag). - The -printer=X flag sets the format in which the grammar is - written. - N.B. since grammars are compiled when imported, this command - generally does not show the grammar in the same format as the - source. In particular, the -printer=latex is not supported. - Use the command tg -printer=latex File to print the source - grammar in LaTeX. - options: - -utf8 apply UTF8-encoding to the grammar - flags: - -printer - -lang - -startcat -- The start category of the generated grammar. - Only supported by some grammar printers. - examples: - pg -printer=cf -- show the context-free skeleton - -pm, print_multigrammar: pm - Prints the current multilingual grammar in .gfcm form. - (Automatically executes the strip command (s) before doing this.) - options: - -utf8 apply UTF8 encoding to the tokens in the grammar - -utf8id apply UTF8 encoding to the identifiers in the grammar - examples: - pm | wf Letter.gfcm -- print the grammar into the file Letter.gfcm - pm -printer=graph | wf D.dot -- then do 'dot -Tps D.dot > D.ps' - -vg, visualize_graph: vg - Show the dependency graph of multilingual grammar via dot and gv. - -po, print_options: po - Print what modules there are in the state. Also - prints those flag values in the current state that differ from defaults. - -pl, print_languages: pl - Prints the names of currently available languages. - -pi, print_info: pi Ident - Prints information on the identifier. - --- commands that execute and show the session history - -eh, execute_history: eh File - Executes commands in the file. - -ph, print_history; ph - Prints the commands issued during the GF session. - The result is readable by the eh command. - examples: - ph | wf foo.hist" -- save the history into a file - --- linearization, parsing, translation, and computation - -l, linearize: l PattList? Tree - Shows all linearization forms of Tree by the actual grammar - (which is overridden by the -lang flag). - The pattern list has the form [P, ... ,Q] where P,...,Q follow GF - syntax for patterns. All those forms are generated that match with the - pattern list. Too short lists are filled with variables in the end. - Only the -table flag is available if a pattern list is specified. - HINT: see GF language specification for the syntax of Pattern and Term. - You can also copy and past parsing results. - options: - -struct bracketed form - -table show parameters (not compatible with -record, -all) - -record record, i.e. explicit GF concrete syntax term (not compatible with -table, -all) - -all show all forms and variants (not compatible with -record, -table) - -multi linearize to all languages (can be combined with the other options) - flags: - -lang linearize in this grammar - -number give this number of forms at most - -unlexer filter output through unlexer - examples: - l -lang=Swe -table -- show full inflection table in Swe - -p, parse: p String - Shows all Trees returned for String by the actual - grammar (overridden by the -lang flag), in the category S (overridden - by the -cat flag). - options for batch input: - -lines parse each line of input separately, ignoring empty lines - -all as -lines, but also parse empty lines - -prob rank results by probability - -cut stop after first lexing result leading to parser success - -fail show strings whose parse fails prefixed by #FAIL - -ambiguous show strings that have more than one parse prefixed by #AMBIGUOUS - options for selecting parsing method: - -fcfg parse using a fast variant of MCFG (default is no HOAS in grammar) - -old parse using an overgenerating CFG (default if HOAS in grammar) - -cfg parse using a much less overgenerating CFG - -mcfg parse using an even less overgenerating MCFG - Note: the first time parsing with -cfg, -mcfg, and -fcfg may take a long time - options that only work for the -old default parsing method: - -n non-strict: tolerates morphological errors - -ign ignore unknown words when parsing - -raw return context-free terms in raw form - -v verbose: give more information if parsing fails - flags: - -cat parse in this category - -lang parse in this grammar - -lexer filter input through this lexer - -parser use this parsing strategy - -number return this many results at most - examples: - p -cat=S -mcfg "jag är gammal" -- parse an S with the MCFG - rf examples.txt | p -lines -- parse each non-empty line of the file - -at, apply_transfer: at (Module.Fun | Fun) - Transfer a term using Fun from Module, or the topmost transfer - module. Transfer modules are given in the .trc format. They are - shown by the 'po' command. - flags: - -lang typecheck the result in this lang instead of default lang - examples: - p -lang=Cncdecimal "123" | at num2bin | l -- convert dec to bin - -tb, tree_bank: tb - Generate a multilingual treebank from a list of trees (default) or compare - to an existing treebank. - options: - -c compare to existing xml-formatted treebank - -trees return the trees of the treebank - -all show all linearization alternatives (branches and variants) - -table show tables of linearizations with parameters - -record show linearization records - -xml wrap the treebank (or comparison results) with XML tags - -mem write the treebank in memory instead of a file TODO - examples: - gr -cat=S -number=100 | tb -xml | wf tb.xml -- random treebank into file - rf tb.xml | tb -c -- compare-test treebank from file - rf old.xml | tb -trees | tb -xml -- create new treebank from old - -ut, use_treebank: ut String - Lookup a string in a treebank and return the resulting trees. - Use 'tb' to create a treebank and 'i -treebank' to read one from - a file. - options: - -assocs show all string-trees associations in the treebank - -strings show all strings in the treebank - -trees show all trees in the treebank - -raw return the lookup result as string, without typechecking it - flags: - -treebank use this treebank (instead of the latest introduced one) - examples: - ut "He adds this to that" | l -multi -- use treebank lookup as parser in translation - ut -assocs | grep "ComplV2" -- show all associations with ComplV2 - -tt, test_tokenizer: tt String - Show the token list sent to the parser when String is parsed. - HINT: can be useful when debugging the parser. - flags: - -lexer use this lexer - examples: - tt -lexer=codelit "2*(x + 3)" -- a favourite lexer for program code - -g, grep: g String1 String2 - Grep the String1 in the String2. String2 is read line by line, - and only those lines that contain String1 are returned. - flags: - -v return those lines that do not contain String1. - examples: - pg -printer=cf | grep "mother" -- show cf rules with word mother - -cc, compute_concrete: cc Term - Compute a term by concrete syntax definitions. Uses the topmost - resource module (the last in listing by command po) to resolve - constant names. - N.B. You need the flag -retain when importing the grammar, if you want - the oper definitions to be retained after compilation; otherwise this - command does not expand oper constants. - N.B.' The resulting Term is not a term in the sense of abstract syntax, - and hence not a valid input to a Tree-demanding command. - flags: - -table show output in a similar readable format as 'l -table' - -res use another module than the topmost one - examples: - cc -res=ParadigmsFin (nLukko "hyppy") -- inflect "hyppy" with nLukko - -so, show_operations: so Type - Show oper operations with the given value type. Uses the topmost - resource module to resolve constant names. - N.B. You need the flag -retain when importing the grammar, if you want - the oper definitions to be retained after compilation; otherwise this - command does not find any oper constants. - N.B.' The value type may not be defined in a supermodule of the - topmost resource. In that case, use appropriate qualified name. - flags: - -res use another module than the topmost one - examples: - so -res=ParadigmsFin ResourceFin.N -- show N-paradigms in ParadigmsFin - -t, translate: t Lang Lang String - Parses String in Lang1 and linearizes the resulting Trees in Lang2. - flags: - -cat - -lexer - -parser - examples: - t Eng Swe -cat=S "every number is even or odd" - -gr, generate_random: gr Tree? - Generates a random Tree of a given category. If a Tree - argument is given, the command completes the Tree with values to - the metavariables in the tree. - options: - -prob use probabilities (works for nondep types only) - -cf use a very fast method (works for nondep types only) - flags: - -cat generate in this category - -lang use the abstract syntax of this grammar - -number generate this number of trees (not impl. with Tree argument) - -depth use this number of search steps at most - examples: - gr -cat=Query -- generate in category Query - gr (PredVP ? (NegVG ?)) -- generate a random tree of this form - gr -cat=S -tr | l -- gererate and linearize - -gt, generate_trees: gt Tree? - Generates all trees up to a given depth. If the depth is large, - a small -alts is recommended. If a Tree argument is given, the - command completes the Tree with values to the metavariables in - the tree. - options: - -metas also return trees that include metavariables - -all generate all (can be infinitely many, lazily) - -lin linearize result of -all (otherwise, use pipe to linearize) - flags: - -depth generate to this depth (default 3) - -atoms take this number of atomic rules of each category (default unlimited) - -alts take this number of alternatives at each branch (default unlimited) - -cat generate in this category - -nonub don't remove duplicates (faster, not effective with -mem) - -mem use a memorizing algorithm (often faster, usually more memory-consuming) - -lang use the abstract syntax of this grammar - -number generate (at most) this number of trees (also works with -all) - -noexpand don't expand these categories (comma-separated, e.g. -noexpand=V,CN) - -doexpand only expand these categories (comma-separated, e.g. -doexpand=V,CN) - examples: - gt -depth=10 -cat=NP -- generate all NP's to depth 10 - gt (PredVP ? (NegVG ?)) -- generate all trees of this form - gt -cat=S -tr | l -- generate and linearize - gt -noexpand=NP | l -mark=metacat -- the only NP is meta, linearized "?0 +NP" - gt | l | p -lines -ambiguous | grep "#AMBIGUOUS" -- show ambiguous strings - -ma, morphologically_analyse: ma String - Runs morphological analysis on each word in String and displays - the results line by line. - options: - -short show analyses in bracketed words, instead of separate lines - -status show just the work at success, prefixed with "*" at failure - flags: - -lang - examples: - wf Bible.txt | ma -short | wf Bible.tagged -- analyse the Bible - - --- elementary generation of Strings and Trees - -ps, put_string: ps String - Returns its argument String, like Unix echo. - HINT. The strength of ps comes from the possibility to receive the - argument from a pipeline, and altering it by the -filter flag. - flags: - -filter filter the result through this string processor - -length cut the string after this number of characters - examples: - gr -cat=Letter | l | ps -filter=text -- random letter as text - -pt, put_tree: pt Tree - Returns its argument Tree, like a specialized Unix echo. - HINT. The strength of pt comes from the possibility to receive - the argument from a pipeline, and altering it by the -transform flag. - flags: - -transform transform the result by this term processor - -number generate this number of terms at most - examples: - p "zero is even" | pt -transform=solve -- solve ?'s in parse result - -* st, show_tree: st Tree - Prints the tree as a string. Unlike pt, this command cannot be - used in a pipe to produce a tree, since its output is a string. - flags: - -printer show the tree in a special format (-printer=xml supported) - -wt, wrap_tree: wt Fun - Wraps the tree as the sole argument of Fun. - flags: - -c compute the resulting new tree to normal form - -vt, visualize_tree: vt Tree - Shows the abstract syntax tree via dot and gv (via temporary files - grphtmp.dot, grphtmp.ps). - flags: - -c show categories only (no functions) - -f show functions only (no categories) - -g show as graph (sharing uses of the same function) - -o just generate the .dot file - examples: - p "hello world" | vt -o | wf my.dot ;; ! open -a GraphViz my.dot - -- This writes the parse tree into my.dot and opens the .dot file - -- with another application without generating .ps. - --- subshells - -es, editing_session: es - Opens an interactive editing session. - N.B. Exit from a Fudget session is to the Unix shell, not to GF. - options: - -f Fudget GUI (necessary for Unicode; only available in X Window System) - -ts, translation_session: ts - Translates input lines from any of the actual languages to all other ones. - To exit, type a full stop (.) alone on a line. - N.B. Exit from a Fudget session is to the Unix shell, not to GF. - HINT: Set -parser and -lexer locally in each grammar. - options: - -f Fudget GUI (necessary for Unicode; only available in X Windows) - -lang prepend translation results with language names - flags: - -cat the parser category - examples: - ts -cat=Numeral -lang -- translate numerals, show language names - -tq, translation_quiz: tq Lang Lang - Random-generates translation exercises from Lang1 to Lang2, - keeping score of success. - To interrupt, type a full stop (.) alone on a line. - HINT: Set -parser and -lexer locally in each grammar. - flags: - -cat - examples: - tq -cat=NP TestResourceEng TestResourceSwe -- quiz for NPs - -tl, translation_list: tl Lang Lang - Random-generates a list of ten translation exercises from Lang1 - to Lang2. The number can be changed by a flag. - HINT: use wf to save the exercises in a file. - flags: - -cat - -number - examples: - tl -cat=NP TestResourceEng TestResourceSwe -- quiz list for NPs - -mq, morphology_quiz: mq - Random-generates morphological exercises, - keeping score of success. - To interrupt, type a full stop (.) alone on a line. - HINT: use printname judgements in your grammar to - produce nice expressions for desired forms. - flags: - -cat - -lang - examples: - mq -cat=N -lang=TestResourceSwe -- quiz for Swedish nouns - -ml, morphology_list: ml - Random-generates a list of ten morphological exercises, - keeping score of success. The number can be changed with a flag. - HINT: use wf to save the exercises in a file. - flags: - -cat - -lang - -number - examples: - ml -cat=N -lang=TestResourceSwe -- quiz list for Swedish nouns - - --- IO related commands - -rf, read_file: rf File - Returns the contents of File as a String; error if File does not exist. - -wf, write_file: wf File String - Writes String into File; File is created if it does not exist. - N.B. the command overwrites File without a warning. - -af, append_file: af File - Writes String into the end of File; File is created if it does not exist. - -* tg, transform_grammar: tg File - Reads File, parses as a grammar, - but instead of compiling further, prints it. - The environment is not changed. When parsing the grammar, the same file - name suffixes are supported as in the i command. - HINT: use this command to print the grammar in - another format (the -printer flag); pipe it to wf to save this format. - flags: - -printer (only -printer=latex supported currently) - -* cl, convert_latex: cl File - Reads File, which is expected to be in LaTeX form. - Three environments are treated in special ways: - \begGF - \end{verbatim}, which contains GF judgements, - \begTGF - \end{verbatim}, which contains a GF expression (displayed) - \begInTGF - \end{verbatim}, which contains a GF expressions (inlined). - Moreover, certain macros should be included in the file; you can - get those macros by applying 'tg -printer=latex foo.gf' to any grammar - foo.gf. Notice that the same File can be imported as a GF grammar, - consisting of all the judgements in \begGF environments. - HINT: pipe with 'wf Foo.tex' to generate a new Latex file. - -sa, speak_aloud: sa String - Uses the Flite speech generator to produce speech for String. - Works for American English spelling. - examples: - h | sa -- listen to the list of commands - gr -cat=S | l | sa -- generate a random sentence and speak it aloud - -si, speech_input: si - Uses an ATK speech recognizer to get speech input. - flags: - -lang: The grammar to use with the speech recognizer. - -cat: The grammar category to get input in. - -language: Use acoustic model and dictionary for this language. - -number: The number of utterances to recognize. - -h, help: h Command? - Displays the paragraph concerning the command from this help file. - Without the argument, shows the first lines of all paragraphs. - options - -all show the whole help file - -defs show user-defined commands and terms - -FLAG show the values of FLAG (works for grammar-independent flags) - examples: - h print_grammar -- show all information on the pg command - -q, quit: q - Exits GF. - HINT: you can use 'ph | wf history' to save your session. - -!, system_command: ! String - Issues a system command. No value is returned to GF. - example: - ! ls - -?, system_command: ? String - Issues a system command that receives its arguments from GF pipe - and returns a value to GF. - example: - h | ? 'wc -l' | p -cat=Num - - --- Flags. The availability of flags is defined separately for each command. - --cat, category in which parsing is performed. - The default is S. - --depth, the search depth in e.g. random generation. - The default depends on application. - --filter, operation performed on a string. The default is identity. - -filter=identity no change - -filter=erase erase the text - -filter=take100 show the first 100 characters - -filter=length show the length of the string - -filter=text format as text (punctuation, capitalization) - -filter=code format as code (spacing, indentation) - --lang, grammar used when executing a grammar-dependent command. - The default is the last-imported grammar. - --language, voice used by Festival as its --language flag in the sa command. - The default is system-dependent. - --length, the maximum number of characters shown of a string. - The default is unlimited. - --lexer, tokenization transforming a string into lexical units for a parser. - The default is words. - -lexer=words tokens are separated by spaces or newlines - -lexer=literals like words, but GF integer and string literals recognized - -lexer=vars like words, but "x","x_...","$...$" as vars, "?..." as meta - -lexer=chars each character is a token - -lexer=code use Haskell's lex - -lexer=codevars like code, but treat unknown words as variables, ?? as meta - -lexer=textvars like text, but treat unknown words as variables, ?? as meta - -lexer=text with conventions on punctuation and capital letters - -lexer=codelit like code, but treat unknown words as string literals - -lexer=textlit like text, but treat unknown words as string literals - -lexer=codeC use a C-like lexer - -lexer=ignore like literals, but ignore unknown words - -lexer=subseqs like ignore, but then try all subsequences from longest - --number, the maximum number of generated items in a list. - The default is unlimited. - --optimize, optimization on generated code. - The default is share for concrete, none for resource modules. - Each of the flags can have the suffix _subs, which performs - common subexpression elimination after the main optimization. - Thus, -optimize=all_subs is the most aggressive one. The _subs - strategy only works in GFC, and applies therefore in concrete but - not in resource modules. - -optimize=share share common branches in tables - -optimize=parametrize first try parametrize then do share with the rest - -optimize=values represent tables as courses-of-values - -optimize=all first try parametrize then do values with the rest - -optimize=none no optimization - --parser, parsing strategy. The default is chart. If -cfg or -mcfg are - selected, only bottomup and topdown are recognized. - -parser=chart bottom-up chart parsing - -parser=bottomup a more up to date bottom-up strategy - -parser=topdown top-down strategy - -parser=old an old bottom-up chart parser - --printer, format in which the grammar is printed. The default is - gfc. Those marked with M are (only) available for pm, the rest - for pg. - -printer=gfc GFC grammar - -printer=gf GF grammar - -printer=old old GF grammar - -printer=cf context-free grammar, with profiles - -printer=bnf context-free grammar, without profiles - -printer=lbnf labelled context-free grammar for BNF Converter - -printer=plbnf grammar for BNF Converter, with precedence levels - *-printer=happy source file for Happy parser generator (use lbnf!) - -printer=haskell abstract syntax in Haskell, with transl to/from GF - -printer=haskell_gadt abstract syntax GADT in Haskell, with transl to/from GF - -printer=morpho full-form lexicon, long format - *-printer=latex LaTeX file (for the tg command) - -printer=fullform full-form lexicon, short format - *-printer=xml XML: DTD for the pg command, object for st - -printer=old old GF: file readable by GF 1.2 - -printer=stat show some statistics of generated GFC - -printer=probs show probabilities of all functions - -printer=gsl Nuance GSL speech recognition grammar - -printer=jsgf Java Speech Grammar Format - -printer=jsgf_sisr_old Java Speech Grammar Format with semantic tags in - SISR WD 20030401 format - -printer=srgs_abnf SRGS ABNF format - -printer=srgs_abnf_non_rec SRGS ABNF format, without any recursion. - -printer=srgs_abnf_sisr_old SRGS ABNF format, with semantic tags in - SISR WD 20030401 format - -printer=srgs_xml SRGS XML format - -printer=srgs_xml_non_rec SRGS XML format, without any recursion. - -printer=srgs_xml_prob SRGS XML format, with weights - -printer=srgs_xml_sisr_old SRGS XML format, with semantic tags in - SISR WD 20030401 format - -printer=vxml Generate a dialogue system in VoiceXML. - -printer=slf a finite automaton in the HTK SLF format - -printer=slf_graphviz the same automaton as slf, but in Graphviz format - -printer=slf_sub a finite automaton with sub-automata in the - HTK SLF format - -printer=slf_sub_graphviz the same automaton as slf_sub, but in - Graphviz format - -printer=fa_graphviz a finite automaton with labelled edges - -printer=regular a regular grammar in a simple BNF - -printer=unpar a gfc grammar with parameters eliminated - -printer=functiongraph abstract syntax functions in 'dot' format - -printer=typegraph abstract syntax categories in 'dot' format - -printer=transfer Transfer language datatype (.tr file format) - -printer=cfg-prolog M cfg in prolog format (also pg) - -printer=gfc-prolog M gfc in prolog format (also pg) - -printer=gfcm M gfcm file (default for pm) - -printer=graph M module dependency graph in 'dot' (graphviz) format - -printer=header M gfcm file with header (for GF embedded in Java) - -printer=js M JavaScript type annotator and linearizer - -printer=mcfg-prolog M mcfg in prolog format (also pg) - -printer=missing M the missing linearizations of each concrete - --startcat, like -cat, but used in grammars (to avoid clash with keyword cat) - --transform, transformation performed on a syntax tree. The default is identity. - -transform=identity no change - -transform=compute compute by using definitions in the grammar - -transform=nodup return the term only if it has no constants duplicated - -transform=nodupatom return the term only if it has no atomic constants duplicated - -transform=typecheck return the term only if it is type-correct - -transform=solve solve metavariables as derived refinements - -transform=context solve metavariables by unique refinements as variables - -transform=delete replace the term by metavariable - --unlexer, untokenization transforming linearization output into a string. - The default is unwords. - -unlexer=unwords space-separated token list (like unwords) - -unlexer=text format as text: punctuation, capitals, paragraph

- -unlexer=code format as code (spacing, indentation) - -unlexer=textlit like text, but remove string literal quotes - -unlexer=codelit like code, but remove string literal quotes - -unlexer=concat remove all spaces - -unlexer=bind like identity, but bind at "&+" - --mark, marking of parts of tree in linearization. The default is none. - -mark=metacat append "+CAT" to every metavariable, showing its category - -mark=struct show tree structure with brackets - -mark=java show tree structure with XML tags (used in gfeditor) - --coding, Some grammars are in UTF-8, some in isolatin-1. - If the letters ä (a-umlaut) and ö (o-umlaut) look strange, either - change your terminal to isolatin-1, or rewrite the grammar with - 'pg -utf8'. - --- *: Commands and options marked with * are not currently implemented. diff --git a/src/Makefile b/src/Makefile deleted file mode 100644 index e4c6bb728..000000000 --- a/src/Makefile +++ /dev/null @@ -1,250 +0,0 @@ -include config.mk - - -GHMAKE=$(GHC) --make -GHCXMAKE=ghcxmake -GHCFLAGS+= -fglasgow-exts -GHCOPTFLAGS=-O2 -GHCFUDFLAG= - -DIST_DIR=GF-$(PACKAGE_VERSION) -NOT_IN_DIST= \ - grammars \ - download \ - doc/release2.html \ - src/tools/AlphaConvGF.hs - -BIN_DIST_DIR=$(DIST_DIR)-$(host) - -GRAMMAR_PACKAGE_VERSION=$(shell date +%Y%m%d) -GRAMMAR_DIST_DIR=gf-grammars-$(GRAMMAR_PACKAGE_VERSION) - -MSI_FILE=gf-$(subst .,_,$(PACKAGE_VERSION)).msi - -GF_DATA_DIR=$(datadir)/GF-$(PACKAGE_VERSION) -GF_LIB_DIR=$(GF_DATA_DIR)/lib - -EMBED = GF/Embed/TemplateApp - -# use the temporary binary file name 'gf-bin' to not clash with directory 'GF' -# on case insensitive file systems (such as FAT) -GF_EXE=gf$(EXEEXT) -GF_EXE_TMP=gf-bin$(EXEEXT) -GF_DOC_EXE=gfdoc$(EXEEXT) - - -ifeq ("$(READLINE)","readline") - GHCFLAGS += -package readline -DUSE_READLINE -endif - -ifneq ("$(CPPFLAGS)","") - GHCFLAGS += $(addprefix -optP, $(CPPFLAGS)) -endif - -ifneq ("$(LDFLAGS)","") - GHCFLAGS += $(addprefix -optl, $(LDFLAGS)) -endif - -ifeq ("$(INTERRUPT)","yes") - GHCFLAGS += -DUSE_INTERRUPT -endif - -ifeq ("$(ATK)","yes") - GHCFLAGS += -DUSE_ATK -endif - -ifeq ("$(ENABLE_JAVA)", "yes") - BUILD_JAR=jar -else - BUILD_JAR= -endif - -.PHONY: all unix jar tags gfdoc windows install install-gf \ - lib temp install-gfdoc \ - today help clean windows-msi dist gfc - -all: unix gfc lib - -static: GHCFLAGS += -optl-static -static: unix - - -gf: unix - -unix: today opt - -windows: unix - -temp: today noopt - - -build: - $(GHMAKE) $(GHCFLAGS) GF.hs -o $(GF_EXE_TMP) - strip $(GF_EXE_TMP) - mv $(GF_EXE_TMP) ../bin/$(GF_EXE) - -opt: GHCFLAGS += $(GHCOPTFLAGS) -opt: build - -embed: GHCFLAGS += $(GHCOPTFLAGS) -embed: - $(GHMAKE) $(GHCFLAGS) $(EMBED) -o $(EMBED) - strip $(EMBED) - -noopt: build - -clean: - find . '(' -name '*~' -o -name '*.hi' -o -name '*.ghi' -o -name '*.o' ')' -exec rm -f '{}' ';' - -rm -f gf.wixobj - -rm -f ../bin/$(GF_EXE) - $(MAKE) -C tools/c clean - $(MAKE) -C ../lib/c clean - -rm -f ../bin/gfcc2c - -distclean: clean - -rm -f tools/$(GF_DOC_EXE) - -rm -f config.status config.mk config.log - -rm -f *.tgz *.zip - -rm -rf $(DIST_DIR) $(BIN_DIST_DIR) - -rm -rf gf.wxs *.msi - -today: - echo 'module Paths_gf (version, getDataDir) where' > Paths_gf.hs - echo 'import Data.Version' >> Paths_gf.hs - echo '{-# NOINLINE version #-}' >> Paths_gf.hs - echo 'version :: Version' >> Paths_gf.hs - echo 'version = Version {versionBranch = [3,0], versionTags = ["beta3"]}' >> Paths_gf.hs - echo 'getDataDir = return "$(GF_DATA_DIR)" :: IO FilePath' >> Paths_gf.hs - - -showflags: - @echo $(GHCFLAGS) - -# added by peb: -tracing: GHCFLAGS += -DTRACING -tracing: temp - -ghci-trace: GHCFLAGS += -DTRACING -ghci-trace: ghci - -#touch-files: -# rm -f GF/System/Tracing.{hi,o} -# touch GF/System/Tracing.hs - -# profiling -prof: GHCOPTFLAGS += -prof -auto-all -prof: unix - -tags: - find GF Transfer -name '*.hs' | xargs hasktags - -# -# Help file -# - -tools/MkHelpFile: tools/MkHelpFile.hs - $(GHMAKE) -o $@ $^ - -help: GF/Shell/HelpFile.hs - -GF/Shell/HelpFile.hs: tools/MkHelpFile HelpFile - tools/MkHelpFile - -# -# Tools -# - -gfdoc: tools/$(GF_DOC_EXE) - -tools/$(GF_DOC_EXE): tools/GFDoc.hs - $(GHMAKE) $(GHCOPTFLAGS) -o $@ $^ - -gfc: gf - echo GFC! - cp -f gfc ../bin/ - chmod a+x ../bin/gfc - -gfcc2c: - $(MAKE) -C tools/c - $(MAKE) -C ../lib/c - mv tools/c/gfcc2c ../bin - -# -# Resource grammars -# - -lib: - $(MAKE) -C ../lib/resource clean all - -# -# Distribution -# - -dist: - -rm -rf $(DIST_DIR) - darcs dist --dist-name=$(DIST_DIR) - tar -zxf ../$(DIST_DIR).tar.gz - rm ../$(DIST_DIR).tar.gz - cd $(DIST_DIR)/src && perl -pi -e "s/^AC_INIT\(\[GF\],\[[^\]]*\]/AC_INIT([GF],[$(PACKAGE_VERSION)]/" configure.ac - cd $(DIST_DIR)/src && autoconf && rm -rf autom4te.cache -# cd $(DIST_DIR)/grammars && sh mkLib.sh - cd $(DIST_DIR) && rm -rf $(NOT_IN_DIST) - $(TAR) -zcf $(DIST_DIR).tgz $(DIST_DIR) - rm -rf $(DIST_DIR) - -snapshot: PACKAGE_VERSION=$(shell date +%Y%m%d) -snapshot: DIST_DIR=GF-$(PACKAGE_VERSION) -snapshot: dist - -rpm: dist - rpmbuild -ta $(DIST_DIR).tgz - - -binary-dist: - rm -rf $(BIN_DIST_DIR) - mkdir $(BIN_DIST_DIR) - mkdir $(BIN_DIST_DIR)/lib - ./configure --host="$(host)" --build="$(build)" - $(MAKE) gfc gfdoc - $(INSTALL) ../bin/$(GF_EXE) tools/$(GF_DOC_EXE) $(BIN_DIST_DIR) - $(INSTALL) configure config.guess config.sub install-sh config.mk.in $(BIN_DIST_DIR) - $(INSTALL) gfc.in $(BIN_DIST_DIR) - $(INSTALL) -m 0644 ../README ../LICENSE $(BIN_DIST_DIR) - $(INSTALL) -m 0644 INSTALL.binary $(BIN_DIST_DIR)/INSTALL - $(INSTALL) -m 0644 Makefile.binary $(BIN_DIST_DIR)/Makefile -# $(TAR) -C $(BIN_DIST_DIR)/lib -zxf ../lib/compiled.tgz - $(TAR) -zcf GF-$(PACKAGE_VERSION)-$(host).tgz $(BIN_DIST_DIR) - rm -rf $(BIN_DIST_DIR) - -grammar-dist: - -rm -rf $(GRAMMAR_DIST_DIR) - mkdir $(GRAMMAR_DIST_DIR) - cp -r ../_darcs/current/{lib,examples} $(GRAMMAR_DIST_DIR) - $(MAKE) GF_LIB_PATH=.. -C $(GRAMMAR_DIST_DIR)/lib/resource-1.0 show-path prelude present alltenses mathematical api multimodal langs - $(TAR) -zcf $(GRAMMAR_DIST_DIR).tgz $(GRAMMAR_DIST_DIR) - rm -rf $(GRAMMAR_DIST_DIR) - -gf.wxs: config.status gf.wxs.in - ./config.status --file=$@ - -windows-msi: gf.wxs - candle -nologo gf.wxs - light -nologo -o $(MSI_FILE) gf.wixobj - -# -# Installation -# - -install: install-gf install-gfdoc install-lib - -install-gf: - $(INSTALL) -d $(bindir) - $(INSTALL) ../bin/$(GF_EXE) $(bindir) - -install-gfdoc: - $(INSTALL) -d $(bindir) - $(INSTALL) tools/$(GF_DOC_EXE) $(bindir) - -install-lib: - $(INSTALL) -d $(GF_LIB_DIR) - $(TAR) -C $(GF_LIB_DIR) -zxf ../lib/compiled.tgz diff --git a/src/Makefile.binary b/src/Makefile.binary deleted file mode 100644 index 0ae18a2e7..000000000 --- a/src/Makefile.binary +++ /dev/null @@ -1,20 +0,0 @@ -include config.mk - -GF_DATA_DIR=$(datadir)/GF-$(PACKAGE_VERSION) -GF_LIB_DIR=$(GF_DATA_DIR)/lib - -.PHONY: install uninstall - -install: - $(INSTALL) -d $(bindir) - $(INSTALL) gf$(EXEEXT) gfdoc$(EXEEXT) $(bindir) - $(INSTALL) gfc$(EXEEXT) $(bindir) - $(INSTALL) -d $(GF_DATA_DIR) - cp -r lib $(GF_DATA_DIR) - -uninstall: - -rm -f $(bindir)/gf$(EXEEXT) $(bindir)/gfdoc$(EXEEXT) - -rm -f $GF_LIB_DIR)/*/*.gf{o} - -rmdir $(GF_LIB_DIR)/* - -rmdir $(GF_LIB_DIR) - -rmdir $(GF_DATA_DIR) diff --git a/src/PGF.hs b/src/PGF.hs deleted file mode 100644 index 6c192095d..000000000 --- a/src/PGF.hs +++ /dev/null @@ -1,352 +0,0 @@ -------------------------------------------------- --- | --- Module : PGF --- Maintainer : Aarne Ranta --- Stability : stable --- Portability : portable --- --- This module is an Application Programming Interface to --- load and interpret grammars compiled in Portable Grammar Format (PGF). --- The PGF format is produced as a final output from the GF compiler. --- The API is meant to be used for embedding GF grammars in Haskell --- programs -------------------------------------------------- - -module PGF( - -- * PGF - PGF, - readPGF, - - -- * Identifiers - CId, mkCId, wildCId, - showCId, readCId, - - -- * Languages - Language, - showLanguage, readLanguage, - languages, abstractName, languageCode, - - -- * Types - Type, Hypo, - showType, readType, - mkType, mkHypo, mkDepHypo, mkImplHypo, - categories, startCat, - - -- * Functions - functions, functionType, - - -- * Expressions & Trees - -- ** Tree - Tree, - - -- ** Expr - Expr, - showExpr, readExpr, - mkApp, unApp, - mkStr, unStr, - mkInt, unInt, - mkDouble, unDouble, - mkMeta, isMeta, - - -- * Operations - -- ** Linearization - linearize, linearizeAllLang, linearizeAll, - showPrintName, - - -- ** Parsing - parse, parseWithRecovery, canParse, parseAllLang, parseAll, - - -- ** Evaluation - PGF.compute, paraphrase, - - -- ** Type Checking - -- | The type checker in PGF does both type checking and renaming - -- i.e. it verifies that all identifiers are declared and it - -- distinguishes between global function or type indentifiers and - -- variable names. The type checker should always be applied on - -- expressions entered by the user i.e. those produced via functions - -- like 'readType' and 'readExpr' because otherwise unexpected results - -- could appear. All typechecking functions returns updated versions - -- of the input types or expressions because the typechecking could - -- also lead to metavariables instantiations. - checkType, checkExpr, inferExpr, - TcError(..), ppTcError, - - -- ** Word Completion (Incremental Parsing) - complete, - Incremental.ParseState, - Incremental.initState, Incremental.nextState, Incremental.getCompletions, Incremental.recoveryStates, Incremental.extractTrees, - - -- ** Generation - generateRandom, generateAll, generateAllDepth, - - -- ** Morphological Analysis - Lemma, Analysis, Morpho, - lookupMorpho, buildMorpho, - - -- ** Visualizations - graphvizAbstractTree, - graphvizParseTree, - graphvizDependencyTree, - graphvizAlignment, - - -- * Browsing - browse - ) where - -import PGF.CId -import PGF.Linearize -import PGF.Generate -import PGF.TypeCheck -import PGF.Paraphrase -import PGF.VisualizeTree -import PGF.Macros -import PGF.Expr (Tree) -import PGF.Morphology -import PGF.Data hiding (functions) -import PGF.Binary -import qualified PGF.Parsing.FCFG.Active as Active -import qualified PGF.Parsing.FCFG.Incremental as Incremental -import qualified GF.Compile.GeneratePMCFG as PMCFG - -import GF.Infra.Option -import GF.Data.Utilities (replace) - -import Data.Char -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import Data.Maybe -import Data.Binary -import Data.List(mapAccumL) -import System.Random (newStdGen) -import Control.Monad -import Text.PrettyPrint - ---------------------------------------------------- --- Interface ---------------------------------------------------- - --- | Reads file in Portable Grammar Format and produces --- 'PGF' structure. The file is usually produced with: --- --- > $ gf -make -readPGF :: FilePath -> IO PGF - --- | Linearizes given expression as string in the language -linearize :: PGF -> Language -> Tree -> String - --- | Tries to parse the given string in the specified language --- and to produce abstract syntax expression. An empty --- list is returned if the parsing is not successful. The list may also --- contain more than one element if the grammar is ambiguous. --- Throws an exception if the given language cannot be used --- for parsing, see 'canParse'. -parse :: PGF -> Language -> Type -> String -> [Tree] - -parseWithRecovery :: PGF -> Language -> Type -> [Type] -> String -> [Tree] - --- | Checks whether the given language can be used for parsing. -canParse :: PGF -> Language -> Bool - --- | The same as 'linearizeAllLang' but does not return --- the language. -linearizeAll :: PGF -> Tree -> [String] - --- | Linearizes given expression as string in all languages --- available in the grammar. -linearizeAllLang :: PGF -> Tree -> [(Language,String)] - --- | Show the printname of a type -showPrintName :: PGF -> Language -> Type -> String - --- | The same as 'parseAllLang' but does not return --- the language. -parseAll :: PGF -> Type -> String -> [[Tree]] - --- | Tries to parse the given string with all available languages. --- Languages which cannot be used for parsing (see 'canParse') --- are ignored. --- The returned list contains pairs of language --- and list of abstract syntax expressions --- (this is a list, since grammars can be ambiguous). --- Only those languages --- for which at least one parsing is possible are listed. -parseAllLang :: PGF -> Type -> String -> [(Language,[Tree])] - --- | The same as 'generateAllDepth' but does not limit --- the depth in the generation. -generateAll :: PGF -> Type -> [Expr] - --- | Generates an infinite list of random abstract syntax expressions. --- This is usefull for tree bank generation which after that can be used --- for grammar testing. -generateRandom :: PGF -> Type -> IO [Expr] - --- | Generates an exhaustive possibly infinite list of --- abstract syntax expressions. A depth can be specified --- to limit the search space. -generateAllDepth :: PGF -> Type -> Maybe Int -> [Expr] - --- | List of all languages available in the given grammar. -languages :: PGF -> [Language] - --- | Gets the RFC 4646 language tag --- of the language which the given concrete syntax implements, --- if this is listed in the source grammar. --- Example language tags include @\"en\"@ for English, --- and @\"en-UK\"@ for British English. -languageCode :: PGF -> Language -> Maybe String - --- | The abstract language name is the name of the top-level --- abstract module -abstractName :: PGF -> Language - --- | List of all categories defined in the given grammar. --- The categories are defined in the abstract syntax --- with the \'cat\' keyword. -categories :: PGF -> [CId] - --- | The start category is defined in the grammar with --- the \'startcat\' flag. This is usually the sentence category --- but it is not necessary. Despite that there is a start category --- defined you can parse with any category. The start category --- definition is just for convenience. -startCat :: PGF -> Type - --- | List of all functions defined in the abstract syntax -functions :: PGF -> [CId] - --- | The type of a given function -functionType :: PGF -> CId -> Maybe Type - --- | Complete the last word in the given string. If the input --- is empty or ends in whitespace, the last word is considred --- to be the empty string. This means that the completions --- will be all possible next words. -complete :: PGF -> Language -> Type -> String - -> [String] -- ^ Possible completions, - -- including the given input. - - ---------------------------------------------------- --- Implementation ---------------------------------------------------- - -readPGF f = decodeFile f >>= addParsers - --- Adds parsers for all concretes that don't have a parser and that have parser=ondemand. -addParsers :: PGF -> IO PGF -addParsers pgf = do cncs <- sequence [if wantsParser cnc then addParser lang cnc else return (lang,cnc) - | (lang,cnc) <- Map.toList (concretes pgf)] - return pgf { concretes = Map.fromList cncs } - where - wantsParser cnc = isNothing (parser cnc) && Map.lookup (mkCId "parser") (cflags cnc) == Just "ondemand" - addParser lang cnc = do pinfo <- PMCFG.convertConcrete noOptions (abstract pgf) lang cnc - return (lang,cnc { parser = Just pinfo }) - -linearize pgf lang = concat . take 1 . PGF.Linearize.linearizes pgf lang - -parse pgf lang typ s = - case Map.lookup lang (concretes pgf) of - Just cnc -> case parser cnc of - Just pinfo -> if Map.lookup (mkCId "erasing") (cflags cnc) == Just "on" - then Incremental.parse pgf lang typ (words s) - else Active.parse "t" pinfo typ (words s) - Nothing -> error ("No parser built for language: " ++ showCId lang) - Nothing -> error ("Unknown language: " ++ showCId lang) - -parseWithRecovery pgf lang typ open_typs s = Incremental.parseWithRecovery pgf lang typ open_typs (words s) - -canParse pgf cnc = isJust (lookParser pgf cnc) - -linearizeAll mgr = map snd . linearizeAllLang mgr -linearizeAllLang mgr t = - [(lang,PGF.linearize mgr lang t) | lang <- languages mgr] - -showPrintName pgf lang (DTyp _ c _) = realize $ lookPrintName pgf lang c - -parseAll mgr typ = map snd . parseAllLang mgr typ - -parseAllLang mgr typ s = - [(lang,ts) | lang <- languages mgr, canParse mgr lang, let ts = parse mgr lang typ s, not (null ts)] - -generateRandom pgf cat = do - gen <- newStdGen - return $ genRandom gen pgf cat - -generateAll pgf cat = generate pgf cat Nothing -generateAllDepth pgf cat = generate pgf cat - -abstractName pgf = absname pgf - -languages pgf = cncnames pgf - -languageCode pgf lang = - fmap (replace '_' '-') $ lookConcrFlag pgf lang (mkCId "language") - -categories pgf = [c | (c,hs) <- Map.toList (cats (abstract pgf))] - -startCat pgf = DTyp [] (lookStartCat pgf) [] - -functions pgf = Map.keys (funs (abstract pgf)) - -functionType pgf fun = - case Map.lookup fun (funs (abstract pgf)) of - Just (ty,_,_) -> Just ty - Nothing -> Nothing - -complete pgf from typ input = - let (ws,prefix) = tokensAndPrefix input - state0 = Incremental.initState pgf from typ - in case loop state0 ws of - Nothing -> [] - Just state -> - (if null prefix && not (null (Incremental.extractTrees state typ)) then [unwords ws ++ " "] else []) - ++ [unwords (ws++[c]) ++ " " | c <- Map.keys (Incremental.getCompletions state prefix)] - where - tokensAndPrefix :: String -> ([String],String) - tokensAndPrefix s | not (null s) && isSpace (last s) = (ws, "") - | null ws = ([],"") - | otherwise = (init ws, last ws) - where ws = words s - - loop ps [] = Just ps - loop ps (t:ts) = case Incremental.nextState ps t of - Left es -> Nothing - Right ps -> loop ps ts - --- | Converts an expression to normal form -compute :: PGF -> Expr -> Expr -compute pgf = PGF.Data.normalForm (funs (abstract pgf)) 0 [] - -browse :: PGF -> CId -> Maybe (String,[CId],[CId]) -browse pgf id = fmap (\def -> (def,producers,consumers)) definition - where - definition = case Map.lookup id (funs (abstract pgf)) of - Just (ty,_,eqs) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$ - if null eqs - then empty - else text "def" <+> vcat [let (scope,ds) = mapAccumL (ppPatt 9) [] patts - in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs]) - Nothing -> case Map.lookup id (cats (abstract pgf)) of - Just hyps -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL ppHypo [] hyps))) - Nothing -> Nothing - - (producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf)) - where - accum f (ty,_,_) (plist,clist) = - let !plist' = if id `elem` ps then f : plist else plist - !clist' = if id `elem` cs then f : clist else clist - in (plist',clist') - where - (ps,cs) = tyIds ty - - tyIds (DTyp hyps cat es) = (foldr expIds (cat:concat css) es,concat pss) - where - (pss,css) = unzip [tyIds ty | (_,_,ty) <- hyps] - - expIds (EAbs _ _ e) ids = expIds e ids - expIds (EApp e1 e2) ids = expIds e1 (expIds e2 ids) - expIds (EFun id) ids = id : ids - expIds (ETyped e _) ids = expIds e ids - expIds _ ids = ids diff --git a/src/PGF/Binary.hs b/src/PGF/Binary.hs deleted file mode 100644 index e4ed98424..000000000 --- a/src/PGF/Binary.hs +++ /dev/null @@ -1,199 +0,0 @@ -module PGF.Binary where - -import PGF.CId -import PGF.Data -import Data.Binary -import Data.Binary.Put -import Data.Binary.Get -import qualified Data.ByteString as BS -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import qualified Data.Set as Set -import Control.Monad - -pgfMajorVersion, pgfMinorVersion :: Word16 -(pgfMajorVersion, pgfMinorVersion) = (1,0) - -instance Binary PGF where - put pgf = putWord16be pgfMajorVersion >> - putWord16be pgfMinorVersion >> - put ( absname pgf, cncnames pgf - , gflags pgf - , abstract pgf, concretes pgf - ) - get = do v1 <- getWord16be - v2 <- getWord16be - absname <- get - cncnames <- get - gflags <- get - abstract <- get - concretes <- get - return (PGF{ absname=absname, cncnames=cncnames - , gflags=gflags - , abstract=abstract, concretes=concretes - }) - -instance Binary CId where - put (CId bs) = put bs - get = liftM CId get - -instance Binary Abstr where - put abs = put (aflags abs, funs abs, cats abs) - get = do aflags <- get - funs <- get - cats <- get - let catfuns = Map.mapWithKey (\cat _ -> [f | (f, (DTyp _ c _,_,_)) <- Map.toList funs, c==cat]) cats - return (Abstr{ aflags=aflags - , funs=funs, cats=cats - , catfuns=catfuns - }) - -instance Binary Concr where - put cnc = put ( cflags cnc, lins cnc, opers cnc - , lincats cnc, lindefs cnc - , printnames cnc, paramlincats cnc - , parser cnc - ) - get = do cflags <- get - lins <- get - opers <- get - lincats <- get - lindefs <- get - printnames <- get - paramlincats <- get - parser <- get - return (Concr{ cflags=cflags, lins=lins, opers=opers - , lincats=lincats, lindefs=lindefs - , printnames=printnames - , paramlincats=paramlincats - , parser=parser - }) - -instance Binary Alternative where - put (Alt v x) = put v >> put x - get = liftM2 Alt get get - -instance Binary Term where - put (R es) = putWord8 0 >> put es - put (S es) = putWord8 1 >> put es - put (FV es) = putWord8 2 >> put es - put (P e v) = putWord8 3 >> put (e,v) - put (W e v) = putWord8 4 >> put (e,v) - put (C i ) = putWord8 5 >> put i - put (TM i ) = putWord8 6 >> put i - put (F f) = putWord8 7 >> put f - put (V i) = putWord8 8 >> put i - put (K (KS s)) = putWord8 9 >> put s - put (K (KP d vs)) = putWord8 10 >> put (d,vs) - - get = do tag <- getWord8 - case tag of - 0 -> liftM R get - 1 -> liftM S get - 2 -> liftM FV get - 3 -> liftM2 P get get - 4 -> liftM2 W get get - 5 -> liftM C get - 6 -> liftM TM get - 7 -> liftM F get - 8 -> liftM V get - 9 -> liftM (K . KS) get - 10 -> liftM2 (\d vs -> K (KP d vs)) get get - _ -> decodingError - -instance Binary Expr where - put (EAbs b x exp) = putWord8 0 >> put (b,x,exp) - put (EApp e1 e2) = putWord8 1 >> put (e1,e2) - put (ELit (LStr s)) = putWord8 2 >> put s - put (ELit (LFlt d)) = putWord8 3 >> put d - put (ELit (LInt i)) = putWord8 4 >> put i - put (EMeta i) = putWord8 5 >> put i - put (EFun f) = putWord8 6 >> put f - put (EVar i) = putWord8 7 >> put i - put (ETyped e ty) = putWord8 8 >> put (e,ty) - get = do tag <- getWord8 - case tag of - 0 -> liftM3 EAbs get get get - 1 -> liftM2 EApp get get - 2 -> liftM (ELit . LStr) get - 3 -> liftM (ELit . LFlt) get - 4 -> liftM (ELit . LInt) get - 5 -> liftM EMeta get - 6 -> liftM EFun get - 7 -> liftM EVar get - 8 -> liftM2 ETyped get get - _ -> decodingError - -instance Binary Patt where - put (PApp f ps) = putWord8 0 >> put (f,ps) - put (PVar x) = putWord8 1 >> put x - put PWild = putWord8 2 - put (PLit (LStr s)) = putWord8 3 >> put s - put (PLit (LFlt d)) = putWord8 4 >> put d - put (PLit (LInt i)) = putWord8 5 >> put i - get = do tag <- getWord8 - case tag of - 0 -> liftM2 PApp get get - 1 -> liftM PVar get - 2 -> return PWild - 3 -> liftM (PLit . LStr) get - 4 -> liftM (PLit . LFlt) get - 5 -> liftM (PLit . LInt) get - _ -> decodingError - -instance Binary Equation where - put (Equ ps e) = put (ps,e) - get = liftM2 Equ get get - -instance Binary Type where - put (DTyp hypos cat exps) = put (hypos,cat,exps) - get = liftM3 DTyp get get get - -instance Binary BindType where - put Explicit = putWord8 0 - put Implicit = putWord8 1 - get = do tag <- getWord8 - case tag of - 0 -> return Explicit - 1 -> return Implicit - _ -> decodingError - -instance Binary FFun where - put (FFun fun prof lins) = put (fun,prof,lins) - get = liftM3 FFun get get get - -instance Binary FSymbol where - put (FSymCat n l) = putWord8 0 >> put (n,l) - put (FSymLit n l) = putWord8 1 >> put (n,l) - put (FSymKS ts) = putWord8 2 >> put ts - put (FSymKP d vs) = putWord8 3 >> put (d,vs) - get = do tag <- getWord8 - case tag of - 0 -> liftM2 FSymCat get get - 1 -> liftM2 FSymLit get get - 2 -> liftM FSymKS get - 3 -> liftM2 (\d vs -> FSymKP d vs) get get - _ -> decodingError - -instance Binary Production where - put (FApply ruleid args) = putWord8 0 >> put (ruleid,args) - put (FCoerce fcat) = putWord8 1 >> put fcat - get = do tag <- getWord8 - case tag of - 0 -> liftM2 FApply get get - 1 -> liftM FCoerce get - _ -> decodingError - -instance Binary ParserInfo where - put p = put (functions p, sequences p, productions0 p, totalCats p, startCats p) - get = do functions <- get - sequences <- get - productions0<- get - totalCats <- get - startCats <- get - return (ParserInfo{functions=functions,sequences=sequences - ,productions0=productions0 - ,productions =filterProductions productions0 - ,totalCats=totalCats,startCats=startCats}) - -decodingError = fail "This PGF file was compiled with different version of GF" diff --git a/src/PGF/BuildParser.hs b/src/PGF/BuildParser.hs deleted file mode 100644 index 23e0725c6..000000000 --- a/src/PGF/BuildParser.hs +++ /dev/null @@ -1,76 +0,0 @@ ---------------------------------------------------------------------- --- | --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- FCFG parsing, parser information ------------------------------------------------------------------------------ - -module PGF.BuildParser where - -import GF.Data.SortedList -import GF.Data.Assoc -import PGF.CId -import PGF.Data -import PGF.Parsing.FCFG.Utilities - -import Data.Array.IArray -import Data.Maybe -import qualified Data.IntMap as IntMap -import qualified Data.Map as Map -import qualified Data.Set as Set -import Debug.Trace - - -data ParserInfoEx - = ParserInfoEx { epsilonRules :: [(FunId,[FCat],FCat)] - , leftcornerCats :: Assoc FCat [(FunId,[FCat],FCat)] - , leftcornerTokens :: Assoc String [(FunId,[FCat],FCat)] - , grammarToks :: [String] - } - ------------------------------------------------------------- --- parser information - -getLeftCornerTok pinfo (FFun _ _ lins) - | inRange (bounds syms) 0 = case syms ! 0 of - FSymKS [tok] -> [tok] - _ -> [] - | otherwise = [] - where - syms = (sequences pinfo) ! (lins ! 0) - -getLeftCornerCat pinfo args (FFun _ _ lins) - | inRange (bounds syms) 0 = case syms ! 0 of - FSymCat d _ -> let cat = args !! d - in case IntMap.lookup cat (productions pinfo) of - Just set -> cat : [cat' | FCoerce cat' <- Set.toList set] - Nothing -> [cat] - _ -> [] - | otherwise = [] - where - syms = (sequences pinfo) ! (lins ! 0) - -buildParserInfo :: ParserInfo -> ParserInfoEx -buildParserInfo pinfo = - ParserInfoEx { epsilonRules = epsilonrules - , leftcornerCats = leftcorncats - , leftcornerTokens = leftcorntoks - , grammarToks = grammartoks - } - - where epsilonrules = [ (ruleid,args,cat) - | (cat,set) <- IntMap.toList (productions pinfo) - , (FApply ruleid args) <- Set.toList set - , let (FFun _ _ lins) = (functions pinfo) ! ruleid - , not (inRange (bounds ((sequences pinfo) ! (lins ! 0))) 0) ] - leftcorncats = accumAssoc id [ (cat', (ruleid, args, cat)) - | (cat,set) <- IntMap.toList (productions pinfo) - , (FApply ruleid args) <- Set.toList set - , cat' <- getLeftCornerCat pinfo args ((functions pinfo) ! ruleid) ] - leftcorntoks = accumAssoc id [ (tok, (ruleid, args, cat)) - | (cat,set) <- IntMap.toList (productions pinfo) - , (FApply ruleid args) <- Set.toList set - , tok <- getLeftCornerTok pinfo ((functions pinfo) ! ruleid) ] - grammartoks = nubsort [t | lin <- elems (sequences pinfo), FSymKS [t] <- elems lin] diff --git a/src/PGF/CId.hs b/src/PGF/CId.hs deleted file mode 100644 index fea304d9d..000000000 --- a/src/PGF/CId.hs +++ /dev/null @@ -1,55 +0,0 @@ -module PGF.CId (CId(..), - mkCId, wildCId, - readCId, showCId, - - -- utils - pCId, pIdent, ppCId) where - -import Control.Monad -import qualified Data.ByteString.Char8 as BS -import Data.Char -import qualified Text.ParserCombinators.ReadP as RP -import qualified Text.PrettyPrint as PP - - --- | An abstract data type that represents --- identifiers for functions and categories in PGF. -newtype CId = CId BS.ByteString deriving (Eq,Ord) - -wildCId :: CId -wildCId = CId (BS.singleton '_') - --- | Creates a new identifier from 'String' -mkCId :: String -> CId -mkCId s = CId (BS.pack s) - --- | Reads an identifier from 'String'. The function returns 'Nothing' if the string is not valid identifier. -readCId :: String -> Maybe CId -readCId s = case [x | (x,cs) <- RP.readP_to_S pCId s, all isSpace cs] of - [x] -> Just x - _ -> Nothing - --- | Renders the identifier as 'String' -showCId :: CId -> String -showCId (CId x) = BS.unpack x - -instance Show CId where - showsPrec _ = showString . showCId - -instance Read CId where - readsPrec _ = RP.readP_to_S pCId - -pCId :: RP.ReadP CId -pCId = do s <- pIdent - if s == "_" - then RP.pfail - else return (mkCId s) - -pIdent :: RP.ReadP String -pIdent = liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest) - where - isIdentFirst c = c == '_' || isLetter c - isIdentRest c = c == '_' || c == '\'' || isAlphaNum c - -ppCId :: CId -> PP.Doc -ppCId = PP.text . showCId diff --git a/src/PGF/Check.hs b/src/PGF/Check.hs deleted file mode 100644 index 58b66cfe4..000000000 --- a/src/PGF/Check.hs +++ /dev/null @@ -1,173 +0,0 @@ -module PGF.Check (checkPGF) where - -import PGF.CId -import PGF.Data -import PGF.Macros -import GF.Data.ErrM - -import qualified Data.Map as Map -import Control.Monad -import Debug.Trace - -checkPGF :: PGF -> Err (PGF,Bool) -checkPGF pgf = do - (cs,bs) <- mapM (checkConcrete pgf) - (Map.assocs (concretes pgf)) >>= return . unzip - return (pgf {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 :: PGF -> (CId,Concr) -> Err ((CId,Concr),Bool) -checkConcrete pgf (lang,cnc) = - labelBoolErr ("happened in language " ++ showCId lang) $ do - (rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip - return ((lang,cnc{lins = Map.fromAscList rs}),and bs) - where - checkl = checkLin pgf lang - -checkLin :: PGF -> CId -> (CId,Term) -> Err ((CId,Term),Bool) -checkLin pgf lang (f,t) = - labelBoolErr ("happened in function " ++ showCId f) $ do - (t',b) <- checkTerm (lintype pgf lang f) t --- $ inline pgf 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 True 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 False 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) - --- symmetry in (Ints m == Ints n) is all we can use in variants - -eqType :: Bool -> CType -> CType -> Bool -eqType symm inf exp = case (inf,exp) of - (C k, C n) -> if symm then True else k <= n -- only run-time corr. - (R rs,R ts) -> length rs == length ts && and [eqType symm 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 :: PGF -> CId -> CId -> LinType -lintype pgf lang fun = case typeSkeleton (lookType pgf fun) of - (cs,c) -> (map vlinc cs, linc c) ---- HOAS - where - linc = lookLincat pgf lang - vlinc (0,c) = linc c - vlinc (i,c) = case linc c of - R ts -> R (ts ++ replicate i str) - -inline :: PGF -> CId -> Term -> Term -inline pgf lang t = case t of - F c -> inl $ look c - _ -> composSafeOp inl t - where - inl = inline pgf lang - look = lookLin pgf 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/PGF/Data.hs b/src/PGF/Data.hs deleted file mode 100644 index 38027e96e..000000000 --- a/src/PGF/Data.hs +++ /dev/null @@ -1,95 +0,0 @@ -module PGF.Data (module PGF.Data, module PGF.Expr, module PGF.Type, module PGF.PMCFG) where - -import PGF.CId -import PGF.Expr hiding (Value, Env, Tree) -import PGF.Type -import PGF.PMCFG - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.IntMap as IntMap -import Data.List - --- internal datatypes for PGF - --- | An abstract data type representing multilingual grammar --- in Portable Grammar Format. -data PGF = PGF { - absname :: CId , - cncnames :: [CId] , - gflags :: Map.Map CId String, -- value of a global flag - abstract :: Abstr , - concretes :: Map.Map CId Concr - } - -data Abstr = Abstr { - aflags :: Map.Map CId String, -- value of a flag - funs :: Map.Map CId (Type,Int,[Equation]), -- type, arrity and definition of function - cats :: Map.Map CId [Hypo], -- context of a cat - catfuns :: Map.Map CId [CId] -- funs to a cat (redundant, for fast lookup) - } - -data Concr = Concr { - cflags :: Map.Map CId String, -- value of a flag - lins :: Map.Map CId Term, -- lin of a fun - opers :: Map.Map CId Term, -- oper generated by subex elim - lincats :: Map.Map CId Term, -- lin type of a cat - lindefs :: Map.Map CId Term, -- lin default of a cat - printnames :: Map.Map CId Term, -- printname of a cat or a fun - paramlincats :: Map.Map CId Term, -- lin type of cat, with printable param names - parser :: Maybe ParserInfo -- parser - } - -data Term = - R [Term] - | P Term Term - | S [Term] - | K Tokn - | V Int - | C Int - | F CId - | FV [Term] - | W String Term - | TM String - deriving (Eq,Ord,Show) - -data Tokn = - KS String - | KP [String] [Alternative] - deriving (Eq,Ord,Show) - - --- merge two GFCCs; fails is differens absnames; priority to second arg - -unionPGF :: PGF -> PGF -> PGF -unionPGF one two = case absname one of - n | n == wildCId -> two -- extending empty grammar - | n == absname two -> one { -- extending grammar with same abstract - concretes = Map.union (concretes two) (concretes one), - cncnames = union (cncnames one) (cncnames two) - } - _ -> one -- abstracts don't match ---- print error msg - -emptyPGF :: PGF -emptyPGF = PGF { - absname = wildCId, - cncnames = [] , - gflags = Map.empty, - abstract = error "empty grammar, no abstract", - concretes = Map.empty - } - --- | This is just a 'CId' with the language name. --- A language name is the identifier that you write in the --- top concrete or abstract module in GF after the --- concrete/abstract keyword. Example: --- --- > abstract Lang = ... --- > concrete LangEng of Lang = ... -type Language = CId - -readLanguage :: String -> Maybe Language -readLanguage = readCId - -showLanguage :: Language -> String -showLanguage = showCId diff --git a/src/PGF/Editor.hs b/src/PGF/Editor.hs deleted file mode 100644 index 3f69da170..000000000 --- a/src/PGF/Editor.hs +++ /dev/null @@ -1,241 +0,0 @@ -module PGF.Editor ( - State, -- datatype -- type-annotated possibly open tree with a focus - Dict, -- datatype -- abstract syntax information optimized for editing - Position, -- datatype -- path from top to focus - new, -- :: Type -> State -- create new State - refine, -- :: Dict -> CId -> State -> State -- refine focus with CId - replace, -- :: Dict -> Tree -> State -> State -- replace focus with Tree - delete, -- :: State -> State -- replace focus with ? - goNextMeta, -- :: State -> State -- move focus to next ? node - goNext, -- :: State -> State -- move to next node - goTop, -- :: State -> State -- move focus to the top (=root) - goPosition, -- :: Position -> State -> State -- move focus to given position - mkPosition, -- :: [Int] -> Position -- list of choices (top = []) - showPosition,-- :: Position -> [Int] -- readable position - focusType, -- :: State -> Type -- get the type of focus - stateTree, -- :: State -> Tree -- get the current tree - isMetaFocus, -- :: State -> Bool -- whether focus is ? - allMetas, -- :: State -> [(Position,Type)] -- all ?s and their positions - prState, -- :: State -> String -- print state, focus marked * - refineMenu, -- :: Dict -> State -> [CId] -- get refinement menu - pgf2dict -- :: PGF -> Dict -- create editing Dict from PGF - ) where - -import PGF.Data -import PGF.CId -import qualified Data.Map as M -import Debug.Trace ---- - --- API - -new :: Type -> State -new (DTyp _ t _) = etree2state (uETree t) - -refine :: Dict -> CId -> State -> State -refine dict f = replaceInState (mkRefinement dict f) - -replace :: Dict -> Tree -> State -> State -replace dict t = replaceInState (tree2etree dict t) - -delete :: State -> State -delete s = replaceInState (uETree (typ (tree s))) s - -goNextMeta :: State -> State -goNextMeta s = - if isComplete s then s - else let s1 = goNext s in if isMetaFocus s1 - then s1 else goNextMeta s1 - -isComplete :: State -> Bool -isComplete s = isc (tree s) where - isc t = case atom t of - AMeta _ -> False - ACon _ -> all isc (children t) - -goTop :: State -> State -goTop = navigate (const top) - -goPosition :: [Int] -> State -> State -goPosition p s = s{position = p} - -mkPosition :: [Int] -> Position -mkPosition = id - -refineMenu :: Dict -> State -> [CId] -refineMenu dict s = maybe [] (map fst) $ M.lookup (focusBType s) (refines dict) - -focusType :: State -> Type -focusType s = btype2type (focusBType s) - -stateTree :: State -> Tree -stateTree = etree2tree . tree - -pgf2dict :: PGF -> Dict -pgf2dict pgf = Dict (M.fromAscList fus) refs where - fus = [(f,mkFType ty) | (f,(ty,_)) <- M.toList (funs abs)] - refs = M.fromAscList [(c, fusTo c) | (c,_) <- M.toList (cats abs)] - fusTo c = [(f,ty) | (f,ty@(_,k)) <- fus, k==c] ---- quadratic - mkFType (DTyp hyps c _) = ([k | Hyp _ (DTyp _ k _) <- hyps],c) ----dep types - abs = abstract pgf - -etree2tree :: ETree -> Tree -etree2tree t = case atom t of - ACon f -> Fun f (map etree2tree (children t)) - AMeta i -> Meta i - -tree2etree :: Dict -> Tree -> ETree -tree2etree dict t = case t of - Fun f _ -> annot (look f) t - where - annot (tys,ty) tr = case tr of - Fun f trs -> ETree (ACon f) ty [annt t tr | (t,tr) <- zip tys trs] - Meta i -> ETree (AMeta i) ty [] - annt ty tr = case tr of - Fun _ _ -> tree2etree dict tr - Meta _ -> annot ([],ty) tr - look f = maybe undefined id $ M.lookup f (functs dict) - -prState :: State -> String -prState s = unlines [replicate i ' ' ++ f | (i,f) <- pr [] (tree s)] where - pr i t = - (ind i,prAtom i (atom t)) : concat [pr (sub j i) c | (j,c) <- zip [0..] (children t)] - prAtom i a = prFocus i ++ case a of - ACon f -> prCId f - AMeta i -> "?" ++ show i - prFocus i = if i == position s then "*" else "" - ind i = 2 * length i - sub j i = i ++ [j] - -showPosition :: Position -> [Int] -showPosition = id - -allMetas :: State -> [(Position,Type)] -allMetas s = [(reverse p, btype2type ty) | (p,ty) <- metas [] (tree s)] where - metas p t = - (if isMetaAtom (atom t) then [(p,typ t)] else []) ++ - concat [metas (i:p) u | (i,u) <- zip [0..] (children t)] - ----- Trees and navigation - -data ETree = ETree { - atom :: Atom, - typ :: BType, - children :: [ETree] - } - deriving Show - -data Atom = - ACon CId - | AMeta Int - deriving Show - -btype2type :: BType -> Type -btype2type t = DTyp [] t [] - -uETree :: BType -> ETree -uETree ty = ETree (AMeta 0) ty [] - -data State = State { - position :: Position, - tree :: ETree - } - deriving Show - -type Position = [Int] - -top :: Position -top = [] - -up :: Position -> Position -up p = case p of - _:_ -> init p - _ -> p - -down :: Position -> Position -down = (++[0]) - -left :: Position -> Position -left p = case p of - _:_ | last p > 0 -> init p ++ [last p - 1] - _ -> top - -right :: Position -> Position -right p = case p of - _:_ -> init p ++ [last p + 1] - _ -> top - -etree2state :: ETree -> State -etree2state = State top - -doInState :: (ETree -> ETree) -> State -> State -doInState f s = s{tree = change (position s) (tree s)} where - change p t = case p of - [] -> f t - n:ns -> let (ts1,t0:ts2) = splitAt n (children t) in - t{children = ts1 ++ [change ns t0] ++ ts2} - -subtree :: Position -> ETree -> ETree -subtree p t = case p of - [] -> t - n:ns -> subtree ns (children t !! n) - -focus :: State -> ETree -focus s = subtree (position s) (tree s) - -focusBType :: State -> BType -focusBType s = typ (focus s) - -navigate :: (Position -> Position) -> State -> State -navigate p s = s{position = p (position s)} - --- p is a fix-point aspect of state change -untilFix :: Eq a => (State -> a) -> (State -> Bool) -> (State -> State) -> State -> State -untilFix p b f s = - if b s - then s - else let fs = f s in if p fs == p s - then s - else untilFix p b f fs - -untilPosition :: (State -> Bool) -> (State -> State) -> State -> State -untilPosition = untilFix position - -goNext :: State -> State -goNext s = case focus s of - st | not (null (children st)) -> navigate down s - _ -> findSister s - where - findSister s = case s of - s' | null (position s') -> s' - s' | hasYoungerSisters s' -> navigate right s' - s' -> findSister (navigate up s') - hasYoungerSisters s = case position s of - p@(_:_) -> length (children (focus (navigate up s))) > last p + 1 - _ -> False - -isMetaFocus :: State -> Bool -isMetaFocus s = isMetaAtom (atom (focus s)) - -isMetaAtom :: Atom -> Bool -isMetaAtom a = case a of - AMeta _ -> True - _ -> False - -replaceInState :: ETree -> State -> State -replaceInState t = doInState (const t) - - -------- - -type BType = CId ----dep types -type FType = ([BType],BType) ----dep types - -data Dict = Dict { - functs :: M.Map CId FType, - refines :: M.Map BType [(CId,FType)] - } - -mkRefinement :: Dict -> CId -> ETree -mkRefinement dict f = ETree (ACon f) val (map uETree args) where - (args,val) = maybe undefined id $ M.lookup f (functs dict) - diff --git a/src/PGF/Expr.hs b/src/PGF/Expr.hs deleted file mode 100644 index cf0cb79aa..000000000 --- a/src/PGF/Expr.hs +++ /dev/null @@ -1,355 +0,0 @@ -module PGF.Expr(Tree, BindType(..), Expr(..), Literal(..), Patt(..), Equation(..), - readExpr, showExpr, pExpr, pBinds, ppExpr, ppPatt, - - mkApp, unApp, - mkStr, unStr, - mkInt, unInt, - mkDouble, unDouble, - mkMeta, isMeta, - - normalForm, - - -- needed in the typechecker - Value(..), Env, Funs, eval, apply, - - MetaId, - - -- helpers - pMeta,pStr,pArg,pLit,freshName,ppMeta,ppLit,ppParens - ) where - -import PGF.CId -import PGF.Type - -import Data.Char -import Data.Maybe -import Data.List as List -import Data.Map as Map hiding (showTree) -import Control.Monad -import qualified Text.PrettyPrint as PP -import qualified Text.ParserCombinators.ReadP as RP - -data Literal = - LStr String -- ^ string constant - | LInt Integer -- ^ integer constant - | LFlt Double -- ^ floating point constant - deriving (Eq,Ord,Show) - -type MetaId = Int - -data BindType = - Explicit - | Implicit - deriving (Eq,Ord,Show) - --- | Tree is the abstract syntax representation of a given sentence --- in some concrete syntax. Technically 'Tree' is a type synonym --- of 'Expr'. -type Tree = Expr - --- | An expression in the abstract syntax of the grammar. It could be --- both parameter of a dependent type or an abstract syntax tree for --- for some sentence. -data Expr = - EAbs BindType CId Expr -- ^ lambda abstraction - | EApp Expr Expr -- ^ application - | ELit Literal -- ^ literal - | EMeta {-# UNPACK #-} !MetaId -- ^ meta variable - | EFun CId -- ^ function or data constructor - | EVar {-# UNPACK #-} !Int -- ^ variable with de Bruijn index - | ETyped Expr Type -- ^ local type signature - | EImplArg Expr -- ^ implicit argument in expression - deriving (Eq,Ord,Show) - --- | The pattern is used to define equations in the abstract syntax of the grammar. -data Patt = - PApp CId [Patt] -- ^ application. The identifier should be constructor i.e. defined with 'data' - | PLit Literal -- ^ literal - | PVar CId -- ^ variable - | PWild -- ^ wildcard - | PImplArg Patt -- ^ implicit argument in pattern - deriving (Eq,Ord) - --- | The equation is used to define lambda function as a sequence --- of equations with pattern matching. The list of 'Expr' represents --- the patterns and the second 'Expr' is the function body for this --- equation. -data Equation = - Equ [Patt] Expr - deriving (Eq,Ord) - --- | parses 'String' as an expression -readExpr :: String -> Maybe Expr -readExpr s = case [x | (x,cs) <- RP.readP_to_S pExpr s, all isSpace cs] of - [x] -> Just x - _ -> Nothing - --- | renders expression as 'String'. The list --- of identifiers is the list of all free variables --- in the expression in order reverse to the order --- of binding. -showExpr :: [CId] -> Expr -> String -showExpr vars = PP.render . ppExpr 0 vars - -instance Read Expr where - readsPrec _ = RP.readP_to_S pExpr - --- | Constructs an expression by applying a function to a list of expressions -mkApp :: CId -> [Expr] -> Expr -mkApp f es = foldl EApp (EFun f) es - --- | Decomposes an expression into application of function -unApp :: Expr -> Maybe (CId,[Expr]) -unApp = extract [] - where - extract es (EFun f) = Just (f,es) - extract es (EApp e1 e2) = extract (e2:es) e1 - extract es _ = Nothing - --- | Constructs an expression from string literal -mkStr :: String -> Expr -mkStr s = ELit (LStr s) - --- | Decomposes an expression into string literal -unStr :: Expr -> Maybe String -unStr (ELit (LStr s)) = Just s -unStr _ = Nothing - --- | Constructs an expression from integer literal -mkInt :: Integer -> Expr -mkInt i = ELit (LInt i) - --- | Decomposes an expression into integer literal -unInt :: Expr -> Maybe Integer -unInt (ELit (LInt i)) = Just i -unInt _ = Nothing - --- | Constructs an expression from real number literal -mkDouble :: Double -> Expr -mkDouble f = ELit (LFlt f) - --- | Decomposes an expression into real number literal -unDouble :: Expr -> Maybe Double -unDouble (ELit (LFlt f)) = Just f -unDouble _ = Nothing - --- | Constructs an expression which is meta variable -mkMeta :: Expr -mkMeta = EMeta 0 - --- | Checks whether an expression is a meta variable -isMeta :: Expr -> Bool -isMeta (EMeta _) = True -isMeta _ = False - ------------------------------------------------------ --- Parsing ------------------------------------------------------ - -pExpr :: RP.ReadP Expr -pExpr = RP.skipSpaces >> (pAbs RP.<++ pTerm) - where - pTerm = do f <- pFactor - RP.skipSpaces - as <- RP.sepBy pArg RP.skipSpaces - return (foldl EApp f as) - - pAbs = do xs <- RP.between (RP.char '\\') (RP.skipSpaces >> RP.string "->") pBinds - e <- pExpr - return (foldr (\(b,x) e -> EAbs b x e) e xs) - -pBinds :: RP.ReadP [(BindType,CId)] -pBinds = do xss <- RP.sepBy1 (RP.skipSpaces >> pBind) (RP.skipSpaces >> RP.char ',') - return (concat xss) - where - pCIdOrWild = pCId `mplus` (RP.char '_' >> return wildCId) - - pBind = - do x <- pCIdOrWild - return [(Explicit,x)] - `mplus` - RP.between (RP.char '{') - (RP.skipSpaces >> RP.char '}') - (RP.sepBy1 (RP.skipSpaces >> pCIdOrWild >>= \id -> return (Implicit,id)) (RP.skipSpaces >> RP.char ',')) - -pArg = fmap EImplArg (RP.between (RP.char '{') (RP.char '}') pExpr) - RP.<++ - pFactor - -pFactor = fmap EFun pCId - RP.<++ fmap ELit pLit - RP.<++ fmap EMeta pMeta - RP.<++ RP.between (RP.char '(') (RP.char ')') pExpr - RP.<++ RP.between (RP.char '<') (RP.char '>') pTyped - -pTyped = do RP.skipSpaces - e <- pExpr - RP.skipSpaces - RP.char ':' - RP.skipSpaces - ty <- pType - return (ETyped e ty) - -pMeta = do RP.char '?' - return 0 - -pLit :: RP.ReadP Literal -pLit = pNum RP.<++ liftM LStr pStr - -pNum = do x <- RP.munch1 isDigit - ((RP.char '.' >> RP.munch1 isDigit >>= \y -> return (LFlt (read (x++"."++y)))) - RP.<++ - (return (LInt (read x)))) - -pStr = RP.char '"' >> (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"')) - where - pEsc = RP.char '\\' >> RP.get - - ------------------------------------------------------ --- Printing ------------------------------------------------------ - -ppExpr :: Int -> [CId] -> Expr -> PP.Doc -ppExpr d scope (EAbs b x e) = let (bs,xs,e1) = getVars [] [] (EAbs b x e) - in ppParens (d > 1) (PP.char '\\' PP.<> - PP.hsep (PP.punctuate PP.comma (reverse (List.zipWith ppBind bs xs))) PP.<+> - PP.text "->" PP.<+> - ppExpr 1 (xs++scope) e1) - where - getVars bs xs (EAbs b x e) = getVars (b:bs) ((freshName x xs):xs) e - getVars bs xs e = (bs,xs,e) -ppExpr d scope (EApp e1 e2) = ppParens (d > 3) ((ppExpr 3 scope e1) PP.<+> (ppExpr 4 scope e2)) -ppExpr d scope (ELit l) = ppLit l -ppExpr d scope (EMeta n) = ppMeta n -ppExpr d scope (EFun f) = ppCId f -ppExpr d scope (EVar i) = ppCId (scope !! i) -ppExpr d scope (ETyped e ty)= PP.char '<' PP.<> ppExpr 0 scope e PP.<+> PP.colon PP.<+> ppType 0 scope ty PP.<> PP.char '>' -ppExpr d scope (EImplArg e) = PP.braces (ppExpr 0 scope e) - -ppPatt :: Int -> [CId] -> Patt -> ([CId],PP.Doc) -ppPatt d scope (PApp f ps) = let (scope',ds) = mapAccumL (ppPatt 2) scope ps - in (scope',ppParens (not (List.null ps) && d > 1) (ppCId f PP.<+> PP.hsep ds)) -ppPatt d scope (PLit l) = (scope,ppLit l) -ppPatt d scope (PVar f) = (f:scope,ppCId f) -ppPatt d scope PWild = (scope,PP.char '_') -ppPatt d scope (PImplArg p) = let (scope',d) = ppPatt 0 scope p - in (scope',PP.braces d) - -ppBind Explicit x = ppCId x -ppBind Implicit x = PP.braces (ppCId x) - -ppLit (LStr s) = PP.text (show s) -ppLit (LInt n) = PP.integer n -ppLit (LFlt d) = PP.double d - -ppMeta :: MetaId -> PP.Doc -ppMeta n - | n == 0 = PP.char '?' - | otherwise = PP.char '?' PP.<> PP.int n - -ppParens True = PP.parens -ppParens False = id - -freshName :: CId -> [CId] -> CId -freshName x xs0 = loop 1 x - where - xs = wildCId : xs0 - - loop i y - | elem y xs = loop (i+1) (mkCId (show x++show i)) - | otherwise = y - - ------------------------------------------------------ --- Computation ------------------------------------------------------ - --- | Compute an expression to normal form -normalForm :: Funs -> Int -> Env -> Expr -> Expr -normalForm funs k env e = value2expr k (eval funs env e) - where - value2expr i (VApp f vs) = foldl EApp (EFun f) (List.map (value2expr i) vs) - value2expr i (VGen j vs) = foldl EApp (EVar (i-j-1)) (List.map (value2expr i) vs) - value2expr i (VMeta j env vs) = foldl EApp (EMeta j) (List.map (value2expr i) vs) - value2expr i (VSusp j env vs k) = value2expr i (k (VGen j vs)) - value2expr i (VLit l) = ELit l - value2expr i (VClosure env (EAbs b x e)) = EAbs b x (value2expr (i+1) (eval funs ((VGen i []):env) e)) - value2expr i (VImplArg v) = EImplArg (value2expr i v) - -data Value - = VApp CId [Value] - | VLit Literal - | VMeta {-# UNPACK #-} !MetaId Env [Value] - | VSusp {-# UNPACK #-} !MetaId Env [Value] (Value -> Value) - | VGen {-# UNPACK #-} !Int [Value] - | VClosure Env Expr - | VImplArg Value - -type Funs = Map.Map CId (Type,Int,[Equation]) -- type and def of a fun -type Env = [Value] - -eval :: Funs -> Env -> Expr -> Value -eval funs env (EVar i) = env !! i -eval funs env (EFun f) = case Map.lookup f funs of - Just (_,a,eqs) -> if a == 0 - then case eqs of - Equ [] e : _ -> eval funs [] e - _ -> VApp f [] - else VApp f [] - Nothing -> error ("unknown function "++showCId f) -eval funs env (EApp e1 e2) = apply funs env e1 [eval funs env e2] -eval funs env (EAbs b x e) = VClosure env (EAbs b x e) -eval funs env (EMeta i) = VMeta i env [] -eval funs env (ELit l) = VLit l -eval funs env (ETyped e _) = eval funs env e -eval funs env (EImplArg e) = VImplArg (eval funs env e) - -apply :: Funs -> Env -> Expr -> [Value] -> Value -apply funs env e [] = eval funs env e -apply funs env (EVar i) vs = applyValue funs (env !! i) vs -apply funs env (EFun f) vs = case Map.lookup f funs of - Just (_,a,eqs) -> if a <= length vs - then let (as,vs') = splitAt a vs - in match funs f eqs as vs' - else VApp f vs - Nothing -> error ("unknown function "++showCId f) -apply funs env (EApp e1 e2) vs = apply funs env e1 (eval funs env e2 : vs) -apply funs env (EAbs _ x e) (v:vs) = apply funs (v:env) e vs -apply funs env (EMeta i) vs = VMeta i env vs -apply funs env (ELit l) vs = error "literal of function type" -apply funs env (ETyped e _) vs = apply funs env e vs -apply funs env (EImplArg _) vs = error "implicit argument in function position" - -applyValue funs v [] = v -applyValue funs (VApp f vs0) vs = apply funs [] (EFun f) (vs0++vs) -applyValue funs (VLit _) vs = error "literal of function type" -applyValue funs (VMeta i env vs0) vs = VMeta i env (vs0++vs) -applyValue funs (VGen i vs0) vs = VGen i (vs0++vs) -applyValue funs (VSusp i env vs0 k) vs = VSusp i env vs0 (\v -> applyValue funs (k v) vs) -applyValue funs (VClosure env (EAbs b x e)) (v:vs) = apply funs (v:env) e vs -applyValue funs (VImplArg _) vs = error "implicit argument in function position" - ------------------------------------------------------ --- Pattern matching ------------------------------------------------------ - -match :: Funs -> CId -> [Equation] -> [Value] -> [Value] -> Value -match funs f eqs as0 vs0 = - case eqs of - [] -> VApp f (as0++vs0) - (Equ ps res):eqs -> tryMatches eqs ps as0 res [] - where - tryMatches eqs [] [] res env = apply funs env res vs0 - tryMatches eqs (p:ps) (a:as) res env = tryMatch p a env - where - tryMatch (PVar x ) (v ) env = tryMatches eqs ps as res (v:env) - tryMatch (PWild ) (_ ) env = tryMatches eqs ps as res env - tryMatch (p ) (VMeta i envi vs ) env = VSusp i envi vs (\v -> tryMatch p v env) - tryMatch (p ) (VGen i vs ) env = VApp f (as0++vs0) - tryMatch (p ) (VSusp i envi vs k) env = VSusp i envi vs (\v -> tryMatch p (k v) env) - tryMatch (PApp f1 ps1) (VApp f2 vs2 ) env | f1 == f2 = tryMatches eqs (ps1++ps) (vs2++as) res env - tryMatch (PLit l1 ) (VLit l2 ) env | l1 == l2 = tryMatches eqs ps as res env - tryMatch (PImplArg p ) (VImplArg v ) env = tryMatch p v env - tryMatch _ _ env = match funs f eqs as0 vs0 - diff --git a/src/PGF/Expr.hs-boot b/src/PGF/Expr.hs-boot deleted file mode 100644 index 34a62a410..000000000 --- a/src/PGF/Expr.hs-boot +++ /dev/null @@ -1,28 +0,0 @@ -module PGF.Expr where - -import PGF.CId -import qualified Text.PrettyPrint as PP -import qualified Text.ParserCombinators.ReadP as RP - -data Expr - -instance Eq Expr -instance Ord Expr -instance Show Expr - - -data BindType = Explicit | Implicit - -instance Eq BindType -instance Ord BindType -instance Show BindType - - -pArg :: RP.ReadP Expr -pBinds :: RP.ReadP [(BindType,CId)] - -ppExpr :: Int -> [CId] -> Expr -> PP.Doc - -freshName :: CId -> [CId] -> CId - -ppParens :: Bool -> PP.Doc -> PP.Doc diff --git a/src/PGF/Generate.hs b/src/PGF/Generate.hs deleted file mode 100644 index 5add00a78..000000000 --- a/src/PGF/Generate.hs +++ /dev/null @@ -1,66 +0,0 @@ -module PGF.Generate where - -import PGF.CId -import PGF.Data -import PGF.Macros -import PGF.TypeCheck - -import qualified Data.Map as M -import System.Random - --- generate an infinite list of trees exhaustively -generate :: PGF -> Type -> Maybe Int -> [Expr] -generate pgf ty@(DTyp _ cat _) dp = filter (\e -> case checkExpr pgf e ty of - Left _ -> False - Right _ -> True ) - (concatMap (\i -> gener i cat) depths) - where - gener 0 c = [EFun f | (f, ([],_)) <- fns c] - gener i c = [ - tr | - (f, (cs,_)) <- fns c, - let alts = map (gener (i-1)) cs, - ts <- combinations alts, - let tr = foldl EApp (EFun f) ts, - depth tr >= i - ] - fns c = [(f,catSkeleton ty) | (f,ty) <- functionsToCat pgf c] - depths = maybe [0 ..] (\d -> [0..d]) dp - --- generate an infinite list of trees randomly -genRandom :: StdGen -> PGF -> Type -> [Expr] -genRandom gen pgf ty@(DTyp _ cat _) = filter (\e -> case checkExpr pgf e ty of - Left _ -> False - Right _ -> True ) - (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 | cid == cidString = (ELit (LStr "foo"), 1) - gett ds cid | cid == cidInt = (ELit (LInt 12345), 1) - gett ds cid | cid == cidFloat = (ELit (LFlt 12345), 1) - gett [] _ = (ELit (LStr "TIMEOUT"), 1) ---- - gett ds cat = case fns cat of - [] -> (EMeta 0,1) - fs -> let - d:ds2 = ds - (f,args) = getf d fs - (ts,k) = getts ds2 args - in (foldl EApp (EFun 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 pgf cat] diff --git a/src/PGF/Linearize.hs b/src/PGF/Linearize.hs deleted file mode 100644 index fdd4cecb5..000000000 --- a/src/PGF/Linearize.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE ParallelListComp #-} -module PGF.Linearize - (linearizes,realize,realizes,linTree, linTreeMark,linearizesMark) where - -import PGF.CId -import PGF.Data -import PGF.Macros -import PGF.Tree - -import Control.Monad -import qualified Data.Map as Map -import Data.List - -import Debug.Trace - --- linearization and computation of concrete PGF Terms - -linearizes :: PGF -> CId -> Expr -> [String] -linearizes pgf lang = realizes . linTree pgf lang - -realize :: Term -> String -realize = concat . take 1 . realizes - -realizes :: Term -> [String] -realizes = map (unwords . untokn) . realizest - -realizest :: Term -> [[Tokn]] -realizest trm = case trm of - R ts -> realizest (ts !! 0) - S ss -> map concat $ combinations $ map realizest ss - K t -> [[t]] - W s t -> [[KS (s ++ r)] | [KS r] <- realizest t] - FV ts -> concatMap realizest ts - TM s -> [[KS s]] - _ -> [[KS $ "REALIZE_ERROR " ++ show trm]] ---- debug - -untokn :: [Tokn] -> [String] -untokn ts = case ts of - KP d _ : [] -> d - KP d vs : ws -> let ss@(s:_) = untokn ws in sel d vs s ++ ss - KS s : ws -> s : untokn ws - [] -> [] - where - sel d vs w = case [v | Alt v cs <- vs, any (\c -> isPrefixOf c w) cs] of - v:_ -> v - _ -> d - --- Lifts all variants to the top level (except those in macros). -liftVariants :: Term -> [Term] -liftVariants = f - where - f (R ts) = liftM R $ mapM f ts - f (P t1 t2) = liftM2 P (f t1) (f t2) - f (S ts) = liftM S $ mapM f ts - f (FV ts) = ts >>= f - f (W s t) = liftM (W s) $ f t - f t = return t - -linTree :: PGF -> CId -> Expr -> Term -linTree pgf lang e = lin (expr2tree e) Nothing - where - cnc = lookMap (error "no lang") lang (concretes pgf) - - lin (Abs xs e ) mty = case lin e Nothing of - R ts -> R $ ts ++ (Data.List.map (kks . showCId . snd) xs) - TM s -> R $ (TM s) : (Data.List.map (kks . showCId . snd) xs) - lin (Fun fun es) mty = case Map.lookup fun (funs (abstract pgf)) of - Just (DTyp hyps _ _,_,_) -> let argVariants = sequence [liftVariants (lin e (Just ty)) | e <- es | (_,_,ty) <- hyps] - in variants [compute pgf lang args $ lookMap tm0 fun (lins cnc) | args <- argVariants] - Nothing -> tm0 - lin (Lit (LStr s)) mty = R [kks (show s)] -- quoted - lin (Lit (LInt i)) mty = R [kks (show i)] - lin (Lit (LFlt d)) mty = R [kks (show d)] - lin (Var x) mty = case mty of - Just (DTyp _ cat _) -> compute pgf lang [K (KS (showCId x))] (lookMap tm0 cat (lindefs cnc)) - Nothing -> TM (showCId x) - lin (Meta i) mty = case mty of - Just (DTyp _ cat _) -> compute pgf lang [K (KS (show i))] (lookMap tm0 cat (lindefs cnc)) - Nothing -> TM (show i) - -variants :: [Term] -> Term -variants ts = case ts of - [t] -> t - _ -> FV ts - -unvariants :: Term -> [Term] -unvariants t = case t of - FV ts -> ts - _ -> [t] - -compute :: PGF -> CId -> [Term] -> Term -> Term -compute pgf 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 i -- already computed - F c -> comp $ look c -- not computed (if contains argvar) - FV ts -> FV $ map comp ts - S ts -> S $ filter (/= S []) $ map comp ts - _ -> trm - - look = lookOper pgf lang - - idx xs i = if i > length xs - 1 - then trace - ("too large " ++ show i ++ " for\n" ++ unlines (map show xs) ++ "\n") tm0 - else xs !! i - - proj r p = case (r,p) of - (_, FV ts) -> FV $ map (proj r) ts - (FV ts, _ ) -> FV $ 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 - _ -> error ("ERROR in grammar compiler: string from "++ show t) "ERR" - - getIndex t = case t of - C i -> i - 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 - TM s -> TM s - _ -> error ("ERROR in grammar compiler: field from " ++ show t) t - ---------- --- markup with tree positions - -linearizesMark :: PGF -> CId -> Expr -> [String] -linearizesMark pgf lang = realizes . linTreeMark pgf lang - -linTreeMark :: PGF -> CId -> Expr -> Term -linTreeMark pgf lang = lin [] . expr2tree - where - lin p (Abs xs e ) = case lin p e of - R ts -> R $ ts ++ (Data.List.map (kks . showCId . snd) xs) - TM s -> R $ (TM s) : (Data.List.map (kks . showCId . snd) xs) - lin p (Fun fun es) = - let argVariants = - mapM (\ (i,e) -> liftVariants $ lin (sub p i) e) (zip [0..] es) - in variants [mark (fun,p) $ compute pgf lang args $ look fun | - args <- argVariants] - lin p (Lit (LStr s)) = mark p $ R [kks (show s)] -- quoted - lin p (Lit (LInt i)) = mark p $ R [kks (show i)] - lin p (Lit (LFlt d)) = mark p $ R [kks (show d)] - lin p (Var x) = mark p $ TM (showCId x) - lin p (Meta i) = mark p $ TM (show i) - - look = lookLin pgf lang - - mark :: Show a => a -> Term -> Term - mark p t = case t of - R ts -> R $ map (mark p) ts - FV ts -> R $ map (mark p) ts - S ts -> S $ bracket p ts - K s -> S $ bracket p [t] - W s (R ts) -> R [mark p $ kks (s ++ u) | K (KS u) <- ts] - _ -> t - -- otherwise in normal form - - bracket p ts = [kks ("("++show p)] ++ ts ++ [kks ")"] - sub p i = p ++ [i] diff --git a/src/PGF/Macros.hs b/src/PGF/Macros.hs deleted file mode 100644 index af25de025..000000000 --- a/src/PGF/Macros.hs +++ /dev/null @@ -1,154 +0,0 @@ -module PGF.Macros where - -import PGF.CId -import PGF.Data -import Control.Monad -import qualified Data.Map as Map -import qualified Data.Array as Array -import Data.Maybe -import Data.List - --- operations for manipulating PGF grammars and objects - -mapConcretes :: (Concr -> Concr) -> PGF -> PGF -mapConcretes f pgf = pgf { concretes = Map.map f (concretes pgf) } - -lookLin :: PGF -> CId -> CId -> Term -lookLin pgf lang fun = - lookMap tm0 fun $ lins $ lookMap (error "no lang") lang $ concretes pgf - -lookOper :: PGF -> CId -> CId -> Term -lookOper pgf lang fun = - lookMap tm0 fun $ opers $ lookMap (error "no lang") lang $ concretes pgf - -lookLincat :: PGF -> CId -> CId -> Term -lookLincat pgf lang fun = - lookMap tm0 fun $ lincats $ lookMap (error "no lang") lang $ concretes pgf - -lookParamLincat :: PGF -> CId -> CId -> Term -lookParamLincat pgf lang fun = - lookMap tm0 fun $ paramlincats $ lookMap (error "no lang") lang $ concretes pgf - -lookPrintName :: PGF -> CId -> CId -> Term -lookPrintName pgf lang fun = - lookMap tm0 fun $ printnames $ lookMap (error "no lang") lang $ concretes pgf - -lookType :: PGF -> CId -> Type -lookType pgf f = - case lookMap (error $ "lookType " ++ show f) f (funs (abstract pgf)) of - (ty,_,_) -> ty - -lookDef :: PGF -> CId -> [Equation] -lookDef pgf f = - case lookMap (error $ "lookDef " ++ show f) f (funs (abstract pgf)) of - (_,a,eqs) -> eqs - -isData :: PGF -> CId -> Bool -isData pgf f = - case Map.lookup f (funs (abstract pgf)) of - Just (_,_,[]) -> True -- the encoding of data constrs - _ -> False - -lookValCat :: PGF -> CId -> CId -lookValCat pgf = valCat . lookType pgf - -lookParser :: PGF -> CId -> Maybe ParserInfo -lookParser pgf lang = Map.lookup lang (concretes pgf) >>= parser - -lookStartCat :: PGF -> CId -lookStartCat pgf = mkCId $ fromMaybe "S" $ msum $ Data.List.map (Map.lookup (mkCId "startcat")) - [gflags pgf, aflags (abstract pgf)] - -lookGlobalFlag :: PGF -> CId -> String -lookGlobalFlag pgf f = - lookMap "?" f (gflags pgf) - -lookAbsFlag :: PGF -> CId -> String -lookAbsFlag pgf f = - lookMap "?" f (aflags (abstract pgf)) - -lookConcr :: PGF -> CId -> Concr -lookConcr pgf cnc = - lookMap (error $ "Missing concrete syntax: " ++ showCId cnc) cnc $ concretes pgf - -lookConcrFlag :: PGF -> CId -> CId -> Maybe String -lookConcrFlag pgf lang f = Map.lookup f $ cflags $ lookConcr pgf lang - -functionsToCat :: PGF -> CId -> [(CId,Type)] -functionsToCat pgf cat = - [(f,ty) | f <- fs, Just (ty,_,_) <- [Map.lookup f $ funs $ abstract pgf]] - where - fs = lookMap [] cat $ catfuns $ abstract pgf - -missingLins :: PGF -> CId -> [CId] -missingLins pgf lang = [c | c <- fs, not (hasl c)] where - fs = Map.keys $ funs $ abstract pgf - hasl = hasLin pgf lang - -hasLin :: PGF -> CId -> CId -> Bool -hasLin pgf lang f = Map.member f $ lins $ lookConcr pgf lang - -restrictPGF :: (CId -> Bool) -> PGF -> PGF -restrictPGF cond pgf = pgf { - abstract = abstr { - funs = restrict $ funs $ abstr, - cats = restrict $ cats $ abstr - } - } ---- restrict concrs also, might be needed - where - restrict = Map.filterWithKey (\c _ -> cond c) - abstr = abstract pgf - -depth :: Expr -> Int -depth (EAbs _ _ t) = depth t -depth (EApp e1 e2) = max (depth e1) (depth e2) + 1 -depth _ = 1 - -cftype :: [CId] -> CId -> Type -cftype args val = DTyp [(Explicit,wildCId,cftype [] arg) | arg <- args] val [] - -typeOfHypo :: Hypo -> Type -typeOfHypo (_,_,ty) = ty - -catSkeleton :: Type -> ([CId],CId) -catSkeleton ty = case ty of - DTyp hyps val _ -> ([valCat (typeOfHypo h) | h <- hyps],val) - -typeSkeleton :: Type -> ([(Int,CId)],CId) -typeSkeleton ty = case ty of - DTyp hyps val _ -> ([(contextLength ty, valCat ty) | h <- hyps, let ty = typeOfHypo h],val) - -valCat :: Type -> CId -valCat ty = case ty of - DTyp _ val _ -> val - -contextLength :: Type -> Int -contextLength ty = case ty of - DTyp hyps _ _ -> length hyps - -term0 :: CId -> Term -term0 = TM . showCId - -tm0 :: Term -tm0 = TM "?" - -kks :: String -> Term -kks = K . KS - --- lookup with default value -lookMap :: (Show i, Ord i) => a -> i -> Map.Map i a -> a -lookMap d c m = Map.findWithDefault d c m - ---- from Operations -combinations :: [[a]] -> [[a]] -combinations t = case t of - [] -> [[]] - aa:uu -> [a:u | a <- aa, u <- combinations uu] - -isLiteralCat :: CId -> Bool -isLiteralCat = (`elem` [cidString, cidFloat, cidInt, cidVar]) - -cidString = mkCId "String" -cidInt = mkCId "Int" -cidFloat = mkCId "Float" -cidVar = mkCId "__gfVar" diff --git a/src/PGF/Morphology.hs b/src/PGF/Morphology.hs deleted file mode 100644 index 9eee71a97..000000000 --- a/src/PGF/Morphology.hs +++ /dev/null @@ -1,26 +0,0 @@ -module PGF.Morphology(Lemma,Analysis,Morpho, - buildMorpho, - lookupMorpho,fullFormLexicon) where - -import PGF.ShowLinearize (collectWords) -import PGF.Data -import PGF.CId - -import qualified Data.Map as Map -import Data.List (intersperse) - --- these 4 definitions depend on the datastructure used - -type Lemma = CId -type Analysis = String - -newtype Morpho = Morpho (Map.Map String [(Lemma,Analysis)]) - -buildMorpho :: PGF -> Language -> Morpho -buildMorpho pgf lang = Morpho (Map.fromListWith (++) (collectWords pgf lang)) - -lookupMorpho :: Morpho -> String -> [(Lemma,Analysis)] -lookupMorpho (Morpho mo) s = maybe [] id $ Map.lookup s mo - -fullFormLexicon :: Morpho -> [(String,[(Lemma,Analysis)])] -fullFormLexicon (Morpho mo) = Map.toList mo diff --git a/src/PGF/PMCFG.hs b/src/PGF/PMCFG.hs deleted file mode 100644 index c657e3d17..000000000 --- a/src/PGF/PMCFG.hs +++ /dev/null @@ -1,119 +0,0 @@ -module PGF.PMCFG where - -import PGF.CId -import PGF.Expr - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.IntMap as IntMap -import Data.Array.IArray -import Data.Array.Unboxed -import Text.PrettyPrint - -type FCat = Int -type FIndex = Int -type FPointPos = Int -data FSymbol - = FSymCat {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex - | FSymLit {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex - | FSymKS [String] - | FSymKP [String] [Alternative] - deriving (Eq,Ord,Show) -type Profile = [Int] -data Production - = FApply {-# UNPACK #-} !FunId [FCat] - | FCoerce {-# UNPACK #-} !FCat - | FConst Expr [String] - deriving (Eq,Ord,Show) -data FFun = FFun CId [Profile] {-# UNPACK #-} !(UArray FIndex SeqId) deriving (Eq,Ord,Show) -type FSeq = Array FPointPos FSymbol -type FunId = Int -type SeqId = Int - -data Alternative = - Alt [String] [String] - deriving (Eq,Ord,Show) - -data ParserInfo - = ParserInfo { functions :: Array FunId FFun - , sequences :: Array SeqId FSeq - , productions0:: IntMap.IntMap (Set.Set Production) -- this are the original productions as they are loaded from the PGF file - , productions :: IntMap.IntMap (Set.Set Production) -- this are the productions after the filtering for useless productions - , startCats :: Map.Map CId [FCat] - , totalCats :: {-# UNPACK #-} !FCat - } - - -fcatString, fcatInt, fcatFloat, fcatVar :: Int -fcatString = (-1) -fcatInt = (-2) -fcatFloat = (-3) -fcatVar = (-4) - -isLiteralFCat :: FCat -> Bool -isLiteralFCat = (`elem` [fcatString, fcatInt, fcatFloat, fcatVar]) - -ppPMCFG :: ParserInfo -> Doc -ppPMCFG pinfo = - text "productions" $$ - nest 2 (vcat [ppProduction (fcat,prod) | (fcat,set) <- IntMap.toList (productions pinfo), prod <- Set.toList set]) $$ - text "functions" $$ - nest 2 (vcat (map ppFun (assocs (functions pinfo)))) $$ - text "sequences" $$ - nest 2 (vcat (map ppSeq (assocs (sequences pinfo)))) $$ - text "startcats" $$ - nest 2 (vcat (map ppStartCat (Map.toList (startCats pinfo)))) - -ppProduction (fcat,FApply funid args) = - ppFCat fcat <+> text "->" <+> ppFunId funid <> brackets (hcat (punctuate comma (map ppFCat args))) -ppProduction (fcat,FCoerce arg) = - ppFCat fcat <+> text "->" <+> char '_' <> brackets (ppFCat arg) -ppProduction (fcat,FConst _ ss) = - ppFCat fcat <+> text "->" <+> ppStrs ss - -ppFun (funid,FFun fun _ arr) = - ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (ppCId fun) - -ppSeq (seqid,seq) = - ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol (elems seq)) - -ppStartCat (id,fcats) = - ppCId id <+> text ":=" <+> brackets (hcat (punctuate comma (map ppFCat fcats))) - -ppSymbol (FSymCat d r) = char '<' <> int d <> comma <> int r <> char '>' -ppSymbol (FSymLit d r) = char '<' <> int d <> comma <> int r <> char '>' -ppSymbol (FSymKS ts) = ppStrs ts -ppSymbol (FSymKP ts alts) = text "pre" <+> braces (hsep (punctuate semi (ppStrs ts : map ppAlt alts))) - -ppAlt (Alt ts ps) = ppStrs ts <+> char '/' <+> hsep (map (doubleQuotes . text) ps) - -ppStrs ss = doubleQuotes (hsep (map text ss)) - -ppFCat fcat - | fcat == fcatString = text "CString" - | fcat == fcatInt = text "CInt" - | fcat == fcatFloat = text "CFloat" - | fcat == fcatVar = text "CVar" - | otherwise = char 'C' <> int fcat - -ppFunId funid = char 'F' <> int funid -ppSeqId seqid = char 'S' <> int seqid - - -filterProductions = closure - where - closure prods0 - | IntMap.size prods == IntMap.size prods0 = prods - | otherwise = closure prods - where - prods = IntMap.mapMaybe (filterProdSet prods0) prods0 - - filterProdSet prods set0 - | Set.null set = Nothing - | otherwise = Just set - where - set = Set.filter (filterRule prods) set0 - - filterRule prods (FApply funid args) = all (\fcat -> isLiteralFCat fcat || IntMap.member fcat prods) args - filterRule prods (FCoerce fcat) = isLiteralFCat fcat || IntMap.member fcat prods - filterRule prods _ = True diff --git a/src/PGF/Paraphrase.hs b/src/PGF/Paraphrase.hs deleted file mode 100644 index 58d15b2e8..000000000 --- a/src/PGF/Paraphrase.hs +++ /dev/null @@ -1,112 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Paraphrase --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- Generate parapharases with def definitions. ------------------------------------------------------------------------------ - -module PGF.Paraphrase ( - paraphrase, - paraphraseN - ) where - -import PGF.Data -import PGF.Tree -import PGF.Macros (lookDef,isData) -import PGF.CId - -import Data.List (nub,sort,group) -import qualified Data.Map as Map - -import Debug.Trace ---- - -paraphrase :: PGF -> Expr -> [Expr] -paraphrase pgf = nub . paraphraseN 2 pgf - -paraphraseN :: Int -> PGF -> Expr -> [Expr] -paraphraseN i pgf = map tree2expr . paraphraseN' i pgf . expr2tree - -paraphraseN' :: Int -> PGF -> Tree -> [Tree] -paraphraseN' 0 _ t = [t] -paraphraseN' i pgf t = - step i t ++ [Fun g ts' | Fun g ts <- step (i-1) t, ts' <- sequence (map par ts)] - where - par = paraphraseN' (i-1) pgf - step 0 t = [t] - step i t = let stept = step (i-1) t in stept ++ concat [def u | u <- stept] - def = fromDef pgf - -fromDef :: PGF -> Tree -> [Tree] -fromDef pgf t@(Fun f ts) = defDown t ++ defUp t where - defDown t = [subst g u | let equ = equsFrom f, (u,g) <- match equ ts, trequ "U" f equ] - defUp t = [subst g u | equ <- equsTo f, (u,g) <- match [equ] ts, trequ "D" f equ] - - equsFrom f = [(ps,d) | Just equs <- [lookup f equss], (Fun _ ps,d) <- equs] - - equsTo f = [c | (_,equs) <- equss, c <- casesTo f equs] - - casesTo f equs = - [(ps,p) | (p,d@(Fun g ps)) <- equs, g==f, - isClosed d || (length equs == 1 && isLinear d)] - - equss = [(f,[(Fun f (map patt2tree ps), expr2tree d) | (Equ ps d) <- eqs]) | - (f,(_,_,eqs)) <- Map.assocs (funs (abstract pgf)), not (null eqs)] - - trequ s f e = True ----trace (s ++ ": " ++ show f ++ " " ++ show e) True - -subst :: Subst -> Tree -> Tree -subst g e = case e of - Fun f ts -> Fun f (map substg ts) - Var x -> maybe e id $ lookup x g - _ -> e - where - substg = subst g - -type Subst = [(CId,Tree)] - --- this applies to pattern, hence don't need to consider abstractions -isClosed :: Tree -> Bool -isClosed t = case t of - Fun _ ts -> all isClosed ts - Var _ -> False - _ -> True - --- this applies to pattern, hence don't need to consider abstractions -isLinear :: Tree -> Bool -isLinear = nodup . vars where - vars t = case t of - Fun _ ts -> concatMap vars ts - Var x -> [x] - _ -> [] - nodup = all ((<2) . length) . group . sort - - -match :: [([Tree],Tree)] -> [Tree] -> [(Tree, Subst)] -match cases terms = case cases of - [] -> [] - (patts,_):_ | length patts /= length terms -> [] - (patts,val):cc -> case mapM tryMatch (zip patts terms) of - Just substs -> return (val, concat substs) - _ -> match cc terms - where - tryMatch (p,t) = case (p, t) of - (Var x, _) | notMeta t -> return [(x,t)] - (Fun p pp, Fun f tt) | p == f && length pp == length tt -> do - matches <- mapM tryMatch (zip pp tt) - return (concat matches) - _ -> if p==t then return [] else Nothing - - notMeta e = case e of - Meta _ -> False - Fun f ts -> all notMeta ts - _ -> True - --- | Converts a pattern to tree. -patt2tree :: Patt -> Tree -patt2tree (PApp f ps) = Fun f (map patt2tree ps) -patt2tree (PLit l) = Lit l -patt2tree (PVar x) = Var x -patt2tree PWild = Meta 0 diff --git a/src/PGF/Parsing/FCFG/Active.hs b/src/PGF/Parsing/FCFG/Active.hs deleted file mode 100644 index e88926f6e..000000000 --- a/src/PGF/Parsing/FCFG/Active.hs +++ /dev/null @@ -1,205 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- MCFG parsing, the active algorithm ------------------------------------------------------------------------------ - -module PGF.Parsing.FCFG.Active (parse) where - -import GF.Data.Assoc -import GF.Data.SortedList -import GF.Data.Utilities -import qualified GF.Data.MultiMap as MM - -import PGF.CId -import PGF.Data -import PGF.Tree -import PGF.Parsing.FCFG.Utilities -import PGF.BuildParser - -import Control.Monad (guard) - -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import qualified Data.Set as Set -import Data.Array.IArray -import Debug.Trace - ----------------------------------------------------------------------- --- * parsing - -type FToken = String - -makeFinalEdge cat 0 0 = (cat, [EmptyRange]) -makeFinalEdge cat i j = (cat, [makeRange i j]) - --- | the list of categories = possible starting categories -parse :: String -> ParserInfo -> Type -> [FToken] -> [Expr] -parse strategy pinfo (DTyp _ start _) toks = map (tree2expr) . nubsort $ filteredForests >>= forest2trees - where - inTokens = input toks - starts = Map.findWithDefault [] start (startCats pinfo) - schart = xchart2syntaxchart chart pinfo - (i,j) = inputBounds inTokens - finalEdges = [makeFinalEdge cat i j | cat <- starts] - forests = chart2forests schart (const False) finalEdges - filteredForests = forests >>= applyProfileToForest - - pinfoex = buildParserInfo pinfo - - chart = process strategy pinfo pinfoex inTokens axioms emptyXChart - axioms | isBU strategy = literals pinfoex inTokens ++ initialBU pinfo pinfoex inTokens - | isTD strategy = literals pinfoex inTokens ++ initialTD pinfo starts inTokens - -isBU s = s=="b" -isTD s = s=="t" - --- used in prediction -emptyChildren :: FunId -> [FCat] -> SyntaxNode FunId RangeRec -emptyChildren ruleid args = SNode ruleid (replicate (length args) []) - - -process :: String -> ParserInfo -> ParserInfoEx -> Input FToken -> [Item] -> XChart FCat -> XChart FCat -process strategy pinfo pinfoex toks [] chart = chart -process strategy pinfo pinfoex toks (item:items) chart = process strategy pinfo pinfoex toks items $! univRule item chart - where - univRule item@(Active found rng lbl ppos node@(SNode ruleid recs) args cat) chart - | inRange (bounds lin) ppos = - case lin ! ppos of - FSymCat d r -> let c = args !! d - in 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 (Active found rng lbl (ppos+1) (SNode ruleid (updateNth (const found') d recs)) args cat) - ++ - do guard (isTD strategy) - (ruleid,args) <- topdownRules pinfo c - return (Active [] EmptyRange 0 0 (emptyChildren ruleid args) args c) - in process strategy pinfo pinfoex toks items chart - found' -> let items = do rng <- concatRange rng (found' !! r) - return (Active found rng lbl (ppos+1) node args cat) - in process strategy pinfo pinfoex toks items chart - FSymKS [tok] - -> let items = do t_rng <- inputToken toks ? tok - rng' <- concatRange rng t_rng - return (Active found rng' lbl (ppos+1) node args cat) - in process strategy pinfo pinfoex toks items chart - | otherwise = - if inRange (bounds lins) (lbl+1) - then univRule (Active (rng:found) EmptyRange (lbl+1) 0 node args cat) chart - else univRule (Final (reverse (rng:found)) node args cat) chart - where - (FFun _ _ lins) = functions pinfo ! ruleid - lin = sequences pinfo ! (lins ! lbl) - univRule item@(Final found' node args cat) chart = - case insertXChart chart item cat of - Nothing -> chart - Just chart -> let items = do (Active found rng l ppos node@(SNode ruleid _) args c) <- lookupXChartAct chart cat - let FFun _ _ lins = functions pinfo ! ruleid - FSymCat d r = (sequences pinfo ! (lins ! l)) ! ppos - rng <- concatRange rng (found' !! r) - return (Active found rng l (ppos+1) (updateChildren node d found') args c) - ++ - do guard (isBU strategy) - (ruleid,args,c) <- leftcornerCats pinfoex ? cat - let FFun _ _ lins = functions pinfo ! ruleid - FSymCat d r = (sequences pinfo ! (lins ! 0)) ! 0 - return (Active [] (found' !! r) 0 1 (updateChildren (emptyChildren ruleid args) d found') args c) - - updateChildren :: SyntaxNode FunId RangeRec -> Int -> RangeRec -> SyntaxNode FunId RangeRec - updateChildren (SNode ruleid recs) i rec = SNode ruleid $! updateNth (const rec) i recs - in process strategy pinfo pinfoex toks items chart - ----------------------------------------------------------------------- --- * XChart - -data Item - = Active RangeRec - Range - {-# UNPACK #-} !FIndex - {-# UNPACK #-} !FPointPos - (SyntaxNode FunId RangeRec) - [FCat] - FCat - | Final RangeRec (SyntaxNode FunId RangeRec) [FCat] FCat - deriving (Eq, Ord, Show) - -data XChart c = XChart !(MM.MultiMap c Item) !(MM.MultiMap c Item) - -emptyXChart :: Ord c => XChart c -emptyXChart = XChart MM.empty MM.empty - -insertXChart (XChart actives finals) item@(Active _ _ _ _ _ _ _) c = - case MM.insert' c item actives of - Nothing -> Nothing - Just actives -> Just (XChart actives finals) - -insertXChart (XChart actives finals) item@(Final _ _ _ _) c = - case MM.insert' c item finals of - Nothing -> Nothing - Just finals -> Just (XChart actives finals) - -lookupXChartAct (XChart actives finals) c = actives MM.! c -lookupXChartFinal (XChart actives finals) c = finals MM.! c - -xchart2syntaxchart :: XChart FCat -> ParserInfo -> SyntaxChart (CId,[Profile]) (FCat,RangeRec) -xchart2syntaxchart (XChart actives finals) pinfo = - accumAssoc groupSyntaxNodes $ - [ case node of - SNode ruleid rrecs -> let FFun fun prof _ = functions pinfo ! ruleid - in ((cat,found), SNode (fun,prof) (zip rhs rrecs)) - SString s -> ((cat,found), SString s) - SInt n -> ((cat,found), SInt n) - SFloat f -> ((cat,found), SFloat f) - | (Final found node rhs cat) <- MM.elems finals - ] - -literals :: ParserInfoEx -> Input FToken -> [Item] -literals pinfoex toks = - [let (c,node) = lexer t in (Final [rng] node [] c) | (t,rngs) <- aAssocs (inputToken toks), rng <- rngs, not (t `elem` grammarToks pinfoex)] - 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 :: ParserInfo -> [FCat] -> Input FToken -> [Item] -initialTD pinfo starts toks = - do cat <- starts - (ruleid,args) <- topdownRules pinfo cat - return (Active [] (Range 0 0) 0 0 (emptyChildren ruleid args) args cat) - -topdownRules pinfo cat = f cat [] - where - f cat rules = maybe rules (Set.fold g rules) (IntMap.lookup cat (productions pinfo)) - - g (FApply ruleid args) rules = (ruleid,args) : rules - g (FCoerce cat) rules = f cat rules - - ----------------------------------------------------------------------- --- Kilbury -- - -initialBU :: ParserInfo -> ParserInfoEx -> Input FToken -> [Item] -initialBU pinfo pinfoex toks = - do (tok,rngs) <- aAssocs (inputToken toks) - (ruleid,args,cat) <- leftcornerTokens pinfoex ? tok - rng <- rngs - return (Active [] rng 0 1 (emptyChildren ruleid args) args cat) - ++ - do (ruleid,args,cat) <- epsilonRules pinfoex - let FFun _ _ _ = functions pinfo ! ruleid - return (Active [] EmptyRange 0 0 (emptyChildren ruleid args) args cat) diff --git a/src/PGF/Parsing/FCFG/Incremental.hs b/src/PGF/Parsing/FCFG/Incremental.hs deleted file mode 100644 index 296a0d33b..000000000 --- a/src/PGF/Parsing/FCFG/Incremental.hs +++ /dev/null @@ -1,371 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module PGF.Parsing.FCFG.Incremental - ( ParseState - , ErrorState - , initState - , nextState - , getCompletions - , recoveryStates - , extractTrees - , parse - , parseWithRecovery - ) where - -import Data.Array.IArray -import Data.Array.Base (unsafeAt) -import Data.List (isPrefixOf, foldl') -import Data.Maybe (fromMaybe, maybe) -import qualified Data.Map as Map -import qualified GF.Data.TrieMap as TMap -import qualified Data.IntMap as IntMap -import qualified Data.Set as Set -import Control.Monad - -import GF.Data.SortedList -import PGF.CId -import PGF.Data -import PGF.Expr(Tree) -import PGF.Macros -import PGF.TypeCheck -import Debug.Trace - -parse :: PGF -> Language -> Type -> [String] -> [Tree] -parse pgf lang typ toks = loop (initState pgf lang typ) toks - where - loop ps [] = extractTrees ps typ - loop ps (t:ts) = case nextState ps t of - Left es -> [] - Right ps -> loop ps ts - -parseWithRecovery :: PGF -> Language -> Type -> [Type] -> [String] -> [Tree] -parseWithRecovery pgf lang typ open_typs toks = accept (initState pgf lang typ) toks - where - accept ps [] = extractTrees ps typ - accept ps (t:ts) = - case nextState ps t of - Right ps -> accept ps ts - Left es -> skip (recoveryStates open_typs es) ts - - skip ps_map [] = extractTrees (fst ps_map) typ - skip ps_map (t:ts) = - case Map.lookup t (snd ps_map) of - Just ps -> accept ps ts - Nothing -> skip ps_map ts - --- | Creates an initial parsing state for a given language and --- startup category. -initState :: PGF -> Language -> Type -> ParseState -initState pgf lang (DTyp _ start _) = - let items = do - cat <- fromMaybe [] (Map.lookup start (startCats pinfo)) - (funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args) - [] cat (productions pinfo) - let FFun fn _ lins = functions pinfo ! funid - (lbl,seqid) <- assocs lins - return (Active 0 0 funid seqid args (AK cat lbl)) - - pinfo = - case lookParser pgf lang of - Just pinfo -> pinfo - _ -> error ("Unknown language: " ++ showCId lang) - - in PState pgf - pinfo - (Chart emptyAC [] emptyPC (productions pinfo) (totalCats pinfo) 0) - (TMap.singleton [] (Set.fromList items)) - --- | From the current state and the next token --- 'nextState' computes a new state, where the token --- is consumed and the current position is shifted by one. --- If the new token cannot be accepted then an error state --- is returned. -nextState :: ParseState -> String -> Either ErrorState ParseState -nextState (PState pgf pinfo chart items) t = - let (mb_agenda,map_items) = TMap.decompose items - agenda = maybe [] Set.toList mb_agenda - acc = fromMaybe TMap.empty (Map.lookup t map_items) - (acc1,chart1) = process (Just t) add (sequences pinfo) (functions pinfo) agenda acc chart - chart2 = chart1{ active =emptyAC - , actives=active chart1 : actives chart1 - , passive=emptyPC - , offset =offset chart1+1 - } - in if TMap.null acc1 - then Left (EState pgf pinfo chart2) - else Right (PState pgf pinfo chart2 acc1) - where - add (tok:toks) item acc - | tok == t = TMap.insertWith Set.union toks (Set.singleton item) acc - add _ item acc = acc - --- | If the next token is not known but only its prefix (possible empty prefix) --- then the 'getCompletions' function can be used to calculate the possible --- next words and the consequent states. This is used for word completions in --- the GF interpreter. -getCompletions :: ParseState -> String -> Map.Map String ParseState -getCompletions (PState pgf pinfo chart items) w = - let (mb_agenda,map_items) = TMap.decompose items - agenda = maybe [] Set.toList mb_agenda - acc = Map.filterWithKey (\tok _ -> isPrefixOf w tok) map_items - (acc',chart1) = process Nothing add (sequences pinfo) (functions pinfo) agenda acc chart - chart2 = chart1{ active =emptyAC - , actives=active chart1 : actives chart1 - , passive=emptyPC - , offset =offset chart1+1 - } - in fmap (PState pgf pinfo chart2) acc' - where - add (tok:toks) item acc - | isPrefixOf w tok = Map.insertWith (TMap.unionWith Set.union) tok (TMap.singleton toks (Set.singleton item)) acc - add _ item acc = acc - -recoveryStates :: [Type] -> ErrorState -> (ParseState, Map.Map String ParseState) -recoveryStates open_types (EState pgf pinfo chart) = - let open_fcats = concatMap type2fcats open_types - agenda = foldl (complete open_fcats) [] (actives chart) - (acc,chart1) = process Nothing add (sequences pinfo) (functions pinfo) agenda Map.empty chart - chart2 = chart1{ active =emptyAC - , actives=active chart1 : actives chart1 - , passive=emptyPC - , offset =offset chart1+1 - } - in (PState pgf pinfo chart (TMap.singleton [] (Set.fromList agenda)), fmap (PState pgf pinfo chart2) acc) - where - type2fcats (DTyp _ cat _) = fromMaybe [] (Map.lookup cat (startCats pinfo)) - - complete open_fcats items ac = - foldl (Set.fold (\(Active j' ppos funid seqid args keyc) -> - (:) (Active j' (ppos+1) funid seqid args keyc))) - items - [set | fcat <- open_fcats, set <- lookupACByFCat fcat ac] - - add (tok:toks) item acc = Map.insertWith (TMap.unionWith Set.union) tok (TMap.singleton toks (Set.singleton item)) acc - --- | This function extracts the list of all completed parse trees --- that spans the whole input consumed so far. The trees are also --- limited by the category specified, which is usually --- the same as the startup category. -extractTrees :: ParseState -> Type -> [Tree] -extractTrees (PState pgf pinfo chart items) ty@(DTyp _ start _) = - nubsort [e1 | e <- exps, Right e1 <- [checkExpr pgf e ty]] - where - (mb_agenda,acc) = TMap.decompose items - agenda = maybe [] Set.toList mb_agenda - (_,st) = process Nothing (\_ _ -> id) (sequences pinfo) (functions pinfo) agenda () chart - - exps = do - cat <- fromMaybe [] (Map.lookup start (startCats pinfo)) - (funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args) - [] cat (productions pinfo) - let FFun fn _ lins = functions pinfo ! funid - lbl <- indices lins - Just fid <- [lookupPC (PK cat lbl 0) (passive st)] - (fvs,tree) <- go Set.empty 0 (0,fid) - guard (Set.null fvs) - return tree - - go rec fcat' (d,fcat) - | fcat < totalCats pinfo = return (Set.empty,EMeta (fcat'*10+d)) -- FIXME: here we assume that every rule has at most 10 arguments - | Set.member fcat rec = mzero - | otherwise = foldForest (\funid args trees -> - do let FFun fn _ lins = functions pinfo ! funid - args <- mapM (go (Set.insert fcat rec) fcat) (zip [0..] args) - check_ho_fun fn args - `mplus` - trees) - (\const _ trees -> - return (freeVar const,const) - `mplus` - trees) - [] fcat (forest st) - - check_ho_fun fun args - | fun == _V = return (head args) - | fun == _B = return (foldl1 Set.difference (map fst args), foldr (\x e -> EAbs Explicit (mkVar (snd x)) e) (snd (head args)) (tail args)) - | otherwise = return (Set.unions (map fst args),foldl (\e x -> EApp e (snd x)) (EFun fun) args) - - mkVar (EFun v) = v - mkVar (EMeta _) = wildCId - - freeVar (EFun v) = Set.singleton v - freeVar _ = Set.empty - -_B = mkCId "_B" -_V = mkCId "_V" - -process mbt fn !seqs !funs [] acc chart = (acc,chart) -process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc chart - | inRange (bounds lin) ppos = - case unsafeAt lin ppos of - FSymCat d r -> let !fid = args !! d - key = AK fid r - - items2 = case lookupPC (mkPK key k) (passive chart) of - Nothing -> items - Just id -> (Active j (ppos+1) funid seqid (updateAt d id args) key0) : items - items3 = foldForest (\funid args items -> Active k 0 funid (rhs funid r) args key : items) - (\_ _ items -> items) - items2 fid (forest chart) - in case lookupAC key (active chart) of - Nothing -> process mbt fn seqs funs items3 acc chart{active=insertAC key (Set.singleton item) (active chart)} - Just set | Set.member item set -> process mbt fn seqs funs items acc chart - | otherwise -> process mbt fn seqs funs items2 acc chart{active=insertAC key (Set.insert item set) (active chart)} - FSymKS toks -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc - in process mbt fn seqs funs items acc' chart - FSymKP strs vars - -> let !acc' = foldl (\acc toks -> fn toks (Active j (ppos+1) funid seqid args key0) acc) acc - (strs:[strs' | Alt strs' _ <- vars]) - in process mbt fn seqs funs items acc' chart - FSymLit d r -> let !fid = args !! d - in case [ts | FConst _ ts <- maybe [] Set.toList (IntMap.lookup fid (forest chart))] of - (toks:_) -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc - in process mbt fn seqs funs items acc' chart - [] -> case litCatMatch fid mbt of - Just (toks,lit) -> let fid' = nextId chart - !acc' = fn toks (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc - in process mbt fn seqs funs items acc' chart{forest=IntMap.insert fid' (Set.singleton (FConst lit toks)) (forest chart) - ,nextId=nextId chart+1 - } - Nothing -> process mbt fn seqs funs items acc chart - | otherwise = - case lookupPC (mkPK key0 j) (passive chart) of - Nothing -> let fid = nextId chart - - items2 = case lookupAC key0 ((active chart:actives chart) !! (k-j)) of - Nothing -> items - Just set -> Set.fold (\(Active j' ppos funid seqid args keyc) -> - let FSymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos - in (:) (Active j' (ppos+1) funid seqid (updateAt d fid args) keyc)) items set - in process mbt fn seqs funs items2 acc chart{passive=insertPC (mkPK key0 j) fid (passive chart) - ,forest =IntMap.insert fid (Set.singleton (FApply funid args)) (forest chart) - ,nextId =nextId chart+1 - } - Just id -> let items2 = [Active k 0 funid (rhs funid r) args (AK id r) | r <- labelsAC id (active chart)] ++ items - in process mbt fn seqs funs items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (FApply funid args)) (forest chart)} - where - !lin = unsafeAt seqs seqid - !k = offset chart - - mkPK (AK fid lbl) j = PK fid lbl j - - rhs funid lbl = unsafeAt lins lbl - where - FFun _ _ lins = unsafeAt funs funid - - -updateAt :: Int -> a -> [a] -> [a] -updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs] - -litCatMatch fcat (Just t) - | fcat == fcatString = Just ([t],ELit (LStr t)) - | fcat == fcatInt = case reads t of {[(n,"")] -> Just ([t],ELit (LInt n)); - _ -> Nothing } - | fcat == fcatFloat = case reads t of {[(d,"")] -> Just ([t],ELit (LFlt d)); - _ -> Nothing } - | fcat == fcatVar = Just ([t],EFun (mkCId t)) -litCatMatch _ _ = Nothing - - ----------------------------------------------------------------- --- Active Chart ----------------------------------------------------------------- - -data Active - = Active {-# UNPACK #-} !Int - {-# UNPACK #-} !FPointPos - {-# UNPACK #-} !FunId - {-# UNPACK #-} !SeqId - [FCat] - {-# UNPACK #-} !ActiveKey - deriving (Eq,Show,Ord) -data ActiveKey - = AK {-# UNPACK #-} !FCat - {-# UNPACK #-} !FIndex - deriving (Eq,Ord,Show) -type ActiveChart = IntMap.IntMap (IntMap.IntMap (Set.Set Active)) - -emptyAC :: ActiveChart -emptyAC = IntMap.empty - -lookupAC :: ActiveKey -> ActiveChart -> Maybe (Set.Set Active) -lookupAC (AK fcat l) chart = IntMap.lookup fcat chart >>= IntMap.lookup l - -lookupACByFCat :: FCat -> ActiveChart -> [Set.Set Active] -lookupACByFCat fcat chart = - case IntMap.lookup fcat chart of - Nothing -> [] - Just map -> IntMap.elems map - -labelsAC :: FCat -> ActiveChart -> [FIndex] -labelsAC fcat chart = - case IntMap.lookup fcat chart of - Nothing -> [] - Just map -> IntMap.keys map - -insertAC :: ActiveKey -> Set.Set Active -> ActiveChart -> ActiveChart -insertAC (AK fcat l) set chart = IntMap.insertWith IntMap.union fcat (IntMap.singleton l set) chart - - ----------------------------------------------------------------- --- Passive Chart ----------------------------------------------------------------- - -data PassiveKey - = PK {-# UNPACK #-} !FCat - {-# UNPACK #-} !FIndex - {-# UNPACK #-} !Int - deriving (Eq,Ord,Show) - -type PassiveChart = Map.Map PassiveKey FCat - -emptyPC :: PassiveChart -emptyPC = Map.empty - -lookupPC :: PassiveKey -> PassiveChart -> Maybe FCat -lookupPC key chart = Map.lookup key chart - -insertPC :: PassiveKey -> FCat -> PassiveChart -> PassiveChart -insertPC key fcat chart = Map.insert key fcat chart - - ----------------------------------------------------------------- --- Forest ----------------------------------------------------------------- - -foldForest :: (FunId -> [FCat] -> b -> b) -> (Expr -> [String] -> b -> b) -> b -> FCat -> IntMap.IntMap (Set.Set Production) -> b -foldForest f g b fcat forest = - case IntMap.lookup fcat forest of - Nothing -> b - Just set -> Set.fold foldProd b set - where - foldProd (FCoerce fcat) b = foldForest f g b fcat forest - foldProd (FApply funid args) b = f funid args b - foldProd (FConst const toks) b = g const toks b - - ----------------------------------------------------------------- --- Parse State ----------------------------------------------------------------- - --- | An abstract data type whose values represent --- the current state in an incremental parser. -data ParseState = PState PGF ParserInfo Chart (TMap.TrieMap String (Set.Set Active)) - -data Chart - = Chart - { active :: ActiveChart - , actives :: [ActiveChart] - , passive :: PassiveChart - , forest :: IntMap.IntMap (Set.Set Production) - , nextId :: {-# UNPACK #-} !FCat - , offset :: {-# UNPACK #-} !Int - } - deriving Show - ----------------------------------------------------------------- --- Error State ----------------------------------------------------------------- - --- | An abstract data type whose values represent --- the state in an incremental parser after an error. -data ErrorState = EState PGF ParserInfo Chart diff --git a/src/PGF/Parsing/FCFG/Utilities.hs b/src/PGF/Parsing/FCFG/Utilities.hs deleted file mode 100644 index dc0b2dc4a..000000000 --- a/src/PGF/Parsing/FCFG/Utilities.hs +++ /dev/null @@ -1,188 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/13 12:40:19 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.6 $ --- --- Basic type declarations and functions for grammar formalisms ------------------------------------------------------------------------------ - - -module PGF.Parsing.FCFG.Utilities where - -import Control.Monad -import Data.Array -import Data.List (groupBy) - -import PGF.CId -import PGF.Data -import PGF.Tree -import GF.Data.Assoc -import GF.Data.Utilities (sameLength, foldMerge, splitBy) - - ------------------------------------------------------------- --- ranges as single pairs - -type RangeRec = [Range] - -data Range = Range {-# UNPACK #-} !Int {-# UNPACK #-} !Int - | EmptyRange - deriving (Eq, Ord, Show) - -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'] - -minRange :: Range -> Int -minRange (Range i j) = i - -maxRange :: Range -> Int -maxRange (Range i j) = j - - ------------------------------------------------------------- --- * representaions of input tokens - -data Input t = MkInput { inputBounds :: (Int, Int), - inputToken :: Assoc t [Range] - } - -input :: Ord t => [t] -> Input t -input toks = MkInput inBounds inToken - where - inBounds = (0, length toks) - inToken = accumAssoc id [ (tok, makeRange i j) | (i,j,tok) <- zip3 [0..] [1..] toks ] - -inputMany :: Ord t => [[t]] -> Input t -inputMany toks = MkInput inBounds inToken - where - inBounds = (0, length toks) - inToken = accumAssoc id [ (tok, makeRange i j) | (i,j,ts) <- zip3 [0..] [1..] toks, tok <- ts ] - - ------------------------------------------------------------- --- * 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,Show) - -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 - --- ** 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" - - --- ** 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 - -> [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 -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 - - -applyProfileToForest :: SyntaxForest (CId,[Profile]) -> [SyntaxForest CId] -applyProfileToForest (FNode (fun,profiles) children) - | fun == wildCId = concat chForests - | otherwise = [ FNode fun chForests | not (null chForests) ] - where chForests = concat [ mapM (unifyManyForests . map (forests !!)) profiles | - forests0 <- children, - forests <- mapM applyProfileToForest forests0 ] -applyProfileToForest (FString s) = [FString s] -applyProfileToForest (FInt n) = [FInt n] -applyProfileToForest (FFloat f) = [FFloat f] -applyProfileToForest (FMeta) = [FMeta] - - -forest2trees :: SyntaxForest CId -> [Tree] -forest2trees (FNode n forests) = map (Fun n) $ forests >>= mapM forest2trees -forest2trees (FString s) = [Lit (LStr s)] -forest2trees (FInt n) = [Lit (LInt n)] -forest2trees (FFloat f) = [Lit (LFlt f)] -forest2trees (FMeta) = [Meta 0] diff --git a/src/PGF/ShowLinearize.hs b/src/PGF/ShowLinearize.hs deleted file mode 100644 index dd3b997a6..000000000 --- a/src/PGF/ShowLinearize.hs +++ /dev/null @@ -1,113 +0,0 @@ -module PGF.ShowLinearize ( - collectWords, - tableLinearize, - recordLinearize, - termLinearize, - tabularLinearize, - allLinearize, - markLinearize - ) where - -import PGF.CId -import PGF.Data -import PGF.Tree -import PGF.Macros -import PGF.Linearize - -import GF.Data.Operations -import Data.List -import qualified Data.Map as Map - --- 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 PGF.paramlincat -mkRecord :: Term -> Term -> Record -mkRecord typ trm = case (typ,trm) of - (_, FV ts) -> RFV $ map (mkRecord typ) ts - (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 [], _) -> case realizes trm of - [s] -> RS s - ss -> RFV $ map RS ss - _ -> RS $ show trm ---- printTree trm - where - str = realize - --- show all branches, without labels and params -allLinearize :: (String -> String) -> PGF -> CId -> Expr -> String -allLinearize unlex pgf lang = concat . map (unlex . pr) . tabularLinearize pgf lang where - pr (p,vs) = unlines vs - --- show all branches, with labels and params -tableLinearize :: (String -> String) -> PGF -> CId -> Expr -> String -tableLinearize unlex pgf lang = unlines . map pr . tabularLinearize pgf lang where - pr (p,vs) = p +++ ":" +++ unwords (intersperse "|" (map unlex vs)) - --- create a table from labels+params to variants -tabularLinearize :: PGF -> CId -> Expr -> [(String,[String])] -tabularLinearize pgf lang = branches . recLinearize pgf 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 -> concatMap branches rs - RS s -> [([], [s])] - RCon _ -> [] - --- show record in GF-source-like syntax -recordLinearize :: PGF -> CId -> Expr -> String -recordLinearize pgf lang = prRecord . recLinearize pgf lang - --- create a GF-like record, forming the basis of all functions above -recLinearize :: PGF -> CId -> Expr -> Record -recLinearize pgf lang tree = mkRecord typ $ linTree pgf lang tree where - typ = case expr2tree tree of - Fun f _ -> lookParamLincat pgf lang $ valCat $ lookType pgf f - --- show PGF term -termLinearize :: PGF -> CId -> Expr -> String -termLinearize pgf lang = show . linTree pgf lang - --- show bracketed markup with references to tree structure -markLinearize :: PGF -> CId -> Expr -> String -markLinearize pgf lang = concat . take 1 . linearizesMark pgf lang - - --- for Morphology: word, lemma, tags -collectWords :: PGF -> Language -> [(String, [(CId,String)])] -collectWords pgf lang = - concatMap collOne - [(f,c,0) | (f,(DTyp [] c _,_,_)) <- Map.toList $ funs $ abstract pgf] - where - collOne (f,c,i) = - fromRec f [showCId c] (recLinearize pgf lang (foldl EApp (EFun f) (replicate i (EMeta 888)))) - fromRec f v r = case r of - RR rs -> concat [fromRec f v t | (_,t) <- rs] - RT rs -> concat [fromRec f (p:v) t | (p,t) <- rs] - RFV rs -> concatMap (fromRec f v) rs - RS s -> [(s,[(f,unwords (reverse v))])] - RCon c -> [] ---- inherent - diff --git a/src/PGF/Tree.hs b/src/PGF/Tree.hs deleted file mode 100644 index cb2052cd7..000000000 --- a/src/PGF/Tree.hs +++ /dev/null @@ -1,71 +0,0 @@ -module PGF.Tree - ( Tree(..), - tree2expr, expr2tree, - prTree - ) where - -import PGF.CId -import PGF.Expr hiding (Tree) - -import Data.Char -import Data.List as List -import Control.Monad -import qualified Text.PrettyPrint as PP -import qualified Text.ParserCombinators.ReadP as RP - --- | The tree is an evaluated expression in the abstract syntax --- of the grammar. The type is especially restricted to not --- allow unapplied lambda abstractions. The tree is used directly --- from the linearizer and is produced directly from the parser. -data Tree = - Abs [(BindType,CId)] Tree -- ^ lambda abstraction. The list of variables is non-empty - | Var CId -- ^ variable - | Fun CId [Tree] -- ^ function application - | Lit Literal -- ^ literal - | Meta {-# UNPACK #-} !MetaId -- ^ meta variable - deriving (Eq, Ord) - ------------------------------------------------------ --- Conversion Expr <-> Tree ------------------------------------------------------ - --- | Converts a tree to expression. The conversion --- is always total, every tree is a valid expression. -tree2expr :: Tree -> Expr -tree2expr = tree2expr [] - where - tree2expr ys (Fun x ts) = foldl EApp (EFun x) (List.map (tree2expr ys) ts) - tree2expr ys (Lit l) = ELit l - tree2expr ys (Meta n) = EMeta n - tree2expr ys (Abs xs t) = foldr (\(b,x) e -> EAbs b x e) (tree2expr (List.map snd (reverse xs)++ys) t) xs - tree2expr ys (Var x) = case List.lookup x (zip ys [0..]) of - Just i -> EVar i - Nothing -> error "unknown variable" - --- | Converts an expression to tree. The conversion is only partial. --- Variables and meta variables of function type and beta redexes are not allowed. -expr2tree :: Expr -> Tree -expr2tree e = abs [] [] e - where - abs ys xs (EAbs b x e) = abs ys ((b,x):xs) e - abs ys xs (ETyped e _) = abs ys xs e - abs ys xs e = case xs of - [] -> app ys [] e - xs -> Abs (reverse xs) (app (map snd xs++ys) [] e) - - app xs as (EApp e1 e2) = app xs ((abs xs [] e2) : as) e1 - app xs as (ELit l) - | List.null as = Lit l - | otherwise = error "literal of function type encountered" - app xs as (EMeta n) - | List.null as = Meta n - | otherwise = error "meta variables of function type are not allowed in trees" - app xs as (EAbs _ x e) = error "beta redexes are not allowed in trees" - app xs as (EVar i) = Var (xs !! i) - app xs as (EFun f) = Fun f as - app xs as (ETyped e _) = app xs as e - - -prTree :: Tree -> String -prTree = showExpr [] . tree2expr - diff --git a/src/PGF/Type.hs b/src/PGF/Type.hs deleted file mode 100644 index 013754a45..000000000 --- a/src/PGF/Type.hs +++ /dev/null @@ -1,103 +0,0 @@ -module PGF.Type ( Type(..), Hypo, - readType, showType, - mkType, mkHypo, mkDepHypo, mkImplHypo, - pType, ppType, ppHypo ) where - -import PGF.CId -import {-# SOURCE #-} PGF.Expr -import Data.Char -import Data.List -import qualified Text.PrettyPrint as PP -import qualified Text.ParserCombinators.ReadP as RP -import Control.Monad - --- | To read a type from a 'String', use 'readType'. -data Type = - DTyp [Hypo] CId [Expr] - deriving (Eq,Ord,Show) - --- | 'Hypo' represents a hypothesis in a type i.e. in the type A -> B, A is the hypothesis -type Hypo = (BindType,CId,Type) - --- | Reads a 'Type' from a 'String'. -readType :: String -> Maybe Type -readType s = case [x | (x,cs) <- RP.readP_to_S pType s, all isSpace cs] of - [x] -> Just x - _ -> Nothing - --- | renders type as 'String'. The list --- of identifiers is the list of all free variables --- in the expression in order reverse to the order --- of binding. -showType :: [CId] -> Type -> String -showType vars = PP.render . ppType 0 vars - --- | creates a type from list of hypothesises, category and --- list of arguments for the category. The operation --- @mkType [h_1,...,h_n] C [e_1,...,e_m]@ will create --- @h_1 -> ... -> h_n -> C e_1 ... e_m@ -mkType :: [Hypo] -> CId -> [Expr] -> Type -mkType hyps cat args = DTyp hyps cat args - --- | creates hypothesis for non-dependent type i.e. A -mkHypo :: Type -> Hypo -mkHypo ty = (Explicit,wildCId,ty) - --- | creates hypothesis for dependent type i.e. (x : A) -mkDepHypo :: CId -> Type -> Hypo -mkDepHypo x ty = (Explicit,x,ty) - --- | creates hypothesis for dependent type with implicit argument i.e. ({x} : A) -mkImplHypo :: CId -> Type -> Hypo -mkImplHypo x ty = (Implicit,x,ty) - -pType :: RP.ReadP Type -pType = do - RP.skipSpaces - hyps <- RP.sepBy (pHypo >>= \h -> RP.skipSpaces >> RP.string "->" >> return h) RP.skipSpaces - RP.skipSpaces - (cat,args) <- pAtom - return (DTyp (concat hyps) cat args) - where - pHypo = - do (cat,args) <- pAtom - return [(Explicit,wildCId,DTyp [] cat args)] - RP.<++ - (RP.between (RP.char '(') (RP.char ')') $ do - xs <- RP.option [(Explicit,wildCId)] $ do - xs <- pBinds - RP.skipSpaces - RP.char ':' - return xs - ty <- pType - return [(b,v,ty) | (b,v) <- xs]) - RP.<++ - (RP.between (RP.char '{') (RP.char '}') $ do - vs <- RP.sepBy1 (RP.skipSpaces >> pCId) (RP.skipSpaces >> RP.char ',') - RP.skipSpaces - RP.char ':' - ty <- pType - return [(Implicit,v,ty) | v <- vs]) - - pAtom = do - cat <- pCId - RP.skipSpaces - args <- RP.sepBy pArg RP.skipSpaces - return (cat, args) - -ppType :: Int -> [CId] -> Type -> PP.Doc -ppType d scope (DTyp hyps cat args) - | null hyps = ppRes scope cat args - | otherwise = let (scope',hdocs) = mapAccumL ppHypo scope hyps - in ppParens (d > 0) (foldr (\hdoc doc -> hdoc PP.<+> PP.text "->" PP.<+> doc) (ppRes scope' cat args) hdocs) - where - ppRes scope cat es = ppCId cat PP.<+> PP.hsep (map (ppExpr 4 scope) es) - -ppHypo scope (Explicit,x,typ) = if x == wildCId - then (scope,ppType 1 scope typ) - else let y = freshName x scope - in (y:scope,PP.parens (ppCId y PP.<+> PP.char ':' PP.<+> ppType 0 scope typ)) -ppHypo scope (Implicit,x,typ) = if x == wildCId - then (scope,PP.parens (PP.braces (ppCId x) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ)) - else let y = freshName x scope - in (y:scope,PP.parens (PP.braces (ppCId y) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ)) diff --git a/src/PGF/TypeCheck.hs b/src/PGF/TypeCheck.hs deleted file mode 100644 index 937c21786..000000000 --- a/src/PGF/TypeCheck.hs +++ /dev/null @@ -1,524 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PGF.TypeCheck --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- Type checking in abstract syntax with dependent types. --- The type checker also performs renaming and checking for unknown --- functions. The variable references are replaced by de Bruijn indices. --- ------------------------------------------------------------------------------ - -module PGF.TypeCheck (checkType, checkExpr, inferExpr, - - ppTcError, TcError(..) - ) where - -import PGF.Data -import PGF.Expr -import PGF.Macros (typeOfHypo) -import PGF.CId - -import Data.Map as Map -import Data.IntMap as IntMap -import Data.Maybe as Maybe -import Data.List as List -import Control.Monad -import Text.PrettyPrint - ------------------------------------------------------ --- The Scope ------------------------------------------------------ - -data TType = TTyp Env Type -newtype Scope = Scope [(CId,TType)] - -emptyScope = Scope [] - -addScopedVar :: CId -> TType -> Scope -> Scope -addScopedVar x tty (Scope gamma) = Scope ((x,tty):gamma) - --- | returns the type and the De Bruijn index of a local variable -lookupVar :: CId -> Scope -> Maybe (Int,TType) -lookupVar x (Scope gamma) = listToMaybe [(i,tty) | ((y,tty),i) <- zip gamma [0..], x == y] - --- | returns the type and the name of a local variable -getVar :: Int -> Scope -> (CId,TType) -getVar i (Scope gamma) = gamma !! i - -scopeEnv :: Scope -> Env -scopeEnv (Scope gamma) = let n = length gamma - in [VGen (n-i-1) [] | i <- [0..n-1]] - -scopeVars :: Scope -> [CId] -scopeVars (Scope gamma) = List.map fst gamma - -scopeSize :: Scope -> Int -scopeSize (Scope gamma) = length gamma - ------------------------------------------------------ --- The Monad ------------------------------------------------------ - -type MetaStore = IntMap MetaValue -data MetaValue - = MUnbound Scope [Expr -> TcM ()] - | MBound Expr - | MGuarded Expr [Expr -> TcM ()] {-# UNPACK #-} !Int -- the Int is the number of constraints that have to be solved - -- to unlock this meta variable - -newtype TcM a = TcM {unTcM :: Abstr -> MetaId -> MetaStore -> TcResult a} -data TcResult a - = Ok {-# UNPACK #-} !MetaId MetaStore a - | Fail TcError - -instance Monad TcM where - return x = TcM (\abstr metaid ms -> Ok metaid ms x) - f >>= g = TcM (\abstr metaid ms -> case unTcM f abstr metaid ms of - Ok metaid ms x -> unTcM (g x) abstr metaid ms - Fail e -> Fail e) - -instance Functor TcM where - fmap f x = TcM (\abstr metaid ms -> case unTcM x abstr metaid ms of - Ok metaid ms x -> Ok metaid ms (f x) - Fail e -> Fail e) - -lookupCatHyps :: CId -> TcM [Hypo] -lookupCatHyps cat = TcM (\abstr metaid ms -> case Map.lookup cat (cats abstr) of - Just hyps -> Ok metaid ms hyps - Nothing -> Fail (UnknownCat cat)) - -lookupFunType :: CId -> TcM TType -lookupFunType fun = TcM (\abstr metaid ms -> case Map.lookup fun (funs abstr) of - Just (ty,_,_) -> Ok metaid ms (TTyp [] ty) - Nothing -> Fail (UnknownFun fun)) - -newMeta :: Scope -> TcM MetaId -newMeta scope = TcM (\abstr metaid ms -> Ok (metaid+1) (IntMap.insert metaid (MUnbound scope []) ms) metaid) - -newGuardedMeta :: Scope -> Expr -> TcM MetaId -newGuardedMeta scope e = getFuns >>= \funs -> TcM (\abstr metaid ms -> Ok (metaid+1) (IntMap.insert metaid (MGuarded e [] 0) ms) metaid) - -getMeta :: MetaId -> TcM MetaValue -getMeta i = TcM (\abstr metaid ms -> Ok metaid ms $! case IntMap.lookup i ms of - Just mv -> mv) -setMeta :: MetaId -> MetaValue -> TcM () -setMeta i mv = TcM (\abstr metaid ms -> Ok metaid (IntMap.insert i mv ms) ()) - -tcError :: TcError -> TcM a -tcError e = TcM (\abstr metaid ms -> Fail e) - -getFuns :: TcM Funs -getFuns = TcM (\abstr metaid ms -> Ok metaid ms (funs abstr)) - -addConstraint :: MetaId -> MetaId -> Env -> [Value] -> (Value -> TcM ()) -> TcM () -addConstraint i j env vs c = do - funs <- getFuns - mv <- getMeta j - case mv of - MUnbound scope cs -> addRef >> setMeta j (MUnbound scope ((\e -> release >> c (apply funs env e vs)) : cs)) - MBound e -> c (apply funs env e vs) - MGuarded e cs x | x == 0 -> c (apply funs env e vs) - | otherwise -> addRef >> setMeta j (MGuarded e ((\e -> release >> c (apply funs env e vs)) : cs) x) - where - addRef = TcM (\abstr metaid ms -> case IntMap.lookup i ms of - Just (MGuarded e cs x) -> Ok metaid (IntMap.insert i (MGuarded e cs (x+1)) ms) ()) - - release = TcM (\abstr metaid ms -> case IntMap.lookup i ms of - Just (MGuarded e cs x) -> if x == 1 - then unTcM (sequence_ [c e | c <- cs]) abstr metaid (IntMap.insert i (MGuarded e [] 0) ms) - else Ok metaid (IntMap.insert i (MGuarded e cs (x-1)) ms) ()) - ------------------------------------------------------ --- Type errors ------------------------------------------------------ - --- | If an error occurs in the typechecking phase --- the type checker returns not a plain text error message --- but a 'TcError' structure which describes the error. -data TcError - = UnknownCat CId -- ^ Unknown category name was found. - | UnknownFun CId -- ^ Unknown function name was found. - | WrongCatArgs [CId] Type CId Int Int -- ^ A category was applied to wrong number of arguments. - -- The first integer is the number of expected arguments and - -- the second the number of given arguments. - -- The @[CId]@ argument is the list of free variables - -- in the type. It should be used for the 'showType' function. - | TypeMismatch [CId] Expr Type Type -- ^ The expression is not of the expected type. - -- The first type is the expected type, while - -- the second is the inferred. The @[CId]@ argument is the list - -- of free variables in both the expression and the type. - -- It should be used for the 'showType' and 'showExpr' functions. - | NotFunType [CId] Expr Type -- ^ Something that is not of function type was applied to an argument. - | CannotInferType [CId] Expr -- ^ It is not possible to infer the type of an expression. - | UnresolvedMetaVars [CId] Expr [MetaId] -- ^ Some metavariables have to be instantiated in order to complete the typechecking. - | UnexpectedImplArg [CId] Expr -- ^ Implicit argument was passed where the type doesn't allow it - --- | Renders the type checking error to a document. See 'Text.PrettyPrint'. -ppTcError :: TcError -> Doc -ppTcError (UnknownCat cat) = text "Category" <+> ppCId cat <+> text "is not in scope" -ppTcError (UnknownFun fun) = text "Function" <+> ppCId fun <+> text "is not in scope" -ppTcError (WrongCatArgs xs ty cat m n) = text "Category" <+> ppCId cat <+> text "should have" <+> int m <+> text "argument(s), but has been given" <+> int n $$ - text "In the type:" <+> ppType 0 xs ty -ppTcError (TypeMismatch xs e ty1 ty2) = text "Couldn't match expected type" <+> ppType 0 xs ty1 $$ - text " against inferred type" <+> ppType 0 xs ty2 $$ - text "In the expression:" <+> ppExpr 0 xs e -ppTcError (NotFunType xs e ty) = text "A function type is expected for the expression" <+> ppExpr 0 xs e <+> text "instead of type" <+> ppType 0 xs ty -ppTcError (CannotInferType xs e) = text "Cannot infer the type of expression" <+> ppExpr 0 xs e -ppTcError (UnresolvedMetaVars xs e ms) = text "Meta variable(s)" <+> fsep (List.map ppMeta ms) <+> text "should be resolved" $$ - text "in the expression:" <+> ppExpr 0 xs e -ppTcError (UnexpectedImplArg xs e) = braces (ppExpr 0 xs e) <+> text "is implicit argument but not implicit argument is expected here" - ------------------------------------------------------ --- checkType ------------------------------------------------------ - --- | Check whether a given type is consistent with the abstract --- syntax of the grammar. -checkType :: PGF -> Type -> Either TcError Type -checkType pgf ty = - case unTcM (tcType emptyScope ty >>= refineType) (abstract pgf) 0 IntMap.empty of - Ok _ ms ty -> Right ty - Fail err -> Left err - -tcType :: Scope -> Type -> TcM Type -tcType scope ty@(DTyp hyps cat es) = do - (scope,hyps) <- tcHypos scope hyps - c_hyps <- lookupCatHyps cat - let m = length es - n = length [ty | (Explicit,x,ty) <- c_hyps] - (delta,es) <- tcCatArgs scope es [] c_hyps ty n m - return (DTyp hyps cat es) - -tcHypos :: Scope -> [Hypo] -> TcM (Scope,[Hypo]) -tcHypos scope [] = return (scope,[]) -tcHypos scope (h:hs) = do - (scope,h ) <- tcHypo scope h - (scope,hs) <- tcHypos scope hs - return (scope,h:hs) - -tcHypo :: Scope -> Hypo -> TcM (Scope,Hypo) -tcHypo scope (b,x,ty) = do - ty <- tcType scope ty - if x == wildCId - then return (scope,(b,x,ty)) - else return (addScopedVar x (TTyp (scopeEnv scope) ty) scope,(b,x,ty)) - -tcCatArgs scope [] delta [] ty0 n m = return (delta,[]) -tcCatArgs scope (EImplArg e:es) delta ((Explicit,x,ty):hs) ty0 n m = tcError (UnexpectedImplArg (scopeVars scope) e) -tcCatArgs scope (EImplArg e:es) delta ((Implicit,x,ty):hs) ty0 n m = do - e <- tcExpr scope e (TTyp delta ty) - funs <- getFuns - (delta,es) <- if x == wildCId - then tcCatArgs scope es delta hs ty0 n m - else tcCatArgs scope es (eval funs (scopeEnv scope) e:delta) hs ty0 n m - return (delta,EImplArg e:es) -tcCatArgs scope es delta ((Implicit,x,ty):hs) ty0 n m = do - i <- newMeta scope - (delta,es) <- if x == wildCId - then tcCatArgs scope es delta hs ty0 n m - else tcCatArgs scope es (VMeta i (scopeEnv scope) [] : delta) hs ty0 n m - return (delta,EImplArg (EMeta i) : es) -tcCatArgs scope (e:es) delta ((Explicit,x,ty):hs) ty0 n m = do - e <- tcExpr scope e (TTyp delta ty) - funs <- getFuns - (delta,es) <- if x == wildCId - then tcCatArgs scope es delta hs ty0 n m - else tcCatArgs scope es (eval funs (scopeEnv scope) e:delta) hs ty0 n m - return (delta,e:es) -tcCatArgs scope _ delta _ ty0@(DTyp _ cat _) n m = do - tcError (WrongCatArgs (scopeVars scope) ty0 cat n m) - ------------------------------------------------------ --- checkExpr ------------------------------------------------------ - --- | Checks an expression against a specified type. -checkExpr :: PGF -> Expr -> Type -> Either TcError Expr -checkExpr pgf e ty = - case unTcM (do e <- tcExpr emptyScope e (TTyp [] ty) - e <- refineExpr e - checkResolvedMetaStore emptyScope e - return e) (abstract pgf) 0 IntMap.empty of - Ok _ ms e -> Right e - Fail err -> Left err - -tcExpr :: Scope -> Expr -> TType -> TcM Expr -tcExpr scope e0@(EAbs Implicit x e) tty = - case tty of - TTyp delta (DTyp ((Implicit,y,ty):hs) c es) -> do e <- if y == wildCId - then tcExpr (addScopedVar x (TTyp delta ty) scope) - e (TTyp delta (DTyp hs c es)) - else tcExpr (addScopedVar x (TTyp delta ty) scope) - e (TTyp ((VGen (scopeSize scope) []):delta) (DTyp hs c es)) - return (EAbs Implicit x e) - _ -> do ty <- evalType (scopeSize scope) tty - tcError (NotFunType (scopeVars scope) e0 ty) -tcExpr scope e0 (TTyp delta (DTyp ((Implicit,y,ty):hs) c es)) = do - e0 <- if y == wildCId - then tcExpr (addScopedVar wildCId (TTyp delta ty) scope) - e0 (TTyp delta (DTyp hs c es)) - else tcExpr (addScopedVar wildCId (TTyp delta ty) scope) - e0 (TTyp ((VGen (scopeSize scope) []):delta) (DTyp hs c es)) - return (EAbs Implicit wildCId e0) -tcExpr scope e0@(EAbs Explicit x e) tty = - case tty of - TTyp delta (DTyp ((Explicit,y,ty):hs) c es) -> do e <- if y == wildCId - then tcExpr (addScopedVar x (TTyp delta ty) scope) - e (TTyp delta (DTyp hs c es)) - else tcExpr (addScopedVar x (TTyp delta ty) scope) - e (TTyp ((VGen (scopeSize scope) []):delta) (DTyp hs c es)) - return (EAbs Explicit x e) - _ -> do ty <- evalType (scopeSize scope) tty - tcError (NotFunType (scopeVars scope) e0 ty) -tcExpr scope (EMeta _) tty = do - i <- newMeta scope - return (EMeta i) -tcExpr scope e0 tty = do - (e0,tty0) <- infExpr scope e0 - i <- newGuardedMeta scope e0 - eqType scope (scopeSize scope) i tty tty0 - return (EMeta i) - - ------------------------------------------------------ --- inferExpr ------------------------------------------------------ - --- | Tries to infer the type of a given expression. Note that --- even if the expression is type correct it is not always --- possible to infer its type in the GF type system. --- In this case the function returns the 'CannotInferType' error. -inferExpr :: PGF -> Expr -> Either TcError (Expr,Type) -inferExpr pgf e = - case unTcM (do (e,tty) <- infExpr emptyScope e - e <- refineExpr e - checkResolvedMetaStore emptyScope e - ty <- evalType 0 tty - return (e,ty)) (abstract pgf) 1 IntMap.empty of - Ok _ ms (e,ty) -> Right (e,ty) - Fail err -> Left err - -infExpr :: Scope -> Expr -> TcM (Expr,TType) -infExpr scope e0@(EApp e1 e2) = do - (e1,TTyp delta ty) <- infExpr scope e1 - (e0,delta,ty) <- tcArg scope e1 e2 delta ty - return (e0,TTyp delta ty) -infExpr scope e0@(EFun x) = do - case lookupVar x scope of - Just (i,tty) -> return (EVar i,tty) - Nothing -> do tty <- lookupFunType x - return (e0,tty) -infExpr scope e0@(EVar i) = do - return (e0,snd (getVar i scope)) -infExpr scope e0@(ELit l) = do - let cat = case l of - LStr _ -> mkCId "String" - LInt _ -> mkCId "Int" - LFlt _ -> mkCId "Float" - return (e0,TTyp [] (DTyp [] cat [])) -infExpr scope (ETyped e ty) = do - ty <- tcType scope ty - e <- tcExpr scope e (TTyp (scopeEnv scope) ty) - return (ETyped e ty,TTyp (scopeEnv scope) ty) -infExpr scope (EImplArg e) = do - (e,tty) <- infExpr scope e - return (EImplArg e,tty) -infExpr scope e = tcError (CannotInferType (scopeVars scope) e) - -tcArg scope e1 e2 delta ty0@(DTyp [] c es) = do - ty1 <- evalType (scopeSize scope) (TTyp delta ty0) - tcError (NotFunType (scopeVars scope) e1 ty1) -tcArg scope e1 (EImplArg e2) delta ty0@(DTyp ((Explicit,x,ty):hs) c es) = tcError (UnexpectedImplArg (scopeVars scope) e2) -tcArg scope e1 (EImplArg e2) delta ty0@(DTyp ((Implicit,x,ty):hs) c es) = do - e2 <- tcExpr scope e2 (TTyp delta ty) - funs <- getFuns - if x == wildCId - then return (EApp e1 (EImplArg e2), delta,DTyp hs c es) - else return (EApp e1 (EImplArg e2),eval funs (scopeEnv scope) e2:delta,DTyp hs c es) -tcArg scope e1 e2 delta ty0@(DTyp ((Explicit,x,ty):hs) c es) = do - e2 <- tcExpr scope e2 (TTyp delta ty) - funs <- getFuns - if x == wildCId - then return (EApp e1 e2, delta,DTyp hs c es) - else return (EApp e1 e2,eval funs (scopeEnv scope) e2:delta,DTyp hs c es) -tcArg scope e1 e2 delta ty0@(DTyp ((Implicit,x,ty):hs) c es) = do - i <- newMeta scope - if x == wildCId - then tcArg scope (EApp e1 (EImplArg (EMeta i))) e2 delta (DTyp hs c es) - else tcArg scope (EApp e1 (EImplArg (EMeta i))) e2 (VMeta i (scopeEnv scope) [] : delta) (DTyp hs c es) - ------------------------------------------------------ --- eqType ------------------------------------------------------ - -eqType :: Scope -> Int -> MetaId -> TType -> TType -> TcM () -eqType scope k i0 tty1@(TTyp delta1 ty1@(DTyp hyps1 cat1 es1)) tty2@(TTyp delta2 ty2@(DTyp hyps2 cat2 es2)) - | cat1 == cat2 = do (k,delta1,delta2) <- eqHyps k delta1 hyps1 delta2 hyps2 - sequence_ [eqExpr k delta1 e1 delta2 e2 | (e1,e2) <- zip es1 es2] - | otherwise = raiseTypeMatchError - where - raiseTypeMatchError = do ty1 <- evalType k tty1 - ty2 <- evalType k tty2 - e <- refineExpr (EMeta i0) - tcError (TypeMismatch (scopeVars scope) e ty1 ty2) - - eqHyps :: Int -> Env -> [Hypo] -> Env -> [Hypo] -> TcM (Int,Env,Env) - eqHyps k delta1 [] delta2 [] = - return (k,delta1,delta2) - eqHyps k delta1 ((_,x,ty1) : h1s) delta2 ((_,y,ty2) : h2s) = do - eqType scope k i0 (TTyp delta1 ty1) (TTyp delta2 ty2) - if x == wildCId && y == wildCId - then eqHyps k delta1 h1s delta2 h2s - else if x /= wildCId && y /= wildCId - then eqHyps (k+1) ((VGen k []):delta1) h1s ((VGen k []):delta2) h2s - else raiseTypeMatchError - eqHyps k delta1 h1s delta2 h2s = raiseTypeMatchError - - eqExpr :: Int -> Env -> Expr -> Env -> Expr -> TcM () - eqExpr k env1 e1 env2 e2 = do - funs <- getFuns - eqValue k (eval funs env1 e1) (eval funs env2 e2) - - eqValue :: Int -> Value -> Value -> TcM () - eqValue k v1 v2 = do - v1 <- deRef v1 - v2 <- deRef v2 - eqValue' k v1 v2 - - deRef v@(VMeta i env vs) = do - mv <- getMeta i - funs <- getFuns - case mv of - MBound e -> deRef (apply funs env e vs) - MGuarded e _ x | x == 0 -> deRef (apply funs env e vs) - | otherwise -> return v - MUnbound _ _ -> return v - deRef v = return v - - eqValue' k (VSusp i env vs1 c) v2 = addConstraint i0 i env vs1 (\v1 -> eqValue k (c v1) v2) - eqValue' k v1 (VSusp i env vs2 c) = addConstraint i0 i env vs2 (\v2 -> eqValue k v1 (c v2)) - eqValue' k (VMeta i env1 vs1) (VMeta j env2 vs2) | i == j = zipWithM_ (eqValue k) vs1 vs2 - eqValue' k (VMeta i env1 vs1) v2 = do (MUnbound scopei cs) <- getMeta i - e2 <- mkLam i scopei env1 vs1 v2 - setMeta i (MBound e2) - sequence_ [c e2 | c <- cs] - eqValue' k v1 (VMeta i env2 vs2) = do (MUnbound scopei cs) <- getMeta i - e1 <- mkLam i scopei env2 vs2 v1 - setMeta i (MBound e1) - sequence_ [c e1 | c <- cs] - eqValue' k (VApp f1 vs1) (VApp f2 vs2) | f1 == f2 = zipWithM_ (eqValue k) vs1 vs2 - eqValue' k (VLit l1) (VLit l2 ) | l1 == l2 = return () - eqValue' k (VGen i vs1) (VGen j vs2) | i == j = zipWithM_ (eqValue k) vs1 vs2 - eqValue' k (VClosure env1 (EAbs _ x1 e1)) (VClosure env2 (EAbs _ x2 e2)) = let v = VGen k [] - in eqExpr (k+1) (v:env1) e1 (v:env2) e2 - eqValue' k v1 v2 = raiseTypeMatchError - - mkLam i scope env vs0 v = do - let k = scopeSize scope - vs = reverse (take k env) ++ vs0 - xs = nub [i | VGen i [] <- vs] - if length vs == length xs - then return () - else raiseTypeMatchError - v <- occurCheck i k xs v - funs <- getFuns - return (addLam vs0 (value2expr funs (length xs) v)) - where - addLam [] e = e - addLam (v:vs) e = EAbs Explicit var (addLam vs e) - - var = mkCId "v" - - occurCheck i0 k xs (VApp f vs) = do vs <- mapM (occurCheck i0 k xs) vs - return (VApp f vs) - occurCheck i0 k xs (VLit l) = return (VLit l) - occurCheck i0 k xs (VMeta i env vs) = do if i == i0 - then raiseTypeMatchError - else return () - mv <- getMeta i - funs <- getFuns - case mv of - MBound e -> occurCheck i0 k xs (apply funs env e vs) - MGuarded e _ _ -> occurCheck i0 k xs (apply funs env e vs) - MUnbound scopei _ | scopeSize scopei > k -> raiseTypeMatchError - | otherwise -> do vs <- mapM (occurCheck i0 k xs) vs - return (VMeta i env vs) - occurCheck i0 k xs (VSusp i env vs cnt) = do addConstraint i0 i env vs (\v -> occurCheck i0 k xs (cnt v) >> return ()) - return (VSusp i env vs cnt) - occurCheck i0 k xs (VGen i vs) = case List.findIndex (==i) xs of - Just i -> do vs <- mapM (occurCheck i0 k xs) vs - return (VGen i vs) - Nothing -> raiseTypeMatchError - occurCheck i0 k xs (VClosure env e) = do env <- mapM (occurCheck i0 k xs) env - return (VClosure env e) - - ------------------------------------------------------------ --- check for meta variables that still have to be resolved ------------------------------------------------------------ - -checkResolvedMetaStore :: Scope -> Expr -> TcM () -checkResolvedMetaStore scope e = TcM (\abstr metaid ms -> - let xs = [i | (i,mv) <- IntMap.toList ms, not (isResolved mv)] - in if List.null xs - then Ok metaid ms () - else Fail (UnresolvedMetaVars (scopeVars scope) e xs)) - where - isResolved (MUnbound _ []) = True - isResolved (MGuarded _ _ _) = True - isResolved (MBound _) = True - isResolved _ = False - ------------------------------------------------------ --- evalType ------------------------------------------------------ - -evalType :: Int -> TType -> TcM Type -evalType k (TTyp delta ty) = do funs <- getFuns - refineType (evalTy funs k delta ty) - where - evalTy sig k delta (DTyp hyps cat es) = - let ((k1,delta1),hyps1) = mapAccumL (evalHypo sig) (k,delta) hyps - in DTyp hyps1 cat (List.map (normalForm sig k1 delta1) es) - - evalHypo sig (k,delta) (b,x,ty) = - if x == wildCId - then ((k, delta),(b,x,evalTy sig k delta ty)) - else ((k+1,(VGen k []):delta),(b,x,evalTy sig k delta ty)) - - ------------------------------------------------------ --- refinement ------------------------------------------------------ - -refineExpr :: Expr -> TcM Expr -refineExpr e = TcM (\abstr metaid ms -> Ok metaid ms (refineExpr_ ms e)) - -refineExpr_ ms e = refine e - where - refine (EAbs b x e) = EAbs b x (refine e) - refine (EApp e1 e2) = EApp (refine e1) (refine e2) - refine (ELit l) = ELit l - refine (EMeta i) = case IntMap.lookup i ms of - Just (MBound e ) -> refine e - Just (MGuarded e _ _) -> refine e - _ -> EMeta i - refine (EFun f) = EFun f - refine (EVar i) = EVar i - refine (ETyped e ty) = ETyped (refine e) (refineType_ ms ty) - refine (EImplArg e) = EImplArg (refine e) - -refineType :: Type -> TcM Type -refineType ty = TcM (\abstr metaid ms -> Ok metaid ms (refineType_ ms ty)) - -refineType_ ms (DTyp hyps cat es) = DTyp [(b,x,refineType_ ms ty) | (b,x,ty) <- hyps] cat (List.map (refineExpr_ ms) es) - -value2expr sig i (VApp f vs) = foldl EApp (EFun f) (List.map (value2expr sig i) vs) -value2expr sig i (VGen j vs) = foldl EApp (EVar (i-j-1)) (List.map (value2expr sig i) vs) -value2expr sig i (VMeta j env vs) = foldl EApp (EMeta j) (List.map (value2expr sig i) vs) -value2expr sig i (VSusp j env vs k) = value2expr sig i (k (VGen j vs)) -value2expr sig i (VLit l) = ELit l -value2expr sig i (VClosure env (EAbs b x e)) = EAbs b x (value2expr sig (i+1) (eval sig ((VGen i []):env) e)) diff --git a/src/PGF/VisualizeTree.hs b/src/PGF/VisualizeTree.hs deleted file mode 100644 index 429551f54..000000000 --- a/src/PGF/VisualizeTree.hs +++ /dev/null @@ -1,353 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : VisualizeTree --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: --- > CVS $Author: --- > CVS $Revision: --- --- Print a graph of an abstract syntax tree in Graphviz DOT format --- Based on BB's VisualizeGrammar --- FIXME: change this to use GF.Visualization.Graphviz, --- instead of rolling its own. ------------------------------------------------------------------------------ - -module PGF.VisualizeTree ( graphvizAbstractTree - , graphvizParseTree - , graphvizDependencyTree - , graphvizAlignment - , tree2mk - , getDepLabels - , PosText(..), readPosText - ) where - -import PGF.CId (CId,showCId,pCId,mkCId) -import PGF.Data -import PGF.Tree -import PGF.Expr (showExpr) -import PGF.Linearize -import PGF.Macros (lookValCat) - -import qualified Data.Map as Map -import Data.List (intersperse,nub,isPrefixOf,sort,sortBy) -import Data.Char (isDigit) -import qualified Text.ParserCombinators.ReadP as RP - -import Debug.Trace - -graphvizAbstractTree :: PGF -> (Bool,Bool) -> Expr -> String -graphvizAbstractTree pgf funscats = prGraph False . tree2graph pgf funscats . expr2tree - -tree2graph :: PGF -> (Bool,Bool) -> Tree -> [String] -tree2graph pgf (funs,cats) = prf [] where - prf ps t = let (nod,lab) = prn ps t in - (nod ++ " [label = " ++ lab ++ ", style = \"solid\", shape = \"plaintext\"] ;") : - case t of - Fun cid trees -> - [ pra (j:ps) nod t | (j,t) <- zip [0..] trees] ++ - concat [prf (j:ps) t | (j,t) <- zip [0..] trees] - Abs xs (Fun cid trees) -> - [ pra (j:ps) nod t | (j,t) <- zip [0..] trees] ++ - concat [prf (j:ps) t | (j,t) <- zip [0..] trees] - _ -> [] - prn ps t = case t of - Fun cid _ -> - let - fun = if funs then showCId cid else "" - cat = if cats then prCat cid else "" - colon = if funs && cats then " : " else "" - lab = "\"" ++ fun ++ colon ++ cat ++ "\"" - in (show(show (ps :: [Int])),lab) - Abs bs tree -> - let fun = case tree of - Fun cid _ -> Fun cid [] - _ -> tree - in (show(show (ps :: [Int])),"\"" ++ esc (prTree (Abs bs fun)) ++ "\"") - _ -> (show(show (ps :: [Int])),"\"" ++ esc (prTree t) ++ "\"") - pra i nod t = nod ++ arr ++ fst (prn i t) ++ " [style = \"solid\"];" - arr = " -- " -- if digr then " -> " else " -- " - prCat = showCId . lookValCat pgf - esc = concatMap (\c -> if c =='\\' then [c,c] else [c]) --- escape backslash in abstracts - -prGraph digr ns = concat $ map (++"\n") $ [graph ++ "{\n"] ++ ns ++ ["}"] where - graph = if digr then "digraph" else "graph" - - --- replace each non-atomic constructor with mkC, where C is the val cat -tree2mk :: PGF -> Expr -> String -tree2mk pgf = showExpr [] . tree2expr . t2m . expr2tree where - t2m t = case t of - Fun cid [] -> t - Fun cid ts -> Fun (mk cid) (map t2m ts) - _ -> t - mk = mkCId . ("mk" ++) . showCId . lookValCat pgf - --- dependency trees from Linearize.linearizeMark - -graphvizDependencyTree :: String -> Bool -> Maybe Labels -> Maybe String -> PGF -> CId -> Expr -> String -graphvizDependencyTree format debug mlab ms pgf lang exp = case format of - "malt" -> unlines (lin2dep format) - "malt_input" -> unlines (lin2dep format) - _ -> prGraph True (lin2dep format) - - where - - lin2dep format = trace (ifd (show sortedNodes ++ show nodeWords)) $ case format of - "malt" -> map (concat . intersperse "\t") wnodes - "malt_input" -> map (concat . intersperse "\t" . take 6) wnodes - _ -> prelude ++ nodes ++ links - - ifd s = if debug then s else [] - - pot = readPosText $ head $ linearizesMark pgf lang exp - ---- use Just str if you have str to match against - - prelude = ["rankdir=LR ;", "node [shape = plaintext] ;"] - - nodes = map mkNode nodeWords - mkNode (i,((_,p),ss)) = - node p ++ " [label = \"" ++ show i ++ ". " ++ ifd (show p) ++ unwords ss ++ "\"] ;" - nodeWords = (0,((mkCId "",[]),["ROOT"])) : zip [1..] [((f,p),w)| - ((Just f,p),w) <- wlins pot] - - links = map mkLink thelinks - thelinks = [(word y, x, label tr y x) | - (_,((f,x),_)) <- tail nodeWords, - let y = dominant x] - mkLink (x,y,l) = node x ++ " -> " ++ node y ++ " [label = \"" ++ l ++ "\"] ;" - node = show . show - - dominant x = case x of - [] -> x - _ | not (x == hx) -> hx - _ -> dominant (init x) - where - hx = headArg (init x) tr x - - headArg x0 tr x = case (tr,x) of - (Fun f [],[_]) -> x0 ---- ?? - (Fun f ts,[_]) -> x0 ++ [getHead (length ts - 1) f] - (Fun f ts,i:y) -> headArg x0 (ts !! i) y - _ -> x0 ---- - - label tr y x = case span (uncurry (==)) (zip y x) of - (xys,(_,i):_) -> getLabel i (funAt tr (map fst xys)) - _ -> "" ---- - - funAt tr x = case (tr,x) of - (Fun f _ ,[]) -> f - (Fun f ts,i:y) -> funAt (ts !! i) y - _ -> mkCId (prTree tr) ---- - - word x = if elem x sortedNodes then x else - let x' = headArg x tr (x ++[0]) in - if x' == x then [] else word x' - - tr = expr2tree exp - sortedNodes = [p | (_,((_,p),_)) <- nodeWords] - - labels = maybe Map.empty id mlab - getHead i f = case Map.lookup f labels of - Just ls -> length $ takeWhile (/= "head") ls - _ -> i - getLabel i f = case Map.lookup f labels of - Just ls | length ls > i -> ifd (showCId f ++ "#" ++ show i ++ "=") ++ ls !! i - _ -> showCId f ++ "#" ++ show i - --- to generate CoNLL format for MaltParser - nodeMap :: Map.Map [Int] Int - nodeMap = Map.fromList [(p,i) | (i,((_,p),_)) <- nodeWords] - - arcMap :: Map.Map [Int] ([Int],String) - arcMap = Map.fromList [(y,(x,l)) | (x,y,l) <- thelinks] - - lookDomLab p = case Map.lookup p arcMap of - Just (q,l) -> (maybe 0 id (Map.lookup q nodeMap), if null l then rootlabel else l) - _ -> (0,rootlabel) - - wnodes = [[show i, maltws ws, showCId fun, pos, pos, morph, show dom, lab, unspec, unspec] | - (i, ((fun,p),ws)) <- tail nodeWords, - let pos = showCId $ lookValCat pgf fun, - let morph = unspec, - let (dom,lab) = lookDomLab p - ] - maltws = concat . intersperse "+" . words . unwords -- no spaces in column 2 - unspec = "_" - rootlabel = "ROOT" - -type Labels = Map.Map CId [String] - -getDepLabels :: [String] -> Labels -getDepLabels ss = Map.fromList [(mkCId f,ls) | f:ls <- map words ss] - - --- parse trees from Linearize.linearizeMark ----- nubrec and domins are quadratic, but could be (n log n) - -graphvizParseTree :: PGF -> CId -> Expr -> String -graphvizParseTree pgf lang = prGraph False . lin2tree pgf . linMark where - linMark = head . linearizesMark pgf lang - ---- use Just str if you have str to match against - -lin2tree pgf s = trace s $ prelude ++ nodes ++ links where - - prelude = ["rankdir=BU ;", "node [shape = record, color = white] ;"] - - nodeRecs = zip [0..] - (nub (filter (not . null) (nlins [postext] ++ [leaves postext]))) - nlins pts = - nubrec [] $ [(p,cat f) | T (Just f, p) _ <- pts] : - concatMap nlins [ts | T _ ts <- pts] - leaves pt = [(p++[j],s) | (j,(p,s)) <- - zip [9990..] [(p,s) | ((_,p),ss) <- wlins pt, s <- ss]] - - nubrec es rs = case rs of - r:rr -> let r' = filter (not . flip elem es) (nub r) - in r' : nubrec (r' ++ es) rr - _ -> rs - - nodes = map mkStruct nodeRecs - - mkStruct (i,cs) = struct i ++ "[label = \"" ++ fields cs ++ "\"] ;" - cat = showCId . lookValCat pgf - fields cs = concat (intersperse "|" [ mtag (showp p) ++ c | (p,c) <- cs]) - struct i = "struct" ++ show i - - links = map mkEdge domins - domins = nub [((i,x),(j,y)) | - (i,xs) <- nodeRecs, (j,ys) <- nodeRecs, - x <- xs, y <- ys, dominates x y] - dominates (p,x) (q,y) = not (null q) && p == init q - mkEdge ((i,x),(j,y)) = - struct i ++ ":n" ++ uncommas (showp (fst x)) ++ ":s -- " ++ - struct j ++ ":n" ++ uncommas (showp (fst y)) ++ ":n ;" - - postext = readPosText s - --- auxiliaries for graphviz syntax -struct i = "struct" ++ show i -mark (j,n) = "n" ++ show j ++ "a" ++ uncommas n -uncommas = map (\c -> if c==',' then 'c' else c) -tag s = "<" ++ s ++ ">" -showp = init . tail . show -mtag = tag . ('n':) . uncommas - --- word alignments from Linearize.linearizesMark --- words are chunks like {[0,1,1,0] old} - -graphvizAlignment :: PGF -> Expr -> String -graphvizAlignment pgf = prGraph True . lin2graph . linsMark where - linsMark t = [s | la <- cncnames pgf, s <- take 1 (linearizesMark pgf la t)] - -lin2graph :: [String] -> [String] -lin2graph ss = trace (show ss) $ prelude ++ nodes ++ links - - where - - prelude = ["rankdir=LR ;", "node [shape = record] ;"] - - nlins :: [(Int,[((Int,String),String)])] - nlins = [(i, [((j,showp p),unw ws) | (j,((_,p),ws)) <- zip [0..] ws]) | - (i,ws) <- zip [0..] (map (wlins . readPosText) ss)] - - unw = concat . intersperse "\\ " -- space escape in graphviz - - nodes = map mkStruct nlins - - mkStruct (i, ws) = struct i ++ "[label = \"" ++ fields ws ++ "\"] ;" - - fields ws = concat (intersperse "|" [tag (mark m) ++ " " ++ w | (m,w) <- ws]) - - links = nub $ concatMap mkEdge (init nlins) - - mkEdge (i,lin) = let lin' = snd (nlins !! (i+1)) in -- next lin in the list - [edge i v w | (v@(_,p),_) <- lin, (w@(_,q),_) <- lin', p == q] - - edge i v w = - struct i ++ ":" ++ mark v ++ ":e -> " ++ struct (i+1) ++ ":" ++ mark w ++ ":w ;" -{- -alignmentData :: PGF -> [Expr] -> Map.Map String (Map.Map String Double) -alignmentData pgf = mkStat . concatMap (mkAlign . linsMark) where - linsMark t = - [s | la <- take 2 (cncnames pgf), s <- take 1 (linearizesMark pgf la t)] - - mkStat :: [(String,String)] -> Map.Map String (Map.Map String Double) - mkStat = - - mkAlign :: [String] -> [(String,String)] - mkAlign ss = - - nlins :: [(Int,[((Int,String),String)])] - nlins = [(i, [((j,showp p),unw ws) | (j,((_,p),ws)) <- zip [0..] vs]) | - (i,vs) <- zip [0..] (map (wlins . readPosText) ss)] - - nodes = map mkStruct nlins - - mkStruct (i, ws) = struct i ++ "[label = \"" ++ fields ws ++ "\"] ;" - - fields ws = concat (intersperse "|" [tag (mark m) ++ " " ++ w | (m,w) <- ws]) - - links = nub $ concatMap mkEdge (init nlins) - - mkEdge (i,lin) = let lin' = snd (nlins !! (i+1)) in -- next lin in the list - [edge i v w | (v@(_,p),_) <- lin, (w@(_,q),_) <- lin', p == q] - - edge i v w = - struct i ++ ":" ++ mark v ++ ":e -> " ++ struct (i+1) ++ ":" ++ mark w ++ ":w ;" --} - -wlins :: PosText -> [((Maybe CId,[Int]),[String])] -wlins pt = case pt of - T p pts -> concatMap (lins p) pts - M ws -> if null ws then [] else [((Nothing,[]),ws)] - where - lins p pt = case pt of - T q pts -> concatMap (lins q) pts - M ws -> if null ws then [] else [(p,ws)] - -data PosText = - T (Maybe CId,[Int]) [PosText] - | M [String] - deriving Show - -readPosText :: String -> PosText -readPosText = fst . head . (RP.readP_to_S pPosText) where - pPosText = do - RP.char '(' >> RP.skipSpaces - p <- pPos - RP.skipSpaces - ts <- RP.many pPosText - RP.char ')' >> RP.skipSpaces - return (T p ts) - RP.<++ do - ws <- RP.sepBy1 (RP.munch1 (flip notElem "()")) (RP.char ' ') - return (M ws) - pPos = do - fun <- (RP.char '(' >> pCId >>= \f -> RP.char ',' >> (return $ Just f)) - RP.<++ (return Nothing) - RP.char '[' >> RP.skipSpaces - is <- RP.sepBy (RP.munch1 isDigit) (RP.char ',') - RP.char ']' >> RP.skipSpaces - RP.char ')' RP.<++ return ' ' - return (fun,map read is) - - -{- -digraph{ -rankdir ="LR" ; -node [shape = record] ; - -struct1 [label = " this| very| intelligent| man"] ; -struct2 [label = " cet| homme| tres| intelligent| ci"] ; - -struct1:f0 -> struct2:f0 ; -struct1:f1 -> struct2:f2 ; -struct1:f2 -> struct2:f3 ; -struct1:f3 -> struct2:f1 ; -struct1:f0 -> struct2:f4 ; -} --} - diff --git a/src/PGF/doc/Eng.gf b/src/PGF/doc/Eng.gf deleted file mode 100644 index c64f46313..000000000 --- a/src/PGF/doc/Eng.gf +++ /dev/null @@ -1,13 +0,0 @@ -concrete Eng of Ex = { - lincat - S = {s : Str} ; - NP = {s : Str ; n : Num} ; - VP = {s : Num => Str} ; - param - Num = Sg | Pl ; - lin - Pred np vp = {s = np.s ++ vp.s ! np.n} ; - She = {s = "she" ; n = Sg} ; - They = {s = "they" ; n = Pl} ; - Sleep = {s = table {Sg => "sleeps" ; Pl => "sleep"}} ; -} diff --git a/src/PGF/doc/Ex.gf b/src/PGF/doc/Ex.gf deleted file mode 100644 index bd0b03483..000000000 --- a/src/PGF/doc/Ex.gf +++ /dev/null @@ -1,8 +0,0 @@ -abstract Ex = { - cat - S ; NP ; VP ; - fun - Pred : NP -> VP -> S ; - She, They : NP ; - Sleep : VP ; -} diff --git a/src/PGF/doc/Swe.gf b/src/PGF/doc/Swe.gf deleted file mode 100644 index 1d6672371..000000000 --- a/src/PGF/doc/Swe.gf +++ /dev/null @@ -1,13 +0,0 @@ -concrete Swe of Ex = { - lincat - S = {s : Str} ; - NP = {s : Str} ; - VP = {s : Str} ; - param - Num = Sg | Pl ; - lin - Pred np vp = {s = np.s ++ vp.s} ; - She = {s = "hon"} ; - They = {s = "de"} ; - Sleep = {s = "sover"} ; -} diff --git a/src/PGF/doc/Test.gf b/src/PGF/doc/Test.gf deleted file mode 100644 index 5cd4c5474..000000000 --- a/src/PGF/doc/Test.gf +++ /dev/null @@ -1,64 +0,0 @@ --- to test GFCC compilation - -flags coding=utf8 ; - -cat S ; NP ; N ; VP ; - -fun Pred : NP -> VP -> S ; -fun Pred2 : NP -> VP -> NP -> S ; -fun Det, Dets : N -> NP ; -fun Mina, Sina, Me, Te : NP ; -fun Raha, Paska, Pallo : N ; -fun Puhua, Munia, Sanoa : VP ; - -param Person = P1 | P2 | P3 ; -param Number = Sg | Pl ; -param Case = Nom | Part ; - -param NForm = NF Number Case ; -param VForm = VF Number Person ; - -lincat N = Noun ; -lincat VP = Verb ; - -oper Noun = {s : NForm => Str} ; -oper Verb = {s : VForm => Str} ; - -lincat NP = {s : Case => Str ; a : {n : Number ; p : Person}} ; - -lin Pred np vp = {s = np.s ! Nom ++ vp.s ! VF np.a.n np.a.p} ; -lin Pred2 np vp ob = {s = np.s ! Nom ++ vp.s ! VF np.a.n np.a.p ++ ob.s ! Part} ; -lin Det no = {s = \\c => no.s ! NF Sg c ; a = {n = Sg ; p = P3}} ; -lin Dets no = {s = \\c => no.s ! NF Pl c ; a = {n = Pl ; p = P3}} ; -lin Mina = {s = table Case ["minä" ; "minua"] ; a = {n = Sg ; p = P1}} ; -lin Te = {s = table Case ["te" ; "teitä"] ; a = {n = Pl ; p = P2}} ; -lin Sina = {s = table Case ["sinä" ; "sinua"] ; a = {n = Sg ; p = P2}} ; -lin Me = {s = table Case ["me" ; "meitä"] ; a = {n = Pl ; p = P1}} ; - -lin Raha = mkN "raha" ; -lin Paska = mkN "paska" ; -lin Pallo = mkN "pallo" ; -lin Puhua = mkV "puhu" ; -lin Munia = mkV "muni" ; -lin Sanoa = mkV "sano" ; - -oper mkN : Str -> Noun = \raha -> { - s = table { - NF Sg Nom => raha ; - NF Sg Part => raha + "a" ; - NF Pl Nom => raha + "t" ; - NF Pl Part => Predef.tk 1 raha + "oja" - } - } ; - -oper mkV : Str -> Verb = \puhu -> { - s = table { - VF Sg P1 => puhu + "n" ; - VF Sg P2 => puhu + "t" ; - VF Sg P3 => puhu + Predef.dp 1 puhu ; - VF Pl P1 => puhu + "mme" ; - VF Pl P2 => puhu + "tte" ; - VF Pl P3 => puhu + "vat" - } - } ; - diff --git a/src/PGF/doc/gfcc.html b/src/PGF/doc/gfcc.html deleted file mode 100644 index 8f8c478c0..000000000 --- a/src/PGF/doc/gfcc.html +++ /dev/null @@ -1,809 +0,0 @@ - - - - -The GFCC Grammar Format - -

The GFCC Grammar Format

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

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

-

-History: -

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

What is GFCC

-

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

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

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

-

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

-

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

-

GFCC vs. GFC

-

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

-

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

-

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

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

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

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

-

The syntax of GFCC files

-

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

-

Top level

-

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

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

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

-

-The judgement forms have the following syntax. -

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

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

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

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

-

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

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

-

Abstract syntax

-

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

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

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

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

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

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

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

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

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

-

Concrete syntax

-

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

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

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

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

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

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

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

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

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

-

The semantics of concrete syntax terms

-

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

-

Linearization and realization

-

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

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

-TODO: bindings must be supported. -

-

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

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

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

-

Term evaluation

-

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

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

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

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

-

The special term constructors

-

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

-

-Global constants -

-
-    Term ::= CId ;
-
-

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

-

-Prefix-suffix tables -

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

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

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

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

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

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

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

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

-

Compiling to GFCC

-

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

-

-The compilation phases are the following -

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

Problems in GFCC compilation

-

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

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

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

-

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

-

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

-

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

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

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

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

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

-
-    Ag np.n P3
-
-

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

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

-which can then be translated to the GFCC term -

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

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

-

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

-
-    Ag np.n np.p
-
-

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

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

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

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

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

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

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

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

-

The representation of linearization types

-

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

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

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

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

-

Running the compiler and the GFCC interpreter

-

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

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

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

-
-    make gfc
-
-

-in GF/src, and invoked by -

-
-    gfc --make FILES
-
-

-

The reference interpreter

-

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

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

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

-

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

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

-

-To compile the interpreter, type -

-
-    make gfcc
-
-

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

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

-The available commands are -

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

Embedded formats

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

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

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

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

Some things to do

-

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

-

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

-

-Interpreter in Java. -

-

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

-

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

-

-Syntax editor based on GFCC. -

-

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

- - - - diff --git a/src/PGF/doc/gfcc.txt b/src/PGF/doc/gfcc.txt deleted file mode 100644 index 5dcf2fbdc..000000000 --- a/src/PGF/doc/gfcc.txt +++ /dev/null @@ -1,712 +0,0 @@ -The GFCC Grammar Format -Aarne Ranta -December 14, 2007 - -Author's address: -[``http://www.cs.chalmers.se/~aarne`` http://www.cs.chalmers.se/~aarne] - -% to compile: txt2tags -thtml --toc gfcc.txt - -History: -- 14 Dec 2007: simpler, Lisp-like concrete syntax of GFCC -- 5 Oct 2007: new, better structured GFCC with full expressive power -- 19 Oct: translation of lincats, new figures on C++ -- 3 Oct 2006: first version - - -==What is GFCC== - -GFCC is a low-level format for GF grammars. Its aim is to contain the minimum -that is needed to process GF grammars at runtime. This minimality has three -advantages: -- compact grammar files and run-time objects -- time and space efficient processing -- simple definition of interpreters - - -Thus we also want to call GFCC the **portable grammar format**. - -The idea is that all embedded GF applications use GFCC. -The GF system would be primarily used as a compiler and as a grammar -development tool. - -Since GFCC is implemented in BNFC, a parser of the format is readily -available for C, C++, C#, Haskell, Java, and OCaml. Also an XML -representation can be generated in BNFC. A -[reference implementation ../] -of linearization and some other functions has been written in Haskell. - - -==GFCC vs. GFC== - -GFCC is aimed to replace GFC as the run-time grammar format. GFC was designed -to be a run-time format, but also to -support separate compilation of grammars, i.e. -to store the results of compiling -individual GF modules. But this means that GFC has to contain extra information, -such as type annotations, which is only needed in compilation and not at -run-time. In particular, the pattern matching syntax and semantics of GFC is -complex and therefore difficult to implement in new platforms. - -Actually, GFC is planned to be omitted also as the target format of -separate compilation, where plain GF (type annotated and partially evaluated) -will be used instead. GFC provides only marginal advantages as a target format -compared with GF, and it is therefore just extra weight to carry around this -format. - -The main differences of GFCC compared with GFC (and GF) can be -summarized as follows: -- there are no modules, and therefore no qualified names -- a GFCC grammar is multilingual, and consists of a common abstract syntax - together with one concrete syntax per language -- records and tables are replaced by arrays -- record labels and parameter values are replaced by integers -- record projection and table selection are replaced by array indexing -- even though the format does support dependent types and higher-order abstract - syntax, there is no interpreted yet that does this - - - -Here is an example of a GF grammar, consisting of three modules, -as translated to GFCC. The representations are aligned; -thus they do not completely -reflect the order of judgements in GFCC files, which have different orders of -blocks of judgements, and alphabetical sorting. -``` - grammar Ex(Eng,Swe); - -abstract Ex = { abstract { - cat cat - S ; NP ; VP ; NP[]; S[]; VP[]; - fun fun - Pred : NP -> VP -> S ; Pred=[(($ 0! 1),(($ 1! 0)!($ 0! 0)))]; - She, They : NP ; She=[0,"she"]; - Sleep : VP ; They=[1,"they"]; - Sleep=[["sleeps","sleep"]]; -} } ; - -concrete Eng of Ex = { concrete Eng { - lincat lincat - S = {s : Str} ; S=[()]; - NP = {s : Str ; n : Num} ; NP=[1,()]; - VP = {s : Num => Str} ; VP=[[(),()]]; - param - Num = Sg | Pl ; - lin lin - Pred np vp = { Pred=[(($ 0! 1),(($ 1! 0)!($ 0! 0)))]; - s = np.s ++ vp.s ! np.n} ; - She = {s = "she" ; n = Sg} ; She=[0,"she"]; - They = {s = "they" ; n = Pl} ; They = [1, "they"]; - Sleep = {s = table { Sleep=[["sleeps","sleep"]]; - Sg => "sleeps" ; - Pl => "sleep" - } - } ; -} } ; - -concrete Swe of Ex = { concrete Swe { - lincat lincat - S = {s : Str} ; S=[()]; - NP = {s : Str} ; NP=[()]; - VP = {s : Str} ; VP=[()]; - param - Num = Sg | Pl ; - lin lin - Pred np vp = { Pred = [(($0!0),($1!0))]; - s = np.s ++ vp.s} ; - She = {s = "hon"} ; She = ["hon"]; - They = {s = "de"} ; They = ["de"]; - Sleep = {s = "sover"} ; Sleep = ["sover"]; -} } ; -``` - -==The syntax of GFCC files== - -The complete BNFC grammar, from which -the rules in this section are taken, is in the file -[``GF/GFCC/GFCC.cf`` ../DataGFCC.cf]. - - -===Top level=== - -A grammar has a header telling the name of the abstract syntax -(often specifying an application domain), and the names of -the concrete languages. The abstract syntax and the concrete -syntaxes themselves follow. -``` - Grm. Grammar ::= - "grammar" CId "(" [CId] ")" ";" - Abstract ";" - [Concrete] ; - - Abs. Abstract ::= - "abstract" "{" - "flags" [Flag] - "fun" [FunDef] - "cat" [CatDef] - "}" ; - - Cnc. Concrete ::= - "concrete" CId "{" - "flags" [Flag] - "lin" [LinDef] - "oper" [LinDef] - "lincat" [LinDef] - "lindef" [LinDef] - "printname" [LinDef] - "}" ; -``` -This syntax organizes each module to a sequence of **fields**, such -as flags, linearizations, operations, linearization types, etc. -It is envisaged that particular applications can ignore some -of the fields, typically so that earlier fields are more -important than later ones. - -The judgement forms have the following syntax. -``` - Flg. Flag ::= CId "=" String ; - Cat. CatDef ::= CId "[" [Hypo] "]" ; - Fun. FunDef ::= CId ":" Type "=" Exp ; - Lin. LinDef ::= CId "=" Term ; -``` -For the run-time system, the reference implementation in Haskell -uses a structure that gives efficient look-up: -``` - data GFCC = GFCC { - absname :: CId , - cncnames :: [CId] , - abstract :: Abstr , - concretes :: Map CId Concr - } - - data Abstr = Abstr { - aflags :: Map CId String, -- value of a flag - funs :: Map CId (Type,Exp), -- type and def of a fun - cats :: Map CId [Hypo], -- context of a cat - catfuns :: Map CId [CId] -- funs yielding a cat (redundant, for fast lookup) - } - - data Concr = Concr { - flags :: Map CId String, -- value of a flag - lins :: Map CId Term, -- lin of a fun - opers :: Map CId Term, -- oper generated by subex elim - lincats :: Map CId Term, -- lin type of a cat - lindefs :: Map CId Term, -- lin default of a cat - printnames :: Map CId Term -- printname of a cat or a fun - } -``` -These definitions are from [``GF/GFCC/DataGFCC.hs`` ../DataGFCC.hs]. - -Identifiers (``CId``) are like ``Ident`` in GF, except that -the compiler produces constants prefixed with ``_`` in -the common subterm elimination optimization. -``` - token CId (('_' | letter) (letter | digit | '\'' | '_')*) ; -``` - - -===Abstract syntax=== - -Types are first-order function types built from argument type -contexts and value types. -category symbols. Syntax trees (``Exp``) are -rose trees with nodes consisting of a head (``Atom``) and -bound variables (``CId``). -``` - DTyp. Type ::= "[" [Hypo] "]" CId [Exp] ; - DTr. Exp ::= "[" "(" [CId] ")" Atom [Exp] "]" ; - Hyp. Hypo ::= CId ":" Type ; -``` -The head Atom is either a function -constant, a bound variable, or a metavariable, or a string, integer, or float -literal. -``` - AC. Atom ::= CId ; - AS. Atom ::= String ; - AI. Atom ::= Integer ; - AF. Atom ::= Double ; - AM. Atom ::= "?" Integer ; -``` -The context-free types and trees of the "old GFCC" are special -cases, which can be defined as follows: -``` - Typ. Type ::= [CId] "->" CId - Typ args val = DTyp [Hyp (CId "_") arg | arg <- args] val - - Tr. Exp ::= "(" CId [Exp] ")" - Tr fun exps = DTr [] fun exps -``` -To store semantic (``def``) definitions by cases, the following expression -form is provided, but it is only meaningful in the last field of a function -declaration in an abstract syntax: -``` - EEq. Exp ::= "{" [Equation] "}" ; - Equ. Equation ::= [Exp] "->" Exp ; -``` -Notice that expressions are used to encode patterns. Primitive notions -(the default semantics in GF) are encoded as empty sets of equations -(``[]``). For a constructor (canonical form) of a category ``C``, we -aim to use the encoding as the application ``(_constr C)``. - - - -===Concrete syntax=== - -Linearization terms (``Term``) are built as follows. -Constructor names are shown to make the later code -examples readable. -``` - R. Term ::= "[" [Term] "]" ; -- array (record/table) - P. Term ::= "(" Term "!" Term ")" ; -- access to field (projection/selection) - S. Term ::= "(" [Term] ")" ; -- concatenated sequence - K. Term ::= Tokn ; -- token - V. Term ::= "$" Integer ; -- argument (subtree) - C. Term ::= Integer ; -- array index (label/parameter value) - FV. Term ::= "[|" [Term] "|]" ; -- free variation - TM. Term ::= "?" ; -- linearization of metavariable -``` -Tokens are strings or (maybe obsolescent) prefix-dependent -variant lists. -``` - KS. Tokn ::= String ; - KP. Tokn ::= "[" "pre" [String] "[" [Variant] "]" "]" ; - Var. Variant ::= [String] "/" [String] ; -``` -Two special forms of terms are introduced by the compiler -as optimizations. They can in principle be eliminated, but -their presence makes grammars much more compact. Their semantics -will be explained in a later section. -``` - F. Term ::= CId ; -- global constant - W. Term ::= "(" String "+" Term ")" ; -- prefix + suffix table -``` -There is also a deprecated form of "record parameter alias", -``` - RP. Term ::= "(" Term "@" Term ")"; -- DEPRECATED -``` -which will be removed when the migration to new GFCC is complete. - - - -==The semantics of concrete syntax terms== - -The code in this section is from [``GF/GFCC/Linearize.hs`` ../Linearize.hs]. - - -===Linearization and realization=== - -The linearization algorithm is essentially the same as in -GFC: a tree is linearized by evaluating its linearization term -in the environment of the linearizations of the subtrees. -Literal atoms are linearized in the obvious way. -The function also needs to know the language (i.e. concrete syntax) -in which linearization is performed. -``` - linExp :: GFCC -> CId -> Exp -> Term - linExp gfcc lang tree@(DTr _ at trees) = case at of - AC fun -> comp (Prelude.map lin trees) $ look fun - AS s -> R [kks (show s)] -- quoted - AI i -> R [kks (show i)] - AF d -> R [kks (show d)] - AM -> TM - where - lin = linExp gfcc lang - comp = compute gfcc lang - look = lookLin gfcc lang -``` -TODO: bindings must be supported. - -The result of linearization is usually a record, which is realized as -a string using the following algorithm. -``` - realize :: Term -> String - realize trm = case trm of - R (t:_) -> realize t - S ss -> unwords $ Prelude.map realize ss - K (KS s) -> s - K (KP s _) -> unwords s ---- prefix choice TODO - W s t -> s ++ realize t - FV (t:_) -> realize t - TM -> "?" -``` -Notice that realization always picks the first field of a record. -If a linearization type has more than one field, the first field -does not necessarily contain the desired string. -Also notice that the order of record fields in GFCC is not necessarily -the same as in GF source. - - -===Term evaluation=== - -Evaluation follows call-by-value order, with two environments -needed: -- the grammar (a concrete syntax) to give the global constants -- an array of terms to give the subtree linearizations - - -The code is presented in one-level pattern matching, to -enable reimplementations in languages that do not permit -deep patterns (such as Java and C++). -``` -compute :: GFCC -> CId -> [Term] -> Term -> Term -compute gfcc lang args = comp where - comp trm = case trm of - P r p -> proj (comp r) (comp p) - W s t -> W s (comp t) - R ts -> R $ Prelude.map comp ts - V i -> idx args (fromInteger i) -- already computed - F c -> comp $ look c -- not computed (if contains V) - FV ts -> FV $ Prelude.map comp ts - S ts -> S $ Prelude.filter (/= S []) $ Prelude.map comp ts - _ -> trm - - look = lookOper gfcc lang - - idx xs i = xs !! i - - proj r p = case (r,p) of - (_, FV ts) -> FV $ Prelude.map (proj r) ts - (FV ts, _ ) -> FV $ Prelude.map (\t -> proj t p) ts - (W s t, _) -> kks (s ++ getString (proj t p)) - _ -> comp $ getField r (getIndex p) - - getString t = case t of - K (KS s) -> s - _ -> trace ("ERROR in grammar compiler: string from "++ show t) "ERR" - - getIndex t = case t of - C i -> fromInteger i - RP p _ -> getIndex p - TM -> 0 -- default value for parameter - _ -> trace ("ERROR in grammar compiler: index from " ++ show t) 0 - - getField t i = case t of - R rs -> idx rs i - RP _ r -> getField r i - TM -> TM - _ -> trace ("ERROR in grammar compiler: field from " ++ show t) t -``` - -===The special term constructors=== - -The three forms introduced by the compiler may a need special -explanation. - -Global constants -``` - Term ::= CId ; -``` -are shorthands for complex terms. They are produced by the -compiler by (iterated) **common subexpression elimination**. -They are often more powerful than hand-devised code sharing in the source -code. They could be computed off-line by replacing each identifier by -its definition. - -**Prefix-suffix tables** -``` - Term ::= "(" String "+" Term ")" ; -``` -represent tables of word forms divided to the longest common prefix -and its array of suffixes. In the example grammar above, we have -``` - Sleep = [("sleep" + ["s",""])] -``` -which in fact is equal to the array of full forms -``` - ["sleeps", "sleep"] -``` -The power of this construction comes from the fact that suffix sets -tend to be repeated in a language, and can therefore be collected -by common subexpression elimination. It is this technique that -explains the used syntax rather than the more accurate -``` - "(" String "+" [String] ")" -``` -since we want the suffix part to be a ``Term`` for the optimization to -take effect. - - - -==Compiling to GFCC== - -Compilation to GFCC is performed by the GF grammar compiler, and -GFCC interpreters need not know what it does. For grammar writers, -however, it might be interesting to know what happens to the grammars -in the process. - -The compilation phases are the following -+ type check and partially evaluate GF source -+ create a symbol table mapping the GF parameter and record types to - fixed-size arrays, and parameter values and record labels to integers -+ traverse the linearization rules replacing parameters and labels by integers -+ reorganize the created GF grammar so that it has just one abstract syntax - and one concrete syntax per language -+ TODO: apply UTF8 encoding to the grammar, if not yet applied (this is told by the - ``coding`` flag) -+ translate the GF grammar object to a GFCC grammar object, using a simple - compositional mapping -+ perform the word-suffix optimization on GFCC linearization terms -+ perform subexpression elimination on each concrete syntax module -+ print out the GFCC code - - - - -===Problems in GFCC compilation=== - -Two major problems had to be solved in compiling GF to GFCC: -- consistent order of tables and records, to permit the array translation -- run-time variables in complex parameter values. - - -The current implementation is still experimental and may fail -to generate correct code. Any errors remaining are likely to be -related to the two problems just mentioned. - -The order problem is solved in slightly different ways for tables and records. -In both cases, **eta expansion** is used to establish a -canonical order. Tables are ordered by applying the preorder induced -by ``param`` definitions. Records are ordered by sorting them by labels. -This means that -e.g. the ``s`` field will in general no longer appear as the first -field, even if it does so in the GF source code. But relying on the -order of fields in a labelled record would be misplaced anyway. - -The canonical form of records is further complicated by lock fields, -i.e. dummy fields of form ``lock_C = <>``, which are added to grammar -libraries to force intensionality of linearization types. The problem -is that the absence of a lock field only generates a warning, not -an error. Therefore a GF grammar can contain objects of the same -type with and without a lock field. This problem was solved in GFCC -generation by just removing all lock fields (defined as fields whose -type is the empty record type). This has the further advantage of -(slightly) reducing the grammar size. More importantly, it is safe -to remove lock fields, because they are never used in computation, -and because intensional types are only needed in grammars reused -as libraries, not in grammars used at runtime. - -While the order problem is rather bureaucratic in nature, run-time -variables are an interesting problem. They arise in the presence -of complex parameter values, created by argument-taking constructors -and parameter records. To give an example, consider the GF parameter -type system -``` - Number = Sg | Pl ; - Person = P1 | P2 | P3 ; - Agr = Ag Number Person ; -``` -The values can be translated to integers in the expected way, -``` - Sg = 0, Pl = 1 - P1 = 0, P2 = 1, P3 = 2 - Ag Sg P1 = 0, Ag Sg P2 = 1, Ag Sg P3 = 2, - Ag Pl P1 = 3, Ag Pl P2 = 4, Ag Pl P3 = 5 -``` -However, an argument of ``Agr`` can be a run-time variable, as in -``` - Ag np.n P3 -``` -This expression must first be translated to a case expression, -``` - case np.n of { - 0 => 2 ; - 1 => 5 - } -``` -which can then be translated to the GFCC term -``` - ([2,5] ! ($0 ! $1)) -``` -assuming that the variable ``np`` is the first argument and that its -``Number`` field is the second in the record. - -This transformation of course has to be performed recursively, since -there can be several run-time variables in a parameter value: -``` - Ag np.n np.p -``` -A similar transformation would be possible to deal with the double -role of parameter records discussed above. Thus the type -``` - RNP = {n : Number ; p : Person} -``` -could be uniformly translated into the set ``{0,1,2,3,4,5}`` -as ``Agr`` above. Selections would be simple instances of indexing. -But any projection from the record should be translated into -a case expression, -``` - rnp.n ===> - case rnp of { - 0 => 0 ; - 1 => 0 ; - 2 => 0 ; - 3 => 1 ; - 4 => 1 ; - 5 => 1 - } -``` -To avoid the code bloat resulting from this, we have chosen to -deal with records by a **currying** transformation: -``` - table {n : Number ; p : Person} {... ...} - ===> - table Number {Sg => table Person {...} ; table Person {...}} -``` -This is performed when GFCC is generated. Selections with -records have to be treated likewise, -``` - t ! r ===> t ! r.n ! r.p -``` - - -===The representation of linearization types=== - -Linearization types (``lincat``) are not needed when generating with -GFCC, but they have been added to enable parser generation directly from -GFCC. The linearization type definitions are shown as a part of the -concrete syntax, by using terms to represent types. Here is the table -showing how different linearization types are encoded. -``` - P* = max(P) -- parameter type - {r1 : T1 ; ... ; rn : Tn}* = [T1*,...,Tn*] -- record - (P => T)* = [T* ,...,T*] -- table, size(P) cases - Str* = () -``` -For example, the linearization type ``present/CatEng.NP`` is -translated as follows: -``` - NP = { - a : { -- 6 = 2*3 values - n : {ParamX.Number} ; -- 2 values - p : {ParamX.Person} -- 3 values - } ; - s : {ResEng.Case} => Str -- 3 values - } - - __NP = [[1,2],[(),(),()]] -``` - - - - -===Running the compiler and the GFCC interpreter=== - -GFCC generation is a part of the -[developers' version http://www.cs.chalmers.se/Cs/Research/Language-technology/darcs/GF/doc/darcs.html] -of GF since September 2006. To invoke the compiler, the flag -``-printer=gfcc`` to the command -``pm = print_multi`` is used. It is wise to recompile the grammar from -source, since previously compiled libraries may not obey the canonical -order of records. -Here is an example, performed in -[example/bronzeage ../../../../../examples/bronzeage]. -``` - i -src -path=.:prelude:resource-1.0/* -optimize=all_subs BronzeageEng.gf - i -src -path=.:prelude:resource-1.0/* -optimize=all_subs BronzeageGer.gf - strip - pm -printer=gfcc | wf bronze.gfcc -``` -There is also an experimental batch compiler, which does not use the GFC -format or the record aliases. It can be produced by -``` - make gfc -``` -in ``GF/src``, and invoked by -``` - gfc --make FILES -``` - - - - -==The reference interpreter== - -The reference interpreter written in Haskell consists of the following files: -``` - -- source file for BNFC - GFCC.cf -- labelled BNF grammar of gfcc - - -- files generated by BNFC - AbsGFCC.hs -- abstrac syntax datatypes - ErrM.hs -- error monad used internally - LexGFCC.hs -- lexer of gfcc files - ParGFCC.hs -- parser of gfcc files and syntax trees - PrintGFCC.hs -- printer of gfcc files and syntax trees - - -- hand-written files - DataGFCC.hs -- grammar datatype, post-parser grammar creation - Linearize.hs -- linearization and evaluation - Macros.hs -- utilities abstracting away from GFCC datatypes - Generate.hs -- random and exhaustive generation, generate-and-test parsing - API.hs -- functionalities accessible in embedded GF applications - Generate.hs -- random and exhaustive generation - Shell.hs -- main function - a simple command interpreter -``` -It is included in the -[developers' version http://www.cs.chalmers.se/Cs/Research/Language-technology/darcs/GF/doc/darcs.html] -of GF, in the subdirectories [``GF/src/GF/GFCC`` ../] and -[``GF/src/GF/Devel`` ../../Devel]. - -As of September 2007, default parsing in main GF uses GFCC (implemented by Krasimir -Angelov). The interpreter uses the relevant modules -``` - GF/Conversions/SimpleToFCFG.hs -- generate parser from GFCC - GF/Parsing/FCFG.hs -- run the parser -``` - - -To compile the interpreter, type -``` - make gfcc -``` -in ``GF/src``. To run it, type -``` - ./gfcc -``` -The available commands are -- ``gr ``: generate a number of random trees in category. - and show their linearizations in all languages -- ``grt ``: generate a number of random trees in category. - and show the trees and their linearizations in all languages -- ``gt ``: generate a number of trees in category from smallest, - and show their linearizations in all languages -- ``gtt ``: generate a number of trees in category from smallest, - and show the trees and their linearizations in all languages -- ``p ``: parse a string into a set of trees -- ``lin ``: linearize tree in all languages, also showing full records -- ``q``: terminate the system cleanly - - - -==Embedded formats== - -- JavaScript: compiler of linearization and abstract syntax - -- Haskell: compiler of abstract syntax and interpreter with parsing, - linearization, and generation - -- C: compiler of linearization (old GFCC) - -- C++: embedded interpreter supporting linearization (old GFCC) - - - -==Some things to do== - -Support for dependent types, higher-order abstract syntax, and -semantic definition in GFCC generation and interpreters. - -Replacing the entire GF shell by one based on GFCC. - -Interpreter in Java. - -Hand-written parsers for GFCC grammars to reduce code size -(and efficiency?) of interpreters. - -Binary format and/or file compression of GFCC output. - -Syntax editor based on GFCC. - -Rewriting of resource libraries in order to exploit the -word-suffix sharing better (depth-one tables, as in FM). - diff --git a/src/PGF/doc/old-GFCC.cf b/src/PGF/doc/old-GFCC.cf deleted file mode 100644 index 65657a259..000000000 --- a/src/PGF/doc/old-GFCC.cf +++ /dev/null @@ -1,50 +0,0 @@ -Grm. Grammar ::= Header ";" Abstract ";" [Concrete] ; -Hdr. Header ::= "grammar" CId "(" [CId] ")" ; -Abs. Abstract ::= "abstract" "{" [AbsDef] "}" ; -Cnc. Concrete ::= "concrete" CId "{" [CncDef] "}" ; - -Fun. AbsDef ::= CId ":" Type "=" Exp ; ---AFl. AbsDef ::= "%" CId "=" String ; -- flag -Lin. CncDef ::= CId "=" Term ; ---CFl. CncDef ::= "%" CId "=" String ; -- flag - -Typ. Type ::= [CId] "->" CId ; -Tr. Exp ::= "(" Atom [Exp] ")" ; -AC. Atom ::= CId ; -AS. Atom ::= String ; -AI. Atom ::= Integer ; -AF. Atom ::= Double ; -AM. Atom ::= "?" ; -trA. Exp ::= Atom ; -define trA a = Tr a [] ; - -R. Term ::= "[" [Term] "]" ; -- record/table -P. Term ::= "(" Term "!" Term ")" ; -- projection/selection -S. Term ::= "(" [Term] ")" ; -- sequence with ++ -K. Term ::= Tokn ; -- token -V. Term ::= "$" Integer ; -- argument -C. Term ::= Integer ; -- parameter value/label -F. Term ::= CId ; -- global constant -FV. Term ::= "[|" [Term] "|]" ; -- free variation -W. Term ::= "(" String "+" Term ")" ; -- prefix + suffix table -RP. Term ::= "(" Term "@" Term ")"; -- record parameter alias -TM. Term ::= "?" ; -- lin of metavariable - -L. Term ::= "(" CId "->" Term ")" ; -- lambda abstracted table -BV. Term ::= "#" CId ; -- lambda-bound variable - -KS. Tokn ::= String ; -KP. Tokn ::= "[" "pre" [String] "[" [Variant] "]" "]" ; -Var. Variant ::= [String] "/" [String] ; - - -terminator Concrete ";" ; -terminator AbsDef ";" ; -terminator CncDef ";" ; -separator CId "," ; -separator Term "," ; -terminator Exp "" ; -terminator String "" ; -separator Variant "," ; - -token CId (('_' | letter) (letter | digit | '\'' | '_')*) ; diff --git a/src/PGF/doc/old-gfcc.txt b/src/PGF/doc/old-gfcc.txt deleted file mode 100644 index 6ffd9bd64..000000000 --- a/src/PGF/doc/old-gfcc.txt +++ /dev/null @@ -1,656 +0,0 @@ -The GFCC Grammar Format -Aarne Ranta -October 19, 2006 - -Author's address: -[``http://www.cs.chalmers.se/~aarne`` http://www.cs.chalmers.se/~aarne] - -% to compile: txt2tags -thtml --toc gfcc.txt - -History: -- 19 Oct: translation of lincats, new figures on C++ -- 3 Oct 2006: first version - - -==What is GFCC== - -GFCC is a low-level format for GF grammars. Its aim is to contain the minimum -that is needed to process GF grammars at runtime. This minimality has three -advantages: -- compact grammar files and run-time objects -- time and space efficient processing -- simple definition of interpreters - - -The idea is that all embedded GF applications are compiled to GFCC. -The GF system would be primarily used as a compiler and as a grammar -development tool. - -Since GFCC is implemented in BNFC, a parser of the format is readily -available for C, C++, Haskell, Java, and OCaml. Also an XML -representation is generated in BNFC. A -[reference implementation ../] -of linearization and some other functions has been written in Haskell. - - -==GFCC vs. GFC== - -GFCC is aimed to replace GFC as the run-time grammar format. GFC was designed -to be a run-time format, but also to -support separate compilation of grammars, i.e. -to store the results of compiling -individual GF modules. But this means that GFC has to contain extra information, -such as type annotations, which is only needed in compilation and not at -run-time. In particular, the pattern matching syntax and semantics of GFC is -complex and therefore difficult to implement in new platforms. - -The main differences of GFCC compared with GFC can be summarized as follows: -- there are no modules, and therefore no qualified names -- a GFCC grammar is multilingual, and consists of a common abstract syntax - together with one concrete syntax per language -- records and tables are replaced by arrays -- record labels and parameter values are replaced by integers -- record projection and table selection are replaced by array indexing -- there is (so far) no support for dependent types or higher-order abstract - syntax (which would be easy to add, but make interpreters much more difficult - to write) - - -Here is an example of a GF grammar, consisting of three modules, -as translated to GFCC. The representations are aligned, with the exceptions -due to the alphabetical sorting of GFCC grammars. -``` - grammar Ex(Eng,Swe); - -abstract Ex = { abstract { - cat - S ; NP ; VP ; - fun - Pred : NP -> VP -> S ; Pred : NP,VP -> S = (Pred); - She, They : NP ; She : -> NP = (She); - Sleep : VP ; Sleep : -> VP = (Sleep); - They : -> NP = (They); -} } ; - -concrete Eng of Ex = { concrete Eng { - lincat - S = {s : Str} ; - NP = {s : Str ; n : Num} ; - VP = {s : Num => Str} ; - param - Num = Sg | Pl ; - lin - Pred np vp = { Pred = [(($0!1),(($1!0)!($0!0)))]; - s = np.s ++ vp.s ! np.n} ; - She = {s = "she" ; n = Sg} ; She = [0, "she"]; - They = {s = "they" ; n = Pl} ; - Sleep = {s = table { Sleep = [("sleep" + ["s",""])]; - Sg => "sleeps" ; - Pl => "sleep" They = [1, "they"]; - } } ; - } ; -} - -concrete Swe of Ex = { concrete Swe { - lincat - S = {s : Str} ; - NP = {s : Str} ; - VP = {s : Str} ; - param - Num = Sg | Pl ; - lin - Pred np vp = { Pred = [(($0!0),($1!0))]; - s = np.s ++ vp.s} ; - She = {s = "hon"} ; She = ["hon"]; - They = {s = "de"} ; They = ["de"]; - Sleep = {s = "sover"} ; Sleep = ["sover"]; -} } ; -``` - -==The syntax of GFCC files== - -===Top level=== - -A grammar has a header telling the name of the abstract syntax -(often specifying an application domain), and the names of -the concrete languages. The abstract syntax and the concrete -syntaxes themselves follow. -``` - Grammar ::= Header ";" Abstract ";" [Concrete] ; - Header ::= "grammar" CId "(" [CId] ")" ; - Abstract ::= "abstract" "{" [AbsDef] "}" ; - Concrete ::= "concrete" CId "{" [CncDef] "}" ; -``` -Abstract syntax judgements give typings and semantic definitions. -Concrete syntax judgements give linearizations. -``` - AbsDef ::= CId ":" Type "=" Exp ; - CncDef ::= CId "=" Term ; -``` -Also flags are possible, local to each "module" (i.e. abstract and concretes). -``` - AbsDef ::= "%" CId "=" String ; - CncDef ::= "%" CId "=" String ; -``` -For the run-time system, the reference implementation in Haskell -uses a structure that gives efficient look-up: -``` - data GFCC = GFCC { - absname :: CId , - cncnames :: [CId] , - abstract :: Abstr , - concretes :: Map CId Concr - } - - data Abstr = Abstr { - funs :: Map CId Type, -- find the type of a fun - cats :: Map CId [CId] -- find the funs giving a cat - } - - type Concr = Map CId Term -``` - - -===Abstract syntax=== - -Types are first-order function types built from -category symbols. Syntax trees (``Exp``) are -rose trees with the head (``Atom``) either a function -constant, a metavariable, or a string, integer, or float -literal. -``` - Type ::= [CId] "->" CId ; - Exp ::= "(" Atom [Exp] ")" ; - Atom ::= CId ; -- function constant - Atom ::= "?" ; -- metavariable - Atom ::= String ; -- string literal - Atom ::= Integer ; -- integer literal - Atom ::= Double ; -- float literal -``` - - -===Concrete syntax=== - -Linearization terms (``Term``) are built as follows. -Constructor names are shown to make the later code -examples readable. -``` - R. Term ::= "[" [Term] "]" ; -- array - P. Term ::= "(" Term "!" Term ")" ; -- access to indexed field - S. Term ::= "(" [Term] ")" ; -- sequence with ++ - K. Term ::= Tokn ; -- token - V. Term ::= "$" Integer ; -- argument - C. Term ::= Integer ; -- array index - FV. Term ::= "[|" [Term] "|]" ; -- free variation - TM. Term ::= "?" ; -- linearization of metavariable -``` -Tokens are strings or (maybe obsolescent) prefix-dependent -variant lists. -``` - KS. Tokn ::= String ; - KP. Tokn ::= "[" "pre" [String] "[" [Variant] "]" "]" ; - Var. Variant ::= [String] "/" [String] ; -``` -Three special forms of terms are introduced by the compiler -as optimizations. They can in principle be eliminated, but -their presence makes grammars much more compact. Their semantics -will be explained in a later section. -``` - F. Term ::= CId ; -- global constant - W. Term ::= "(" String "+" Term ")" ; -- prefix + suffix table - RP. Term ::= "(" Term "@" Term ")"; -- record parameter alias -``` -Identifiers are like ``Ident`` in GF and GFC, except that -the compiler produces constants prefixed with ``_`` in -the common subterm elimination optimization. -``` - token CId (('_' | letter) (letter | digit | '\'' | '_')*) ; -``` - - -==The semantics of concrete syntax terms== - -===Linearization and realization=== - -The linearization algorithm is essentially the same as in -GFC: a tree is linearized by evaluating its linearization term -in the environment of the linearizations of the subtrees. -Literal atoms are linearized in the obvious way. -The function also needs to know the language (i.e. concrete syntax) -in which linearization is performed. -``` - linExp :: GFCC -> CId -> Exp -> Term - linExp mcfg lang tree@(Tr at trees) = case at of - AC fun -> comp (Prelude.map lin trees) $ look fun - AS s -> R [kks (show s)] -- quoted - AI i -> R [kks (show i)] - AF d -> R [kks (show d)] - AM -> TM - where - lin = linExp mcfg lang - comp = compute mcfg lang - look = lookLin mcfg lang -``` -The result of linearization is usually a record, which is realized as -a string using the following algorithm. -``` - realize :: Term -> String - realize trm = case trm of - R (t:_) -> realize t - S ss -> unwords $ Prelude.map realize ss - K (KS s) -> s - K (KP s _) -> unwords s ---- prefix choice TODO - W s t -> s ++ realize t - FV (t:_) -> realize t - TM -> "?" -``` -Since the order of record fields is not necessarily -the same as in GF source, -this realization does not work securely for -categories whose lincats more than one field. - - -===Term evaluation=== - -Evaluation follows call-by-value order, with two environments -needed: -- the grammar (a concrete syntax) to give the global constants -- an array of terms to give the subtree linearizations - - -The code is presented in one-level pattern matching, to -enable reimplementations in languages that do not permit -deep patterns (such as Java and C++). -``` -compute :: GFCC -> CId -> [Term] -> Term -> Term -compute mcfg lang args = comp where - comp trm = case trm of - P r p -> proj (comp r) (comp p) - RP i t -> RP (comp i) (comp t) - W s t -> W s (comp t) - R ts -> R $ Prelude.map comp ts - V i -> idx args (fromInteger i) -- already computed - F c -> comp $ look c -- not computed (if contains V) - FV ts -> FV $ Prelude.map comp ts - S ts -> S $ Prelude.filter (/= S []) $ Prelude.map comp ts - _ -> trm - - look = lookLin mcfg lang - - idx xs i = xs !! i - - proj r p = case (r,p) of - (_, FV ts) -> FV $ Prelude.map (proj r) ts - (W s t, _) -> kks (s ++ getString (proj t p)) - _ -> comp $ getField r (getIndex p) - - getString t = case t of - K (KS s) -> s - _ -> trace ("ERROR in grammar compiler: string from "++ show t) "ERR" - - getIndex t = case t of - C i -> fromInteger i - RP p _ -> getIndex p - TM -> 0 -- default value for parameter - _ -> trace ("ERROR in grammar compiler: index from " ++ show t) 0 - - getField t i = case t of - R rs -> idx rs i - RP _ r -> getField r i - TM -> TM - _ -> trace ("ERROR in grammar compiler: field from " ++ show t) t -``` - -===The special term constructors=== - -The three forms introduced by the compiler may a need special -explanation. - -Global constants -``` - Term ::= CId ; -``` -are shorthands for complex terms. They are produced by the -compiler by (iterated) common subexpression elimination. -They are often more powerful than hand-devised code sharing in the source -code. They could be computed off-line by replacing each identifier by -its definition. - -Prefix-suffix tables -``` - Term ::= "(" String "+" Term ")" ; -``` -represent tables of word forms divided to the longest common prefix -and its array of suffixes. In the example grammar above, we have -``` - Sleep = [("sleep" + ["s",""])] -``` -which in fact is equal to the array of full forms -``` - ["sleeps", "sleep"] -``` -The power of this construction comes from the fact that suffix sets -tend to be repeated in a language, and can therefore be collected -by common subexpression elimination. It is this technique that -explains the used syntax rather than the more accurate -``` - "(" String "+" [String] ")" -``` -since we want the suffix part to be a ``Term`` for the optimization to -take effect. - -The most curious construct of GFCC is the parameter array alias, -``` - Term ::= "(" Term "@" Term ")"; -``` -This form is used as the value of parameter records, such as the type -``` - {n : Number ; p : Person} -``` -The problem with parameter records is their double role. -They can be used like parameter values, as indices in selection, -``` - VP.s ! {n = Sg ; p = P3} -``` -but also as records, from which parameters can be projected: -``` - {n = Sg ; p = P3}.n -``` -Whichever use is selected as primary, a prohibitively complex -case expression must be generated at compilation to GFCC to get the -other use. The adopted -solution is to generate a pair containing both a parameter value index -and an array of indices of record fields. For instance, if we have -``` - param Number = Sg | Pl ; Person = P1 | P2 | P3 ; -``` -we get the encoding -``` - {n = Sg ; p = P3} ---> (2 @ [0,2]) -``` -The GFCC computation rules are essentially -``` - (t ! (i @ _)) = (t ! i) - ((_ @ r) ! j) =(r ! j) -``` - - -==Compiling to GFCC== - -Compilation to GFCC is performed by the GF grammar compiler, and -GFCC interpreters need not know what it does. For grammar writers, -however, it might be interesting to know what happens to the grammars -in the process. - -The compilation phases are the following -+ translate GF source to GFC, as always in GF -+ undo GFC back-end optimizations -+ perform the ``values`` optimization to normalize tables -+ create a symbol table mapping the GFC parameter and record types to - fixed-size arrays, and parameter values and record labels to integers -+ traverse the linearization rules replacing parameters and labels by integers -+ reorganize the created GFC grammar so that it has just one abstract syntax - and one concrete syntax per language -+ apply UTF8 encoding to the grammar, if not yet applied (this is told by the - ``coding`` flag) -+ translate the GFC syntax tree to a GFCC syntax tree, using a simple - compositional mapping -+ perform the word-suffix optimization on GFCC linearization terms -+ perform subexpression elimination on each concrete syntax module -+ print out the GFCC code - - -Notice that a major part of the compilation is done within GFC, so that -GFC-related tasks (such as parser generation) could be performed by -using the old algorithms. - - -===Problems in GFCC compilation=== - -Two major problems had to be solved in compiling GFC to GFCC: -- consistent order of tables and records, to permit the array translation -- run-time variables in complex parameter values. - - -The current implementation is still experimental and may fail -to generate correct code. Any errors remaining are likely to be -related to the two problems just mentioned. - -The order problem is solved in different ways for tables and records. -For tables, the ``values`` optimization of GFC already manages to -maintain a canonical order. But this order can be destroyed by the -``share`` optimization. To make sure that GFCC compilation works properly, -it is safest to recompile the GF grammar by using the ``values`` -optimization flag. - -Records can be canonically ordered by sorting them by labels. -In fact, this was done in connection of the GFCC work as a part -of the GFC generation, to guarantee consistency. This means that -e.g. the ``s`` field will in general no longer appear as the first -field, even if it does so in the GF source code. But relying on the -order of fields in a labelled record would be misplaced anyway. - -The canonical form of records is further complicated by lock fields, -i.e. dummy fields of form ``lock_C = <>``, which are added to grammar -libraries to force intensionality of linearization types. The problem -is that the absence of a lock field only generates a warning, not -an error. Therefore a GFC grammar can contain objects of the same -type with and without a lock field. This problem was solved in GFCC -generation by just removing all lock fields (defined as fields whose -type is the empty record type). This has the further advantage of -(slightly) reducing the grammar size. More importantly, it is safe -to remove lock fields, because they are never used in computation, -and because intensional types are only needed in grammars reused -as libraries, not in grammars used at runtime. - -While the order problem is rather bureaucratic in nature, run-time -variables are an interesting problem. They arise in the presence -of complex parameter values, created by argument-taking constructors -and parameter records. To give an example, consider the GF parameter -type system -``` - Number = Sg | Pl ; - Person = P1 | P2 | P3 ; - Agr = Ag Number Person ; -``` -The values can be translated to integers in the expected way, -``` - Sg = 0, Pl = 1 - P1 = 0, P2 = 1, P3 = 2 - Ag Sg P1 = 0, Ag Sg P2 = 1, Ag Sg P3 = 2, - Ag Pl P1 = 3, Ag Pl P2 = 4, Ag Pl P3 = 5 -``` -However, an argument of ``Agr`` can be a run-time variable, as in -``` - Ag np.n P3 -``` -This expression must first be translated to a case expression, -``` - case np.n of { - 0 => 2 ; - 1 => 5 - } -``` -which can then be translated to the GFCC term -``` - ([2,5] ! ($0 ! $1)) -``` -assuming that the variable ``np`` is the first argument and that its -``Number`` field is the second in the record. - -This transformation of course has to be performed recursively, since -there can be several run-time variables in a parameter value: -``` - Ag np.n np.p -``` -A similar transformation would be possible to deal with the double -role of parameter records discussed above. Thus the type -``` - RNP = {n : Number ; p : Person} -``` -could be uniformly translated into the set ``{0,1,2,3,4,5}`` -as ``Agr`` above. Selections would be simple instances of indexing. -But any projection from the record should be translated into -a case expression, -``` - rnp.n ===> - case rnp of { - 0 => 0 ; - 1 => 0 ; - 2 => 0 ; - 3 => 1 ; - 4 => 1 ; - 5 => 1 - } -``` -To avoid the code bloat resulting from this, we chose the alias representation -which is easy enough to deal with in interpreters. - - -===The representation of linearization types=== - -Linearization types (``lincat``) are not needed when generating with -GFCC, but they have been added to enable parser generation directly from -GFCC. The linearization type definitions are shown as a part of the -concrete syntax, by using terms to represent types. Here is the table -showing how different linearization types are encoded. -``` - P* = size(P) -- parameter type - {_ : I ; __ : R}* = (I* @ R*) -- record of parameters - {r1 : T1 ; ... ; rn : Tn}* = [T1*,...,Tn*] -- other record - (P => T)* = [T* ,...,T*] -- size(P) times - Str* = () -``` -The category symbols are prefixed with two underscores (``__``). -For example, the linearization type ``present/CatEng.NP`` is -translated as follows: -``` - NP = { - a : { -- 6 = 2*3 values - n : {ParamX.Number} ; -- 2 values - p : {ParamX.Person} -- 3 values - } ; - s : {ResEng.Case} => Str -- 3 values - } - - __NP = [(6@[2,3]),[(),(),()]] -``` - - - - -===Running the compiler and the GFCC interpreter=== - -GFCC generation is a part of the -[developers' version http://www.cs.chalmers.se/Cs/Research/Language-technology/darcs/GF/doc/darcs.html] -of GF since September 2006. To invoke the compiler, the flag -``-printer=gfcc`` to the command -``pm = print_multi`` is used. It is wise to recompile the grammar from -source, since previously compiled libraries may not obey the canonical -order of records. To ``strip`` the grammar before -GFCC translation removes unnecessary interface references. -Here is an example, performed in -[example/bronzeage ../../../../../examples/bronzeage]. -``` - i -src -path=.:prelude:resource-1.0/* -optimize=all_subs BronzeageEng.gf - i -src -path=.:prelude:resource-1.0/* -optimize=all_subs BronzeageGer.gf - strip - pm -printer=gfcc | wf bronze.gfcc -``` - - - -==The reference interpreter== - -The reference interpreter written in Haskell consists of the following files: -``` - -- source file for BNFC - GFCC.cf -- labelled BNF grammar of gfcc - - -- files generated by BNFC - AbsGFCC.hs -- abstrac syntax of gfcc - ErrM.hs -- error monad used internally - LexGFCC.hs -- lexer of gfcc files - ParGFCC.hs -- parser of gfcc files and syntax trees - PrintGFCC.hs -- printer of gfcc files and syntax trees - - -- hand-written files - DataGFCC.hs -- post-parser grammar creation, linearization and evaluation - GenGFCC.hs -- random and exhaustive generation, generate-and-test parsing - RunGFCC.hs -- main function - a simple command interpreter -``` -It is included in the -[developers' version http://www.cs.chalmers.se/Cs/Research/Language-technology/darcs/GF/doc/darcs.html] -of GF, in the subdirectory [``GF/src/GF/Canon/GFCC`` ../]. - -To compile the interpreter, type -``` - make gfcc -``` -in ``GF/src``. To run it, type -``` - ./gfcc -``` -The available commands are -- ``gr ``: generate a number of random trees in category. - and show their linearizations in all languages -- ``grt ``: generate a number of random trees in category. - and show the trees and their linearizations in all languages -- ``gt ``: generate a number of trees in category from smallest, - and show their linearizations in all languages -- ``gtt ``: generate a number of trees in category from smallest, - and show the trees and their linearizations in all languages -- ``p ``: "parse", i.e. generate trees until match or - until the given number have been generated -- ````: linearize tree in all languages, also showing full records -- ``quit``: terminate the system cleanly - - -==Interpreter in C++== - -A base-line interpreter in C++ has been started. -Its main functionality is random generation of trees and linearization of them. - -Here are some results from running the different interpreters, compared -to running the same grammar in GF, saved in ``.gfcm`` format. -The grammar contains the English, German, and Norwegian -versions of Bronzeage. The experiment was carried out on -Ubuntu Linux laptop with 1.5 GHz Intel centrino processor. - -|| | GF | gfcc(hs) | gfcc++ | -| program size | 7249k | 803k | 113k -| grammar size | 336k | 119k | 119k -| read grammar | 1150ms | 510ms | 100ms -| generate 222 | 9500ms | 450ms | 800ms -| memory | 21M | 10M | 20M - - - -To summarize: -- going from GF to gfcc is a major win in both code size and efficiency -- going from Haskell to C++ interpreter is not a win yet, because of a space - leak in the C++ version - - - -==Some things to do== - -Interpreter in Java. - -Parsing via MCFG -- the FCFG format can possibly be simplified -- parser grammars should be saved in files to make interpreters easier - - -Hand-written parsers for GFCC grammars to reduce code size -(and efficiency?) of interpreters. - -Binary format and/or file compression of GFCC output. - -Syntax editor based on GFCC. - -Rewriting of resource libraries in order to exploit the -word-suffix sharing better (depth-one tables, as in FM). - - - diff --git a/src/PGF/doc/syntax.txt b/src/PGF/doc/syntax.txt deleted file mode 100644 index db8f7c149..000000000 --- a/src/PGF/doc/syntax.txt +++ /dev/null @@ -1,180 +0,0 @@ -GFCC Syntax - - -==Syntax of GFCC files== - -The parser syntax is very simple, as defined in BNF: -``` - Grm. Grammar ::= [RExp] ; - - App. RExp ::= "(" CId [RExp] ")" ; - AId. RExp ::= CId ; - AInt. RExp ::= Integer ; - AStr. RExp ::= String ; - AFlt. RExp ::= Double ; - AMet. RExp ::= "?" ; - - terminator RExp "" ; - - token CId (('_' | letter) (letter | digit | '\'' | '_')*) ; -``` -While a parser and a printer can be generated for many languages -from this grammar by using the BNF Converter, a parser is also -easy to write by hand using recursive descent. - - -==Syntax of well-formed GFCC code== - -Here is a summary of well-formed syntax, -with a comment on the semantics of each construction. -``` - Grammar ::= - ("grammar" CId CId*) -- abstract syntax name and concrete syntax names - "(" "flags" Flag* ")" -- global and abstract flags - "(" "abstract" Abstract ")" -- abstract syntax - "(" "concrete" Concrete* ")" -- concrete syntaxes - - Abstract ::= - "(" "fun" FunDef* ")" -- function definitions - "(" "cat" CatDef* ")" -- category definitions - - Concrete ::= - "(" CId -- language name - "flags" Flag* -- concrete flags - "lin" LinDef* -- linearization rules - "oper" LinDef* -- operations (macros) - "lincat" LinDef* -- linearization type definitions - "lindef" LinDef* -- linearization default definitions - "printname" LinDef* -- printname definitions - "param" LinDef* -- lincats with labels and parameter value names - ")" - - Flag ::= "(" CId String ")" -- flag and value - FunDef ::= "(" CId Type Exp ")" -- function, type, and definition - CatDef ::= "(" CId Hypo* ")" -- category and context - LinDef ::= "(" CId Term ")" -- function and definition - - Type ::= - "(" CId -- value category - "(" "H" Hypo* ")" -- argument context - "(" "X" Exp* ")" ")" -- arguments (of dependent value type) - - Exp ::= - "(" CId -- function - "(" "B" CId* ")" -- bindings - "(" "X" Exp* ")" ")" -- arguments - | CId -- variable - | "?" -- metavariable - | "(" "Eq" Equation* ")" -- group of pattern equations - | Integer -- integer literal (non-negative) - | Float -- floating-point literal (non-negative) - | String -- string literal (in double quotes) - - Hypo ::= "(" CId Type ")" -- variable and type - - Equation ::= "(" "E" Exp Exp* ")" -- value and pattern list - - Term ::= - "(" "R" Term* ")" -- array (record or table) - | "(" "S" Term* ")" -- concatenated sequence - | "(" "FV" Term* ")" -- free variant list - | "(" "P" Term Term ")" -- access to index (projection or selection) - | "(" "W" String Term ")" -- token prefix with suffix list - | "(" "A" Integer ")" -- pointer to subtree - | String -- token (in double quotes) - | Integer -- index in array - | CId -- macro constant - | "?" -- metavariable -``` - - -==GFCC interpreter== - -The first phase in interpreting GFCC is to parse a GFCC file and -build an internal abstract syntax representation, as specified -in the previous section. - -With this representation, linearization can be performed by -a straightforward function from expressions (``Exp``) to terms -(``Term``). All expressions except groups of pattern equations -can be linearized. - -Here is a reference Haskell implementation of linearization: -``` - linExp :: GFCC -> CId -> Exp -> Term - linExp gfcc lang tree@(DTr _ at trees) = case at of - AC fun -> comp (map lin trees) $ look fun - AS s -> R [K (show s)] -- quoted - AI i -> R [K (show i)] - AF d -> R [K (show d)] - AM -> TM - where - lin = linExp gfcc lang - comp = compute gfcc lang - look = lookLin gfcc lang -``` -TODO: bindings must be supported. - -Terms resulting from linearization are evaluated in -call-by-value order, with two environments needed: -- the grammar (a concrete syntax) to give the global constants -- an array of terms to give the subtree linearizations - - -The Haskell implementation works as follows: -``` -compute :: GFCC -> CId -> [Term] -> Term -> Term -compute gfcc lang args = comp where - comp trm = case trm of - P r p -> proj (comp r) (comp p) - W s t -> W s (comp t) - R ts -> R $ map comp ts - V i -> idx args (fromInteger i) -- already computed - F c -> comp $ look c -- not computed (if contains V) - FV ts -> FV $ Prelude.map comp ts - S ts -> S $ Prelude.filter (/= S []) $ Prelude.map comp ts - _ -> trm - - look = lookOper gfcc lang - - idx xs i = xs !! i - - proj r p = case (r,p) of - (_, FV ts) -> FV $ Prelude.map (proj r) ts - (FV ts, _ ) -> FV $ Prelude.map (\t -> proj t p) ts - (W s t, _) -> kks (s ++ getString (proj t p)) - _ -> comp $ getField r (getIndex p) - - getString t = case t of - K (KS s) -> s - _ -> trace ("ERROR in grammar compiler: string from "++ show t) "ERR" - - getIndex t = case t of - C i -> fromInteger i - RP p _ -> getIndex p - TM -> 0 -- default value for parameter - _ -> trace ("ERROR in grammar compiler: index from " ++ show t) 0 - - getField t i = case t of - R rs -> idx rs i - RP _ r -> getField r i - TM -> TM - _ -> trace ("ERROR in grammar compiler: field from " ++ show t) t -``` -The result of linearization is usually a record, which is realized as -a string using the following algorithm. -``` - realize :: Term -> String - realize trm = case trm of - R (t:_) -> realize t - S ss -> unwords $ map realize ss - K s -> s - W s t -> s ++ realize t - FV (t:_) -> realize t -- TODO: all variants - TM -> "?" -``` -Notice that realization always picks the first field of a record. -If a linearization type has more than one field, the first field -does not necessarily contain the desired string. -Also notice that the order of record fields in GFCC is not necessarily -the same as in GF source. diff --git a/src/ReleaseProcedure b/src/ReleaseProcedure deleted file mode 100644 index c04f2a065..000000000 --- a/src/ReleaseProcedure +++ /dev/null @@ -1,153 +0,0 @@ -Procedure for making a GF release: - -1. Make sure everything that should be in the release has been - checked in. - -2. Go to the src/ dir. - - $ cd src - -3. Edit configure.ac to set the right version number - (the second argument to the AC_INIT macro). - -4. Edit gf.spec to set the version and release numbers - (change %define version and %define release). - -5. Commit configure.ac and gf.spec: - - $ darcs record -m 'Updated version numbers.' configure.ac gf.spec - -6. Run autoconf to generate configure with the right version number: - - $ autoconf - -7. Go back to the root of the tree. - - $ cd .. - -8. Tag the release. (X_X should be replaced by the version number, with - _ instead of ., e.g. 2_0) - - $ darcs tag -m RELEASE-X_X - -9. Push the changes that you made for the release to the main repo: - - $ darcs push - -10. Build a source package: - - $ cd src - $ ./configure - $ make dist - -11. (Only if releasing a new grammars distribution) - Build a grammar tarball: - - $ cd src - $ ./configure && make grammar-dist - -12. Build an x86/linux RPM (should be done on a Mandrake Linux box): - - Setup for building RPMs (first time only): - - - Make sure that you have the directories neccessary to build - RPMs: - - $ mkdir -p ~/rpm/{BUILD,RPMS/i586,RPMS/noarch,SOURCES,SRPMS,SPECS,tmp} - - - Create ~/.rpmrc with the following contents: - -buildarchtranslate: i386: i586 -buildarchtranslate: i486: i586 -buildarchtranslate: i586: i586 -buildarchtranslate: i686: i586 - - - Create ~/.rpmmacros with the following contents: - -%_topdir %(echo ${HOME}/rpm) -%_tmppath %{_topdir}/tmp - -%packager Your Name - - Build the RPM: - - $ cd src - $ ./configure && make rpm - -13. Build a generic binary x86/linux package (should be done on a Linux box, - e.g. banded.medic.chalmers.se): - - $ cd src - $ ./configure --host=i386-pc-linux-gnu && make binary-dist - -14. Build a generic binary sparc/solaris package (should be done - on a Solaris box, e.g. remote1.cs.chalmers.se): - - $ cd src - $ ./configure --host=sparc-sun-solaris2 && gmake binary-dist - -15. Build a Mac OS X package (should be done on a Mac OS X box, - e.g. csmisc99.cs.chalmers.se): - - $ cd src - $ ./configure && make binary-dist - - Note that to run GHC-compiled binaries on OS X, you need - a "Haskell Support Framework". This should be available - separately from the GF download page. - - TODO: Use OS X PackageMaker to build a .pkg-file which can - be installed using the standard OS X Installer program. - -16. Build a binary Cygwin package (should be done on a Windows - machine with Cygwin): - - $ cd src - $ ./configure && make binary-dist - -17. Build a Windows MSI package (FIXME: This doesn't work right, - pathnames with backslashes and spaces are not handled - correctly in Windows. We only release a binary tarball - for Cygwin right now.): - - $ cd src - $ ./configure && make all windows-msi - -18. Add new GF package release to SourceForge: - - - https://sourceforge.net/projects/gf-tools - - - Project page -> Admin -> File releases -> Add release (for the - GF package) - - - New release name: X.X (just the version number, e.g. 2.2) - - - Paste in release notes - - - Upload files using anonymous FTP to upload.sourceforge.net - in the incoming directory. - - - Add the files to the release and set the processor - and file type for each file (remember to press - Update/Refresh for each file): - * x86 rpm -> i386/.rpm - * source rpm -> Any/Source .rpm - * x86 binary tarball -> i386/.gz - * sparc binary tarball -> Sparc/.gz - * source package -> Any/Source .gz - -19. Add new GF-editor release. Repeat the steps above, but - with GF-editor: - - - Add files and set properties: - - * editor rpm -> i386/.rpm (not really true, but I haven't - figured out how to make noarch rpms from the same spec as - arch-specific ones) - -20. Mail to gf-tools-users@lists.sourceforge.net - -21. Update website. - -22. Party! - diff --git a/src/compiler/GF.hs b/src/compiler/GF.hs new file mode 100644 index 000000000..32a95ca1f --- /dev/null +++ b/src/compiler/GF.hs @@ -0,0 +1,45 @@ +{-# OPTIONS -cpp #-} +module Main where + +import GFC +import GFI +import GF.Data.ErrM +import GF.Infra.Option +import GF.Infra.UseIO +import Paths_gf + +import Data.Version +import System.Directory +import System.Environment (getArgs) +import System.Exit +import System.IO +#ifdef mingw32_HOST_OS +import System.Win32.Console +import System.Win32.NLS +#endif + +main :: IO () +main = do +#ifdef mingw32_HOST_OS + codepage <- getACP + setConsoleCP codepage + setConsoleOutputCP codepage +#endif + args <- getArgs + case parseOptions args of + Ok (opts,files) -> do curr_dir <- getCurrentDirectory + lib_dir <- getLibraryDirectory opts + mainOpts (fixRelativeLibPaths curr_dir lib_dir opts) files + Bad err -> do hPutStrLn stderr err + hPutStrLn stderr "You may want to try --help." + exitFailure + +mainOpts :: Options -> [FilePath] -> IO () +mainOpts opts files = + case flag optMode opts of + ModeVersion -> putStrLn $ "Grammatical Framework (GF) version " ++ showVersion version + ModeHelp -> putStrLn helpMessage + ModeInteractive -> mainGFI opts files + ModeRun -> mainRunGFI opts files + ModeCompiler -> dieIOE (mainGFC opts files) + diff --git a/src/compiler/GF/Command/Abstract.hs b/src/compiler/GF/Command/Abstract.hs new file mode 100644 index 000000000..1f7c4014e --- /dev/null +++ b/src/compiler/GF/Command/Abstract.hs @@ -0,0 +1,79 @@ +module GF.Command.Abstract where + +import PGF.CId +import PGF.Data + +type Ident = String + +type CommandLine = [Pipe] + +type Pipe = [Command] + +data Command + = Command Ident [Option] Argument + deriving (Eq,Ord,Show) + +data Option + = OOpt Ident + | OFlag Ident Value + deriving (Eq,Ord,Show) + +data Value + = VId Ident + | VInt Int + | VStr String + deriving (Eq,Ord,Show) + +data Argument + = AExpr Expr + | ANoArg + | AMacro Ident + deriving (Eq,Ord,Show) + +valCIdOpts :: String -> CId -> [Option] -> CId +valCIdOpts flag def opts = + case [v | OFlag f (VId v) <- opts, f == flag] of + (v:_) -> mkCId v + _ -> def + +valIntOpts :: String -> Int -> [Option] -> Int +valIntOpts flag def opts = + case [v | OFlag f (VInt v) <- opts, f == flag] of + (v:_) -> v + _ -> def + +valStrOpts :: String -> String -> [Option] -> String +valStrOpts flag def opts = + case [v | OFlag f v <- opts, f == flag] of + (VStr v:_) -> v + (VId v:_) -> v + (VInt v:_) -> show v + _ -> def + +isOpt :: String -> [Option] -> Bool +isOpt o opts = elem o [x | OOpt x <- opts] + +isFlag :: String -> [Option] -> Bool +isFlag o opts = elem o [x | OFlag x _ <- opts] + +optsAndFlags :: [Option] -> ([Option],[Option]) +optsAndFlags = foldr add ([],[]) where + add o (os,fs) = case o of + OOpt _ -> (o:os,fs) + OFlag _ _ -> (os,o:fs) + +prOpt :: Option -> String +prOpt o = case o of + OOpt i -> i + OFlag f x -> f ++ "=" ++ show x + +mkOpt :: String -> Option +mkOpt = OOpt + +-- abbreviation convention from gf commands +getCommandOp 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/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs new file mode 100644 index 000000000..d8e2a3023 --- /dev/null +++ b/src/compiler/GF/Command/Commands.hs @@ -0,0 +1,931 @@ +{-# LANGUAGE PatternGuards #-} + +module GF.Command.Commands ( + allCommands, + lookCommand, + exec, + isOpt, + options, + flags, + needsTypeCheck, + CommandInfo, + CommandOutput + ) where + +import PGF +import PGF.CId +import PGF.ShowLinearize +import PGF.VisualizeTree +import PGF.Macros +import PGF.Data ---- +import PGF.Morphology +import GF.Compile.Export +import GF.Infra.Option (noOptions, readOutputFormat, Encoding(..)) +import GF.Infra.UseIO +import GF.Data.ErrM ---- +import GF.Command.Abstract +import GF.Command.Messages +import GF.Text.Lexing +import GF.Text.Transliterations +import GF.Quiz + +import GF.Command.TreeOperations ---- temporary place for typecheck and compute + +import GF.Data.Operations +import GF.Text.Coding + +import Data.List +import Data.Maybe +import qualified Data.Map as Map +import System.Cmd +import Text.PrettyPrint +import Data.List (sort) +import Debug.Trace + +type CommandOutput = ([Expr],String) ---- errors, etc + +data CommandInfo = CommandInfo { + exec :: [Option] -> [Expr] -> IO CommandOutput, + synopsis :: String, + syntax :: String, + explanation :: String, + longname :: String, + options :: [(String,String)], + flags :: [(String,String)], + examples :: [String], + needsTypeCheck :: Bool + } + +emptyCommandInfo :: CommandInfo +emptyCommandInfo = CommandInfo { + exec = \_ ts -> return (ts,[]), ---- + synopsis = "", + syntax = "", + explanation = "", + longname = "", + options = [], + flags = [], + examples = [], + needsTypeCheck = True + } + +lookCommand :: String -> Map.Map String CommandInfo -> Maybe CommandInfo +lookCommand = Map.lookup + +commandHelpAll :: Encoding -> PGFEnv -> [Option] -> String +commandHelpAll cod pgf opts = unlines + [commandHelp (isOpt "full" opts) (co,info) + | (co,info) <- Map.assocs (allCommands cod pgf)] + +commandHelp :: Bool -> (String,CommandInfo) -> String +commandHelp full (co,info) = unlines $ [ + co ++ ", " ++ longname info, + synopsis info] ++ if full then [ + "", + "syntax:" ++++ " " ++ syntax info, + "", + explanation info, + "options:" ++++ unlines [" -" ++ o ++ "\t" ++ e | (o,e) <- options info], + "flags:" ++++ unlines [" -" ++ o ++ "\t" ++ e | (o,e) <- flags info], + "examples:" ++++ unlines [" " ++ s | s <- examples info] + ] else [] + +-- for printing with txt2tags formatting + +commandHelpTags :: Bool -> (String,CommandInfo) -> String +commandHelpTags full (co,info) = unlines $ [ + "#VSPACE","","#NOINDENT", + lit co ++ " = " ++ lit (longname info) ++ ": " ++ + "//" ++ synopsis info ++ ".//"] ++ if full then [ + "","#TINY","", + explanation info, + "- Syntax: ``" ++ syntax info ++ "``", + "- Options:\n" ++++ + unlines [" | ``-" ++ o ++ "`` | " ++ e | (o,e) <- options info], + "- Flags:\n" ++++ + unlines [" | ``-" ++ o ++ "`` | " ++ e | (o,e) <- flags info], + "- Examples:\n```" ++++ + unlines [" " ++ s | s <- examples info], + "```", + "", "#NORMAL", "" + ] else [] + where + lit s = "``" ++ s ++ "``" + +type PGFEnv = (PGF, Map.Map Language Morpho) + +-- this list must no more be kept sorted by the command name +allCommands :: Encoding -> PGFEnv -> Map.Map String CommandInfo +allCommands cod env@(pgf, mos) = Map.fromList [ + ("!", emptyCommandInfo { + synopsis = "system command: escape to system shell", + syntax = "! SYSTEMCOMMAND", + examples = [ + "! ls *.gf -- list all GF files in the working directory" + ], + needsTypeCheck = False + }), + ("?", emptyCommandInfo { + synopsis = "system pipe: send value from previous command to a system command", + syntax = "? SYSTEMCOMMAND", + examples = [ + "gt | l | ? wc -- generate, linearize, word-count" + ], + needsTypeCheck = False + }), + + ("aw", emptyCommandInfo { + longname = "align_words", + synopsis = "show word alignments between languages graphically", + explanation = unlines [ + "Prints a set of strings in the .dot format (the graphviz format).", + "The graph can be saved in a file by the wf command as usual.", + "If the -view flag is defined, the graph is saved in a temporary file", + "which is processed by graphviz and displayed by the program indicated", + "by the flag. The target format is postscript, unless overridden by the", + "flag -format." + ], + exec = \opts es -> do + let grph = if null es then [] else graphvizAlignment pgf (head es) + if isFlag "view" opts || isFlag "format" opts then do + let file s = "_grph." ++ s + let view = optViewGraph opts ++ " " + let format = optViewFormat opts + writeFile (file "dot") (enc grph) + system $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format ++ + " ; " ++ view ++ file format + return void + else return $ fromString grph, + examples = [ + "gr | aw -- generate a tree and show word alignment as graph script", + "gr | vt -view=\"open\" -- generate a tree and display alignment on a Mac" + ], + options = [ + ], + flags = [ + ("format","format of the visualization file (default \"png\")"), + ("view","program to open the resulting file (default \"open\")") + ] + }), + + ("cc", emptyCommandInfo { + longname = "compute_concrete", + syntax = "cc (-all | -table | -unqual)? TERM", + synopsis = "computes concrete syntax term using a source grammar", + explanation = unlines [ + "Compute TERM by concrete syntax definitions. Uses the topmost", + "module (the last one imported) to resolve constant names.", + "N.B.1 You need the flag -retain when importing the grammar, if you want", + "the definitions to be retained after compilation.", + "N.B.2 The resulting term is not a tree in the sense of abstract syntax", + "and hence not a valid input to a Tree-expecting command.", + "This command must be a line of its own, and thus cannot be a part", + "of a pipe." + ], + options = [ + ("all","pick all strings (forms and variants) from records and tables"), + ("table","show all strings labelled by parameters"), + ("unqual","hide qualifying module names") + ], + needsTypeCheck = False + }), + ("dc", emptyCommandInfo { + longname = "define_command", + syntax = "dc IDENT COMMANDLINE", + synopsis = "define a command macro", + explanation = unlines [ + "Defines IDENT as macro for COMMANDLINE, until IDENT gets redefined.", + "A call of the command has the form %IDENT. The command may take an", + "argument, which in COMMANDLINE is marked as ?0. Both strings and", + "trees can be arguments. Currently at most one argument is possible.", + "This command must be a line of its own, and thus cannot be a part", + "of a pipe." + ], + needsTypeCheck = False + }), + ("dt", emptyCommandInfo { + longname = "define_tree", + syntax = "dt IDENT (TREE | STRING | \"<\" COMMANDLINE)", + synopsis = "define a tree or string macro", + explanation = unlines [ + "Defines IDENT as macro for TREE or STRING, until IDENT gets redefined.", + "The defining value can also come from a command, preceded by \"<\".", + "If the command gives many values, the first one is selected.", + "A use of the macro has the form %IDENT. Currently this use cannot be", + "a subtree of another tree. This command must be a line of its own", + "and thus cannot be a part of a pipe." + ], + examples = [ + ("dt ex \"hello world\" -- define ex as string"), + ("dt ex UseN man_N -- define ex as string"), + ("dt ex < p -cat=NP \"the man in the car\" -- define ex as parse result"), + ("l -lang=LangSwe %ex | ps -to_utf8 -- linearize the tree ex") + ], + needsTypeCheck = False + }), + ("e", emptyCommandInfo { + longname = "empty", + synopsis = "empty the environment" + }), + ("gr", emptyCommandInfo { + longname = "generate_random", + synopsis = "generate random trees in the current abstract syntax", + syntax = "gr [-cat=CAT] [-number=INT]", + examples = [ + "gr -- one tree in the startcat of the current grammar", + "gr -cat=NP -number=16 -- 16 trees in the category NP", + "gr -lang=LangHin,LangTha -cat=Cl -- Cl, both in LangHin and LangTha" + ], + explanation = unlines [ + "Generates a list of random trees, by default one tree." +---- "If a tree argument is given, the command completes the Tree with values to", +---- "the metavariables in the tree." + ], + flags = [ + ("cat","generation category"), + ("lang","uses only functions that have linearizations in all these languages"), + ("number","number of trees generated") + ], + exec = \opts _ -> do + let pgfr = optRestricted opts + ts <- generateRandom pgfr (optType opts) + returnFromExprs $ take (optNum opts) ts + }), + ("gt", emptyCommandInfo { + longname = "generate_trees", + synopsis = "generates a list of trees, by default exhaustive", + explanation = unlines [ + "Generates all trees of a given category, with increasing depth.", + "By default, the depth is 4, but this can be changed by a flag." + ---- "If a Tree argument is given, the command completes the Tree with values", + ---- "to the metavariables in the tree." + ], + flags = [ + ("cat","the generation category"), + ("depth","the maximum generation depth"), + ("lang","excludes functions that have no linearization in this language"), + ("number","the number of trees generated") + ], + exec = \opts _ -> do + let pgfr = optRestricted opts + let dp = return $ valIntOpts "depth" 4 opts + let ts = generateAllDepth pgfr (optType opts) dp + returnFromExprs $ take (optNumInf opts) ts + }), + ("h", emptyCommandInfo { + longname = "help", + syntax = "h (-full)? COMMAND?", + synopsis = "get description of a command, or a the full list of commands", + explanation = unlines [ + "Displays information concerning the COMMAND.", + "Without argument, shows the synopsis of all commands." + ], + options = [ + ("changes","give a summary of changes from GF 2.9"), + ("coding","give advice on character encoding"), + ("full","give full information of the commands"), + ("license","show copyright and license information") + ], + exec = \opts ts -> + let + msg = case ts of + _ | isOpt "changes" opts -> changesMsg + _ | isOpt "coding" opts -> codingMsg + _ | isOpt "license" opts -> licenseMsg + [t] -> let co = getCommandOp (showExpr [] t) in + case lookCommand co (allCommands cod env) of ---- new map ??!! + Just info -> commandHelp True (co,info) + _ -> "command not found" + _ -> commandHelpAll cod env opts + in return (fromString msg), + needsTypeCheck = False + }), + ("i", emptyCommandInfo { + longname = "import", + synopsis = "import a grammar from source code or compiled .pgf file", + explanation = unlines [ + "Reads a grammar from File and compiles it into a GF runtime grammar.", + "If a grammar with the same concrete name is already in the state", + "it is overwritten - but only if compilation succeeds.", + "The grammar parser depends on the file name suffix:", + " .gf normal GF source", + " .gfo compiled GF source", + " .pgf precompiled grammar in Portable Grammar Format" + ], + options = [ + -- ["prob", "retain", "gfo", "src", "no-cpu", "cpu", "quiet", "verbose"] + ("retain","retain operations (used for cc command)"), + ("src", "force compilation from source"), + ("v", "be verbose - show intermediate status information") + ], + needsTypeCheck = False + }), + ("l", emptyCommandInfo { + longname = "linearize", + synopsis = "convert an abstract syntax expression to string", + explanation = unlines [ + "Shows the linearization of a Tree by the grammars in scope.", + "The -lang flag can be used to restrict this to fewer languages.", + "A sequence of string operations (see command ps) can be given", + "as options, and works then like a pipe to the ps command, except", + "that it only affect the strings, not e.g. the table labels.", + "These can be given separately to each language with the unlexer flag", + "whose results are prepended to the other lexer flags. The value of the", + "unlexer flag is a space-separated list of comma-separated string operation", + "sequences; see example." + ], + examples = [ + "l -langs=LangSwe,LangNor no_Utt -- linearize tree to LangSwe and LangNor", + "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -to_utf8 -- hindi table", + "l -unlexer=\"LangSwe=to_utf8 LangHin=to_devanagari,to_utf8\" -- different lexers" + ], + exec = \opts -> return . fromStrings . map (optLin opts), + options = [ + ("all","show all forms and variants"), + ("bracket","show tree structure with brackets and paths to nodes"), + ("multi","linearize to all languages (default)"), + ("record","show source-code-like record"), + ("table","show all forms labelled by parameters"), + ("term", "show PGF term"), + ("treebank","show the tree and tag linearizations with language names") + ] ++ stringOpOptions, + flags = [ + ("lang","the languages of linearization (comma-separated, no spaces)"), + ("unlexer","set unlexers separately to each language (space-separated)") + ] + }), + ("ma", emptyCommandInfo { + longname = "morpho_analyse", + synopsis = "print the morphological analyses of all words in the string", + explanation = unlines [ + "Prints all the analyses of space-separated words in the input string,", + "using the morphological analyser of the actual grammar (see command pf)" + ], + exec = \opts -> + return . fromString . unlines . + map prMorphoAnalysis . concatMap (morphos opts) . + concatMap words . toStrings + }), + + ("mq", emptyCommandInfo { + longname = "morpho_quiz", + synopsis = "start a morphology quiz", + exec = \opts _ -> do + let lang = optLang opts + let typ = optType opts + morphologyQuiz cod pgf lang typ + return void, + flags = [ + ("lang","language of the quiz"), + ("cat","category of the quiz"), + ("number","maximum number of questions") + ] + }), + + ("p", emptyCommandInfo { + longname = "parse", + synopsis = "parse a string to abstract syntax expression", + explanation = unlines [ + "Shows all trees returned by parsing a string in the grammars in scope.", + "The -lang flag can be used to restrict this to fewer languages.", + "The default start category can be overridden by the -cat flag.", + "See also the ps command for lexing and character encoding.", + "", + "The -openclass flag is experimental and allows some robustness in ", + "the parser. For example if -openclass=\"A,N,V\" is given, the parser", + "will accept unknown adjectives, nouns and verbs with the resource grammar." + ], + exec = \opts -> returnFromExprs . concatMap (par opts) . toStrings, + flags = [ + ("cat","target category of parsing"), + ("lang","the languages of parsing (comma-separated, no spaces)"), + ("openclass","list of open-class categories for robust parsing") + ] + }), + ("pg", emptyCommandInfo { ----- + longname = "print_grammar", + synopsis = "print the actual grammar with the given printer", + explanation = unlines [ + "Prints the actual grammar, with all involved languages.", + "In some printers, this can be restricted to a subset of languages", + "with the -lang=X,Y flag (comma-separated, no spaces).", + "The -printer=P flag sets the format in which the grammar is printed.", + "N.B.1 Since grammars are compiled when imported, this command", + "generally shows a grammar that looks rather different from the source.", + "N.B.2 This command is slightly obsolete: to produce different formats", + "the batch compiler gfc is recommended, and has many more options." + ], + exec = \opts _ -> prGrammar opts, + flags = [ + --"cat", + ("lang", "select languages for the some options (default all languages)"), + ("printer","select the printing format (see gfc --help)") + ], + options = [ + ("cats", "show just the names of abstract syntax categories"), + ("fullform", "print the fullform lexicon"), + ("missing","show just the names of functions that have no linearization") + ] + }), + ("ph", emptyCommandInfo { + longname = "print_history", + synopsis = "print command history", + explanation = unlines [ + "Prints the commands issued during the GF session.", + "The result is readable by the eh command.", + "The result can be used as a script when starting GF." + ], + examples = [ + "ph | wf -file=foo.gfs -- save the history into a file" + ] + }), + ("ps", emptyCommandInfo { + longname = "put_string", + syntax = "ps OPT? STRING", + synopsis = "return a string, possibly processed with a function", + explanation = unlines [ + "Returns a string obtained from its argument string by applying", + "string processing functions in the order given in the command line", + "option list. Thus 'ps -f -g s' returns g (f s). Typical string processors", + "are lexers and unlexers, but also character encoding conversions are possible.", + "The unlexers preserve the division of their input to lines.", + "To see transliteration tables, use command ut." + ], + examples = [ + "l (EAdd 3 4) | ps -code -- linearize code-like output", + "ps -lexer=code | p -cat=Exp -- parse code-like input", + "gr -cat=QCl | l | ps -bind -- linearization output from LangFin", + "ps -to_devanagari \"A-p\" -- show Devanagari in UTF8 terminal", + "rf -file=Hin.gf | ps -env=quotes -to_devanagari -- convert translit to UTF8", + "rf -file=Ara.gf | ps -from_utf8 -env=quotes -from_arabic -- convert UTF8 to transliteration" + ], + exec = \opts -> + let (os,fs) = optsAndFlags opts in + return . fromString . stringOps (envFlag fs) (map prOpt os) . toString, + options = stringOpOptions, + flags = [ + ("env","apply in this environment only") + ] + }), + ("pt", emptyCommandInfo { + longname = "put_tree", + syntax = "ps OPT? TREE", + synopsis = "return a tree, possibly processed with a function", + explanation = unlines [ + "Returns a tree obtained from its argument tree by applying", + "tree processing functions in the order given in the command line", + "option list. Thus 'pt -f -g s' returns g (f s). Typical tree processors", + "are type checking and semantic computation." + ], + examples = [ + "pt -compute (plus one two) -- compute value" + ], + exec = \opts -> + returnFromExprs . takeOptNum opts . treeOps opts, + options = treeOpOptions pgf, + flags = [("number","take at most this many trees")] ++ treeOpFlags pgf + }), + ("q", emptyCommandInfo { + longname = "quit", + synopsis = "exit GF interpreter" + }), + ("rf", emptyCommandInfo { + longname = "read_file", + synopsis = "read string or tree input from a file", + explanation = unlines [ + "Reads input from file. The filename must be in double quotes.", + "The input is interpreted as a string by default, and can hence be", + "piped e.g. to the parse command. The option -tree interprets the", + "input as a tree, which can be given e.g. to the linearize command.", + "The option -lines will result in a list of strings or trees, one by line." + ], + options = [ + ("lines","return the list of lines, instead of the singleton of all contents"), + ("tree","convert strings into trees") + ], + exec = \opts _ -> do + let file = valStrOpts "file" "_gftmp" opts + let exprs [] = ([],empty) + exprs ((n,s):ls) | null s + = exprs ls + exprs ((n,s):ls) = case readExpr s of + Just e -> let (es,err) = exprs ls + in case inferExpr pgf e of + Right (e,t) -> (e:es,err) + Left tcerr -> (es,text "on line" <+> int n <> colon $$ nest 2 (ppTcError tcerr) $$ err) + Nothing -> let (es,err) = exprs ls + in (es,text "on line" <+> int n <> colon <+> text "parse error" $$ err) + returnFromLines ls = case exprs ls of + (es, err) | null es -> return ([], render (err $$ text "no trees found")) + | otherwise -> return (es, render err) + + s <- readFile file + case opts of + _ | isOpt "lines" opts && isOpt "tree" opts -> + returnFromLines (zip [1..] (lines s)) + _ | isOpt "tree" opts -> + returnFromLines [(1,s)] + _ | isOpt "lines" opts -> return (fromStrings $ lines s) + _ -> return (fromString s), + flags = [("file","the input file name")] + }), + ("tq", emptyCommandInfo { + longname = "translation_quiz", + synopsis = "start a translation quiz", + exec = \opts _ -> do + let from = valCIdOpts "from" (optLang opts) opts + let to = valCIdOpts "to" (optLang opts) opts + let typ = optType opts + translationQuiz cod pgf from to typ + return void, + flags = [ + ("from","translate from this language"), + ("to","translate to this language"), + ("cat","translate in this category"), + ("number","the maximum number of questions") + ] + }), + ("se", emptyCommandInfo { + longname = "set_encoding", + synopsis = "set the encoding used in current terminal", + syntax = "se ID", + examples = [ + "se cp1251 -- set encoding to cp1521", + "se utf8 -- set encoding to utf8 (default)" + ], + needsTypeCheck = False + }), + ("sp", emptyCommandInfo { + longname = "system_pipe", + synopsis = "send argument to a system command", + syntax = "sp -command=\"SYSTEMCOMMAND\", alt. ? SYSTEMCOMMAND", + exec = \opts arg -> do + let tmpi = "_tmpi" --- + let tmpo = "_tmpo" + writeFile tmpi $ enc $ toString arg + let syst = optComm opts ++ " " ++ tmpi + system $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo + s <- readFile tmpo + return $ fromString s, + flags = [ + ("command","the system command applied to the argument") + ], + examples = [ + "sp -command=\"wc\" \"foo\"", + "gt | l | sp -command=\"grep \\\"who\\\"\" | sp -command=\"wc\"" + ] + }), + ("ut", emptyCommandInfo { + longname = "unicode_table", + synopsis = "show a transliteration table for a unicode character set", + exec = \opts _ -> do + let t = concatMap prOpt (take 1 opts) + let out = maybe "no such transliteration" characterTable $ transliteration t + return $ fromString out, + options = transliterationPrintNames + }), + + ("vd", emptyCommandInfo { + longname = "visualize_dependency", + synopsis = "show word dependency tree graphically", + explanation = unlines [ + "Prints a dependency tree in the .dot format (the graphviz format, default)", + "or the MaltParser/CoNLL format (flag -output=malt for training, malt_input)", + "for unanalysed input.", + "By default, the last argument is the head of every abstract syntax", + "function; moreover, the head depends on the head of the function above.", + "The graph can be saved in a file by the wf command as usual.", + "If the -view flag is defined, the graph is saved in a temporary file", + "which is processed by graphviz and displayed by the program indicated", + "by the flag. The target format is png, unless overridden by the", + "flag -format." + ], + exec = \opts es -> do + let debug = isOpt "v" opts + let file = valStrOpts "file" "" opts + let outp = valStrOpts "output" "dot" opts + mlab <- case file of + "" -> return Nothing + _ -> readFile file >>= return . Just . getDepLabels . lines + let lang = optLang opts + let grphs = unlines $ map (graphvizDependencyTree outp debug mlab Nothing pgf lang) es + if isFlag "view" opts || isFlag "format" opts then do + let file s = "_grphd." ++ s + let view = optViewGraph opts ++ " " + let format = optViewFormat opts + writeFile (file "dot") (enc grphs) + system $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format ++ + " ; " ++ view ++ file format + return void + else return $ fromString grphs, + examples = [ + "gr | vd -- generate a tree and show dependency tree in .dot", + "gr | vd -view=open -- generate a tree and display dependency tree on a Mac", + "gr -number=1000 | vd -file=dep.labels -output=malt -- generate training treebank", + "gr -number=100 | vd -file=dep.labels -output=malt_input -- generate test sentences" + ], + options = [ + ("v","show extra information") + ], + flags = [ + ("file","configuration file for labels per fun, format 'fun l1 ... label ... l2'"), + ("format","format of the visualization file (default \"png\")"), + ("output","output format of graph source (default \"dot\")"), + ("view","program to open the resulting file (default \"open\")") + ] + }), + + + ("vp", emptyCommandInfo { + longname = "visualize_parse", + synopsis = "show parse tree graphically", + explanation = unlines [ + "Prints a parse tree the .dot format (the graphviz format).", + "The graph can be saved in a file by the wf command as usual.", + "If the -view flag is defined, the graph is saved in a temporary file", + "which is processed by graphviz and displayed by the program indicated", + "by the flag. The target format is png, unless overridden by the", + "flag -format." + ], + exec = \opts es -> do + let lang = optLang opts + let grph = if null es then [] else graphvizParseTree pgf lang (head es) + if isFlag "view" opts || isFlag "format" opts then do + let file s = "_grph." ++ s + let view = optViewGraph opts ++ " " + let format = optViewFormat opts + writeFile (file "dot") (enc grph) + system $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format ++ + " ; " ++ view ++ file format + return void + else return $ fromString grph, + examples = [ + "p \"John walks\" | vp -- generate a tree and show parse tree as .dot script", + "gr | vp -view=\"open\" -- generate a tree and display parse tree on a Mac" + ], + options = [ + ], + flags = [ + ("format","format of the visualization file (default \"png\")"), + ("view","program to open the resulting file (default \"open\")") + ] + }), + + ("vt", emptyCommandInfo { + longname = "visualize_tree", + synopsis = "show a set of trees graphically", + explanation = unlines [ + "Prints a set of trees in the .dot format (the graphviz format).", + "The graph can be saved in a file by the wf command as usual.", + "If the -view flag is defined, the graph is saved in a temporary file", + "which is processed by graphviz and displayed by the program indicated", + "by the flag. The target format is postscript, unless overridden by the", + "flag -format.", + "With option -mk, use for showing library style function names of form 'mkC'." + ], + exec = \opts es -> + if isOpt "mk" opts + then return $ fromString $ unlines $ map (tree2mk pgf) es + else do + let funs = not (isOpt "nofun" opts) + let cats = not (isOpt "nocat" opts) + let grph = unlines (map (graphvizAbstractTree pgf (funs,cats)) es) -- True=digraph + if isFlag "view" opts || isFlag "format" opts then do + let file s = "_grph." ++ s + let view = optViewGraph opts ++ " " + let format = optViewFormat opts + writeFile (file "dot") (enc grph) + system $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format ++ + " ; " ++ view ++ file format + return void + else return $ fromString grph, + examples = [ + "p \"hello\" | vt -- parse a string and show trees as graph script", + "p \"hello\" | vt -view=\"open\" -- parse a string and display trees on a Mac" + ], + options = [ + ("mk", "show the tree with function names converted to 'mkC' with value cats C"), + ("nofun","don't show functions but only categories"), + ("nocat","don't show categories but only functions") + ], + flags = [ + ("format","format of the visualization file (default \"png\")"), + ("view","program to open the resulting file (default \"open\")") + ] + }), + ("wf", emptyCommandInfo { + longname = "write_file", + synopsis = "send string or tree to a file", + exec = \opts arg -> do + let file = valStrOpts "file" "_gftmp" opts + if isOpt "append" opts + then appendFile file (enc (toString arg)) + else writeFile file (enc (toString arg)) + return void, + options = [ + ("append","append to file, instead of overwriting it") + ], + flags = [("file","the output filename")] + }), + ("ai", emptyCommandInfo { + longname = "abstract_info", + syntax = "ai IDENTIFIER or ai EXPR", + synopsis = "Provides an information about a function, an expression or a category from the abstract syntax", + explanation = unlines [ + "The command has one argument which is either function, expression or", + "a category defined in the abstract syntax of the current grammar. ", + "If the argument is a function then ?its type is printed out.", + "If it is a category then the category definition is printed.", + "If a whole expression is given it prints the expression with refined", + "metavariables and the type of the expression." + ], + exec = \opts arg -> do + case arg of + [EFun id] -> case Map.lookup id (funs (abstract pgf)) of + Just (ty,_,eqs) -> return $ fromString $ + render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$ + if null eqs + then empty + else text "def" <+> vcat [let (scope,ds) = mapAccumL (ppPatt 9) [] patts + in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs]) + Nothing -> case Map.lookup id (cats (abstract pgf)) of + Just hyps -> do return $ fromString $ + render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL ppHypo [] hyps)) $$ + if null (functionsToCat pgf id) + then empty + else space $$ + text "fun" <+> vcat [ppCId fid <+> colon <+> ppType 0 [] ty + | (fid,ty) <- functionsToCat pgf id]) + Nothing -> do putStrLn ("unknown category of function identifier "++show id) + return void + [e] -> case inferExpr pgf e of + Left tcErr -> error $ render (ppTcError tcErr) + Right (e,ty) -> do putStrLn ("Expression: "++showExpr [] e) + putStrLn ("Type: "++showType [] ty) + return void + _ -> do putStrLn "a single identifier or expression is expected from the command" + return void, + needsTypeCheck = False + }) + ] + where + enc = encodeUnicode cod + par opts s = case optOpenTypes opts of + [] -> concat [parse pgf lang (optType opts) s | lang <- optLangs opts, canParse pgf lang] + open_typs -> concat [parseWithRecovery pgf lang (optType opts) open_typs s | lang <- optLangs opts, canParse pgf lang] + + void = ([],[]) + + optLin opts t = unlines $ + case opts of + _ | isOpt "treebank" opts -> (showCId (abstractName pgf) ++ ": " ++ showExpr [] t) : + [showCId lang ++ ": " ++ linear opts lang t | lang <- optLangs opts] + _ -> [linear opts lang t | lang <- optLangs opts] + + linear :: [Option] -> CId -> Expr -> String + linear opts lang = let unl = unlex opts lang in case opts of + _ | isOpt "all" opts -> allLinearize unl pgf lang + _ | isOpt "table" opts -> tableLinearize unl pgf lang + _ | isOpt "term" opts -> termLinearize pgf lang + _ | isOpt "record" opts -> recordLinearize pgf lang + _ | isOpt "bracket" opts -> markLinearize pgf lang + _ -> unl . linearize pgf lang + + unlex opts lang = stringOps Nothing (getUnlex opts lang ++ map prOpt opts) ---- + + getUnlex opts lang = case words (valStrOpts "unlexer" "" opts) of + lexs -> case lookup lang + [(mkCId la,tail le) | lex <- lexs, let (la,le) = span (/='=') lex, not (null le)] of + Just le -> chunks ',' le + _ -> [] + +-- Proposed logic of coding in unlexing: +-- - If lang has no coding flag, or -to_utf8 is not in opts, just opts are used. +-- - If lang has flag coding=utf8, -to_utf8 is ignored. +-- - If lang has coding=other, and -to_utf8 is in opts, from_other is applied first. +-- THIS DOES NOT WORK UNFORTUNATELY - can't use the grammar flag properly + unlexx opts lang = {- trace (unwords optsC) $ -} stringOps Nothing optsC where ---- + optsC = case lookFlag pgf lang "coding" of + Just "utf8" -> filter (/="to_utf8") $ map prOpt opts + Just other | isOpt "to_utf8" opts -> + let cod = ("from_" ++ other) + in cod : filter (/=cod) (map prOpt opts) + _ -> map prOpt opts + + optRestricted opts = + restrictPGF (\f -> and [hasLin pgf la f | la <- optLangs opts]) pgf + + optLangs opts = case valStrOpts "lang" "" opts of + "" -> languages pgf + lang -> map mkCId (chunks ',' lang) + optLang opts = head $ optLangs opts ++ [wildCId] + + optOpenTypes opts = case valStrOpts "openclass" "" opts of + "" -> [] + cats -> mapMaybe readType (chunks ',' cats) + + optType opts = + let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts + in case readType str of + Just ty -> case checkType pgf ty of + Left tcErr -> error $ render (ppTcError tcErr) + Right ty -> ty + Nothing -> error ("Can't parse '"++str++"' as type") + optComm opts = valStrOpts "command" "" opts + optViewFormat opts = valStrOpts "format" "png" opts + optViewGraph opts = valStrOpts "view" "open" opts + optNum opts = valIntOpts "number" 1 opts + optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9 + takeOptNum opts = take (optNumInf opts) + + fromExprs es = (es,unlines (map (showExpr []) es)) + fromStrings ss = (map (ELit . LStr) ss, unlines ss) + fromString s = ([ELit (LStr s)], s) + toStrings = map showAsString + toString = unwords . toStrings + + returnFromExprs es = return $ case es of + [] -> ([], "no trees found") + _ -> fromExprs es + + prGrammar opts + | isOpt "cats" opts = return $ fromString $ unwords $ map showCId $ categories pgf + | isOpt "fullform" opts = return $ fromString $ concatMap (morpho "" prFullFormLexicon) $ optLangs opts + | isOpt "missing" opts = return $ fromString $ unlines $ [unwords (showCId la:":": map showCId cs) | + la <- optLangs opts, let cs = missingLins pgf la] + | otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts) + return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf + + morphos opts s = + [morpho [] (\mo -> lookupMorpho mo s) la | la <- optLangs opts] + + morpho z f la = maybe z f $ Map.lookup la mos + + -- ps -f -g s returns g (f s) + stringOps menv opts s = foldr (menvop . app) s (reverse opts) where + app f = maybe id id (stringOp f) + menvop op = maybe op (\ (b,e) -> opInEnv b e op) menv + + envFlag fs = case valStrOpts "env" "global" fs of + "quotes" -> Just ("\"","\"") + _ -> Nothing + + treeOps opts s = foldr app s (reverse opts) where + app (OOpt op) | Just (Left f) <- treeOp pgf op = f + app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f (mkCId x) + app _ = id + + showAsString t = case t of + ELit (LStr s) -> s + _ -> "\n" ++ showExpr [] t --- newline needed in other cases than the first + +stringOpOptions = sort $ [ + ("bind","bind tokens separated by Prelude.BIND, i.e. &+"), + ("chars","lexer that makes every non-space character a token"), + ("from_cp1251","decode from cp1251 (Cyrillic used in Bulgarian resource)"), + ("from_utf8","decode from utf8 (default)"), + ("lextext","text-like lexer"), + ("lexcode","code-like lexer"), + ("lexmixed","mixture of text and code (code between $...$)"), + ("to_cp1251","encode to cp1251 (Cyrillic used in Bulgarian resource)"), + ("to_html","wrap in a html file with linebreaks"), + ("to_utf8","encode to utf8 (default)"), + ("unlextext","text-like unlexer"), + ("unlexcode","code-like unlexer"), + ("unlexmixed","mixture of text and code (code between $...$)"), + ("unchars","unlexer that puts no spaces between tokens"), + ("unwords","unlexer that puts a single space between tokens (default)"), + ("words","lexer that assumes tokens separated by spaces (default)") + ] ++ + concat [ + [("from_" ++ p, "from unicode to GF " ++ n ++ " transliteration"), + ("to_" ++ p, "from GF " ++ n ++ " transliteration to unicode")] | + (p,n) <- transliterationPrintNames] + +treeOpOptions pgf = [(op,expl) | (op,(expl,Left _)) <- allTreeOps pgf] +treeOpFlags pgf = [(op,expl) | (op,(expl,Right _)) <- allTreeOps pgf] + +translationQuiz :: Encoding -> PGF -> Language -> Language -> Type -> IO () +translationQuiz cod pgf ig og typ = do + tts <- translationList pgf ig og typ infinity + mkQuiz cod "Welcome to GF Translation Quiz." tts + +morphologyQuiz :: Encoding -> PGF -> Language -> Type -> IO () +morphologyQuiz cod pgf ig typ = do + tts <- morphologyList pgf ig typ infinity + mkQuiz cod "Welcome to GF Morphology Quiz." tts + +-- | the maximal number of precompiled quiz problems +infinity :: Int +infinity = 256 + +lookFlag :: PGF -> String -> String -> Maybe String +lookFlag pgf lang flag = lookConcrFlag pgf (mkCId lang) (mkCId flag) + +prFullFormLexicon :: Morpho -> String +prFullFormLexicon mo = + unlines [w ++ " : " ++ prMorphoAnalysis ts | (w,ts) <- fullFormLexicon mo] + +prMorphoAnalysis :: [(Lemma,Analysis)] -> String +prMorphoAnalysis lps = unlines [showCId l ++ " " ++ p | (l,p) <- lps] + diff --git a/src/compiler/GF/Command/Importing.hs b/src/compiler/GF/Command/Importing.hs new file mode 100644 index 000000000..06deab6c6 --- /dev/null +++ b/src/compiler/GF/Command/Importing.hs @@ -0,0 +1,50 @@ +module GF.Command.Importing (importGrammar, importSource) where + +import PGF +import PGF.Data + +import GF.Compile +import GF.Grammar.Grammar (SourceGrammar) -- for cc command +import GF.Grammar.CF +import GF.Infra.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 :: PGF -> Options -> [FilePath] -> IO PGF +importGrammar pgf0 _ [] = return pgf0 +importGrammar pgf0 opts files = + case takeExtensions (last files) of + ".cf" -> do + s <- fmap unlines $ mapM readFile files + let cnc = justModuleName (last files) + gf <- case getCF cnc s of + Ok g -> return g + Bad s -> error s ---- + Ok gr <- appIOE $ compileSourceGrammar opts gf + epgf <- appIOE $ link opts (cnc ++ "Abs") gr + case epgf of + Ok pgf -> return pgf + Bad s -> error s ---- + s | elem s [".gf",".gfo"] -> do + res <- appIOE $ compileToPGF opts files + case res of + Ok pgf2 -> do return $ unionPGF pgf0 pgf2 + Bad msg -> do putStrLn ('\n':'\n':msg) + return pgf0 + ".pgf" -> do + pgf2 <- mapM readPGF files >>= return . foldl1 unionPGF + return $ unionPGF pgf0 pgf2 + ext -> die $ "Unknown filename extension: " ++ show ext + +importSource :: SourceGrammar -> Options -> [FilePath] -> IO SourceGrammar +importSource src0 opts files = do + src <- appIOE $ batchCompile opts files + case src of + Ok gr -> return gr + Bad msg -> do + putStrLn msg + return src0 diff --git a/src/compiler/GF/Command/Interpreter.hs b/src/compiler/GF/Command/Interpreter.hs new file mode 100644 index 000000000..ff84da8a3 --- /dev/null +++ b/src/compiler/GF/Command/Interpreter.hs @@ -0,0 +1,132 @@ +module GF.Command.Interpreter ( + CommandEnv (..), + mkCommandEnv, + emptyCommandEnv, + interpretCommandLine, + interpretPipe, + getCommandOp + ) where + +import GF.Command.Commands +import GF.Command.Abstract +import GF.Command.Parse +import PGF +import PGF.Data +import PGF.Morphology +import GF.System.Signal +import GF.Infra.UseIO +import GF.Infra.Option + +import Text.PrettyPrint +import Control.Monad.Error +import qualified Data.Map as Map + +data CommandEnv = CommandEnv { + multigrammar :: PGF, + morphos :: Map.Map Language Morpho, + commands :: Map.Map String CommandInfo, + commandmacros :: Map.Map String CommandLine, + expmacros :: Map.Map String Expr + } + +mkCommandEnv :: Encoding -> PGF -> CommandEnv +mkCommandEnv enc pgf = + let mos = Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf] in + CommandEnv pgf mos (allCommands enc (pgf, mos)) Map.empty Map.empty + +emptyCommandEnv :: CommandEnv +emptyCommandEnv = mkCommandEnv UTF_8 emptyPGF + +interpretCommandLine :: (String -> String) -> CommandEnv -> String -> IO () +interpretCommandLine enc env line = + case readCommandLine line of + Just [] -> return () + Just pipes -> mapM_ (interpretPipe enc env) pipes + Nothing -> putStrLnFlush "command not parsed" + +interpretPipe enc env cs = do + v@(_,s) <- intercs ([],"") cs + putStrLnFlush $ enc s + return v + where + intercs treess [] = return treess + intercs (trees,_) (c:cs) = do + treess2 <- interc trees c + intercs treess2 cs + interc es comm@(Command co opts arg) = case co of + '%':f -> case Map.lookup f (commandmacros env) of + Just css -> + case getCommandTrees env False arg es of + Right es -> do mapM_ (interpretPipe enc env) (appLine es css) + return ([],[]) + Left msg -> do putStrLn ('\n':msg) + return ([],[]) + Nothing -> do + putStrLn $ "command macro " ++ co ++ " not interpreted" + return ([],[]) + _ -> interpret enc env es comm + appLine es = map (map (appCommand es)) + +-- macro definition applications: replace ?i by (exps !! i) +appCommand :: [Expr] -> Command -> Command +appCommand xs c@(Command i os arg) = case arg of + AExpr e -> Command i os (AExpr (app e)) + _ -> c + where + app e = case e of + EAbs b x e -> EAbs b x (app e) + EApp e1 e2 -> EApp (app e1) (app e2) + ELit l -> ELit l + EMeta i -> xs !! i + EFun x -> EFun x + +-- return the trees to be sent in pipe, and the output possibly printed +interpret :: (String -> String) -> CommandEnv -> [Expr] -> Command -> IO CommandOutput +interpret enc env trees comm = + case getCommand env trees comm of + Left msg -> do putStrLn ('\n':msg) + return ([],[]) + Right (info,opts,trees) -> do tss@(_,s) <- exec info opts trees + if isOpt "tr" opts + then putStrLn (enc s) + else return () + return tss + +-- analyse command parse tree to a uniform datastructure, normalizing comm name +--- the env is needed for macro lookup +getCommand :: CommandEnv -> [Expr] -> Command -> Either String (CommandInfo,[Option],[Expr]) +getCommand env es co@(Command c opts arg) = do + info <- getCommandInfo env c + checkOpts info opts + es <- getCommandTrees env (needsTypeCheck info) arg es + return (info,opts,es) + +getCommandInfo :: CommandEnv -> String -> Either String CommandInfo +getCommandInfo env cmd = + case lookCommand (getCommandOp cmd) (commands env) of + Just info -> return info + Nothing -> fail $ "command " ++ cmd ++ " not interpreted" + +checkOpts :: CommandInfo -> [Option] -> Either String () +checkOpts info opts = + case + [o | OOpt o <- opts, notElem o ("tr" : map fst (options info))] ++ + [o | OFlag o _ <- opts, notElem o (map fst (flags info))] + of + [] -> return () + [o] -> fail $ "option not interpreted: " ++ o + os -> fail $ "options not interpreted: " ++ unwords os + +getCommandTrees :: CommandEnv -> Bool -> Argument -> [Expr] -> Either String [Expr] +getCommandTrees env needsTypeCheck a es = + case a of + AMacro m -> case Map.lookup m (expmacros env) of + Just e -> return [e] + _ -> return [] + AExpr e -> if needsTypeCheck + then case inferExpr (multigrammar env) e of + Left tcErr -> fail $ render (ppTcError tcErr) + Right (e,ty) -> return [e] -- ignore piped + else return [e] + ANoArg -> return es -- use piped + diff --git a/src/compiler/GF/Command/Messages.hs b/src/compiler/GF/Command/Messages.hs new file mode 100644 index 000000000..8dda92d49 --- /dev/null +++ b/src/compiler/GF/Command/Messages.hs @@ -0,0 +1,54 @@ +module GF.Command.Messages where + +licenseMsg = unlines [ + "Copyright (c)", + "Krasimir Angelov, Bj\246rn Bringert, H\229kan Burden, Hans-Joachim Daniels,", + "Markus Forsberg, Thomas Hallgren, Harald Hammarstr\246m, Kristofer Johannisson,", + "Janna Khegai, Peter Ljungl\246f, Petri M\228enp\228\228, and", + "Aarne Ranta, 1998-2008, under GNU General Public License (GPL)", + "see LICENSE in GF distribution, or http://www.gnu.org/licenses/gpl.html." + ] + +codingMsg = unlines [ + "The GF shell uses Unicode internally, but assumes user input to be UTF8", + "and converts terminal and file output to UTF8. If your terminal is not UTF8", + "see 'help set_encoding." + ] + +changesMsg = unlines [ + "While GF 3.0 is backward compatible with source grammars, the shell commands", + "have changed from version 2.9. Below the most importand changes. Bug reports", + "and feature requests should be sent to http://trac.haskell.org/gf/.", + "", + "af use wf -append", + "at not supported", + "eh not yet supported", + "es no longer supported; use javascript generation", + "g not yet supported", + "l now by default multilingual", + "ml not yet supported", + "p now by default multilingual", + "pi not yet supported", + "pl not yet supported", + "pm subsumed to pg", + "po not yet supported", + "pt not yet supported", + "r not yet supported", + "rf changed syntax", + "rl not supported", + "s no longer needed", + "sa not supported", + "sf not supported", + "si not supported", + "so not yet supported", + "t use pipe with l and p", + "tb use l -treebank", + "tl not yet supported", + "tq changed syntax", + "ts not supported", + "tt use ps", + "ut not supported", + "vg not yet supported", + "wf changed syntax", + "wt not supported" + ] diff --git a/src/compiler/GF/Command/Parse.hs b/src/compiler/GF/Command/Parse.hs new file mode 100644 index 000000000..44366c472 --- /dev/null +++ b/src/compiler/GF/Command/Parse.hs @@ -0,0 +1,64 @@ +module GF.Command.Parse(readCommandLine, pCommand) where + +import PGF.CId +import PGF.Expr +import GF.Command.Abstract + +import Data.Char +import Control.Monad +import qualified Text.ParserCombinators.ReadP as RP + +readCommandLine :: String -> Maybe CommandLine +readCommandLine s = case [x | (x,cs) <- RP.readP_to_S pCommandLine s, all isSpace cs] of + [x] -> Just x + _ -> Nothing + +pCommandLine = + (RP.skipSpaces >> RP.char '-' >> RP.char '-' >> RP.skipMany (RP.satisfy (const True)) >> return []) -- comment + RP.<++ + (RP.sepBy (RP.skipSpaces >> pPipe) (RP.skipSpaces >> RP.char ';')) + +pPipe = RP.sepBy1 (RP.skipSpaces >> pCommand) (RP.skipSpaces >> RP.char '|') + +pCommand = (do + cmd <- pIdent RP.<++ (RP.char '%' >> pIdent >>= return . ('%':)) + RP.skipSpaces + opts <- RP.sepBy pOption RP.skipSpaces + arg <- pArgument + return (Command cmd opts arg) + ) + RP.<++ (do + RP.char '?' + c <- pSystemCommand + return (Command "sp" [OFlag "command" (VStr c)] ANoArg) + ) + +pOption = do + RP.char '-' + flg <- pIdent + RP.option (OOpt flg) (fmap (OFlag flg) (RP.char '=' >> pValue)) + +pValue = do + fmap (VInt . read) (RP.munch1 isDigit) + RP.<++ + fmap VStr pStr + RP.<++ + fmap VId pFilename + +pFilename = liftM2 (:) (RP.satisfy isFileFirst) (RP.munch (not . isSpace)) where + isFileFirst c = not (isSpace c) && not (isDigit c) + +pArgument = + RP.option ANoArg + (fmap AExpr pExpr + RP.<++ + (RP.munch isSpace >> RP.char '%' >> fmap AMacro pIdent)) + +pSystemCommand = + RP.munch isSpace >> ( + (RP.char '"' >> (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"'))) + RP.<++ + RP.many RP.get + ) + where + pEsc = RP.char '\\' >> RP.get diff --git a/src/compiler/GF/Command/TreeOperations.hs b/src/compiler/GF/Command/TreeOperations.hs new file mode 100644 index 000000000..941f03782 --- /dev/null +++ b/src/compiler/GF/Command/TreeOperations.hs @@ -0,0 +1,32 @@ +module GF.Command.TreeOperations ( + treeOp, + allTreeOps + ) where + +import PGF +import PGF.Data +import Data.List + +type TreeOp = [Expr] -> [Expr] + +treeOp :: PGF -> String -> Maybe (Either TreeOp (CId -> TreeOp)) +treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf + +allTreeOps :: PGF -> [(String,(String,Either TreeOp (CId -> TreeOp)))] +allTreeOps pgf = [ + ("compute",("compute by using semantic definitions (def)", + Left $ map (compute pgf))), + ("transfer",("syntactic transfer by applying function and computing", + Right $ \f -> map (compute pgf . EApp (EFun f)))), + ("paraphrase",("paraphrase by using semantic definitions (def)", + Left $ nub . concatMap (paraphrase pgf))), + ("smallest",("sort trees from smallest to largest, in number of nodes", + Left $ smallest)) + ] + +smallest :: [Expr] -> [Expr] +smallest = sortBy (\t u -> compare (size t) (size u)) where + size t = case t of + EAbs _ _ e -> size e + 1 + EApp e1 e2 -> size e1 + size e2 + 1 + _ -> 1 diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs new file mode 100644 index 000000000..e0c60178e --- /dev/null +++ b/src/compiler/GF/Compile.hs @@ -0,0 +1,252 @@ +module GF.Compile (batchCompile, link, compileToPGF, compileSourceGrammar) where + +-- the main compiler passes +import GF.Compile.GetGrammar +import GF.Compile.Rename +import GF.Compile.CheckGrammar +import GF.Compile.Optimize +import GF.Compile.SubExOpt +import GF.Compile.OptimizeGFCC +import GF.Compile.GrammarToGFCC +import GF.Compile.ReadFiles +import GF.Compile.Update +import GF.Compile.Refresh + +import GF.Compile.Coding +import GF.Text.UTF8 ---- + +import GF.Grammar.Grammar +import GF.Grammar.Lookup +import GF.Grammar.Printer +import GF.Grammar.Binary + +import GF.Infra.Ident +import GF.Infra.Option +import GF.Infra.Modules +import GF.Infra.UseIO +import GF.Infra.CheckM + +import GF.Data.Operations + +import Control.Monad +import System.IO +import System.Directory +import System.FilePath +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.List(nub) +import Data.Maybe (isNothing) +import Data.Binary +import Text.PrettyPrint + +import PGF.Check +import PGF.CId +import PGF.Data +import PGF.Macros + + +-- | Compiles a number of source files and builds a 'PGF' structure for them. +compileToPGF :: Options -> [FilePath] -> IOE PGF +compileToPGF opts fs = + do gr <- batchCompile opts fs + let name = justModuleName (last fs) + link opts name gr + +link :: Options -> String -> SourceGrammar -> IOE PGF +link opts cnc gr = do + let isv = (verbAtLeast opts Normal) + gc1 <- putPointE Normal opts "linking ... " $ + let (abs,gc0) = mkCanon2gfcc opts cnc gr + in case checkPGF gc0 of + Ok (gc,b) -> do + case (isv,b) of + (True, True) -> ioeIO $ putStrLn "OK" + (False,True) -> return () + _ -> ioeIO $ putStrLn $ "Corrupted PGF" + return gc + Bad s -> fail s + ioeIO $ buildParser opts $ optimize opts gc1 + +optimize :: Options -> PGF -> PGF +optimize opts = cse . suf + where os = flag optOptimizations opts + cse = if OptCSE `Set.member` os then cseOptimize else id + suf = if OptStem `Set.member` os then suffixOptimize else id + +buildParser :: Options -> PGF -> IO PGF +buildParser opts = + case flag optBuildParser opts of + BuildParser -> addParsers opts + DontBuildParser -> return + BuildParserOnDemand -> return . mapConcretes (\cnc -> cnc { cflags = Map.insert (mkCId "parser") "ondemand" (cflags cnc) }) + +batchCompile :: Options -> [FilePath] -> IOE SourceGrammar +batchCompile opts files = do + (_,gr,_) <- foldM (compileModule opts) emptyCompileEnv files + return gr + +-- to compile a set of modules, e.g. an old GF or a .cf file +compileSourceGrammar :: Options -> SourceGrammar -> IOE SourceGrammar +compileSourceGrammar opts gr@(MGrammar ms) = do + (_,gr',_) <- foldM compOne (0,emptySourceGrammar,Map.empty) ms + return gr' + where + compOne env mo = do + (k,mo') <- compileSourceModule opts env mo + extendCompileEnvInt env k Nothing mo' --- file for the same of modif time... + +-- to output an intermediate stage +intermOut :: Options -> Dump -> Doc -> IOE () +intermOut opts d doc + | dump opts d = ioeIO (hPutStrLn stderr (encodeUTF8 (render (text "\n\n--#" <+> text (show d) $$ doc)))) + | otherwise = return () + +-- | 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 -- ^ Options from program command line and shell command. + -> CompileEnv -> FilePath -> IOE CompileEnv +compileModule opts1 env file = do + file <- getRealFile file + opts0 <- getOptionsFromFile file + curr_dir <- return $ dropFileName file + lib_dir <- ioeIO $ getLibraryDirectory (addOptions opts0 opts1) + let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1 + ps0 <- ioeIO $ extendPathEnv opts + let ps = nub (curr_dir : ps0) + ioeIO $ putIfVerb opts $ "module search path:" +++ show ps ---- + let (_,sgr,rfs) = env + files <- getAllFiles opts ps rfs file + ioeIO $ putIfVerb opts $ "files to read:" +++ show files ---- + let names = map justModuleName files + ioeIO $ putIfVerb opts $ "modules to include:" +++ show names ---- + foldM (compileOne opts) (0,sgr,rfs) files + where + getRealFile file = do + exists <- ioeIO $ doesFileExist file + if exists + then return file + else if isRelative file + then do lib_dir <- ioeIO $ getLibraryDirectory opts1 + let file1 = lib_dir file + exists <- ioeIO $ doesFileExist file1 + if exists + then return file1 + else ioeErr $ Bad (render (text "None of this files exist:" $$ nest 2 (text file $$ text file1))) + else ioeErr $ Bad (render (text "File" <+> text file <+> text "does not exist.")) + +compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv +compileOne opts env@(_,srcgr,_) file = do + + let putpOpt v m act + | verbAtLeast opts Verbose = putPointE Normal opts v act + | verbAtLeast opts Normal = ioeIO (putStrFlush m) >> act + | otherwise = putPointE Verbose opts v act + + let gf = takeExtensions file + let path = dropFileName file + let name = dropExtension file + + case gf of + + -- for compiled gf, read the file and update environment + -- also undo common subexp optimization, to enable normal computations + ".gfo" -> do + sm00 <- putPointE Normal opts ("+ reading" +++ file) $ ioeIO (decodeFile file) + let sm0 = addOptionsToModule opts sm00 + + intermOut opts DumpSource (ppModule Qualified sm0) + + let sm1 = unsubexpModule sm0 + sm <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ extendModule srcgr sm1 + + extendCompileEnv env file sm + + -- for gf source, do full compilation and generate code + _ -> do + + let gfo = gf2gfo opts file + b1 <- ioeIO $ doesFileExist file + if not b1 + then compileOne opts env $ gfo + else do + + sm00 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ + getSourceModule opts file + let sm0 = decodeStringsInModule sm00 + + intermOut opts DumpSource (ppModule Qualified sm0) + + (k',sm) <- compileSourceModule opts env sm0 + putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo sm + extendCompileEnvInt env k' (Just gfo) sm + where + isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete + +compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule) +compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do + + let puts = putPointE Quiet opts + putpp = putPointE Verbose opts + + mo1 <- ioeErr $ rebuildModule gr mo + intermOut opts DumpRebuild (ppModule Qualified mo1) + + mo1b <- ioeErr $ extendModule gr mo1 + intermOut opts DumpExtend (ppModule Qualified mo1b) + + case mo1b of + (_,n) | not (isCompleteModule n) -> do + return (k,mo1b) -- refresh would fail, since not renamed + _ -> do + let mos = modules gr + + (mo2,warnings) <- putpp " renaming " $ ioeErr $ runCheck (renameModule mos mo1b) + if null warnings then return () else puts warnings $ return () + intermOut opts DumpRename (ppModule Qualified mo2) + + (mo3,warnings) <- putpp " type checking" $ ioeErr $ runCheck (checkModule mos mo2) + if null warnings then return () else puts warnings $ return () + intermOut opts DumpTypeCheck (ppModule Qualified mo3) + + (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3 + intermOut opts DumpRefresh (ppModule Qualified mo3r) + + mo4 <- putpp " optimizing " $ ioeErr $ optimizeModule opts mos mo3r + intermOut opts DumpOptimize (ppModule Qualified mo4) + + return (k',mo4) + +generateModuleCode :: Options -> FilePath -> SourceModule -> IOE SourceModule +generateModuleCode opts file minfo = do + let minfo1 = subexpModule minfo + minfo2 = case minfo1 of + (m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi) + , positions=Map.empty}) + putPointE Normal opts (" wrote file" +++ file) $ ioeIO $ encodeFile file minfo2 + return minfo1 + +-- auxiliaries + +reverseModules (MGrammar ms) = MGrammar $ reverse ms + +emptyCompileEnv :: CompileEnv +emptyCompileEnv = (0,emptyMGrammar,Map.empty) + +extendCompileEnvInt (_,MGrammar ss,menv) k mfile sm = do + let (mod,imps) = importsOfModule sm + menv2 <- case mfile of + Just file -> do + t <- ioeIO $ getModificationTime file + return $ Map.insert mod (t,imps) menv + _ -> return menv + return (k,MGrammar (sm:ss),menv2) --- reverse later + +extendCompileEnv e@(k,_,_) file sm = extendCompileEnvInt e k (Just file) sm + + diff --git a/src/compiler/GF/Compile/Abstract/Compute.hs b/src/compiler/GF/Compile/Abstract/Compute.hs new file mode 100644 index 000000000..d5c9a163c --- /dev/null +++ b/src/compiler/GF/Compile/Abstract/Compute.hs @@ -0,0 +1,138 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Compile.Abstract.Compute +-- 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.Compile.Abstract.Compute (LookDef, + compute, + computeAbsTerm, + computeAbsTermIn, + beta + ) where + +import GF.Data.Operations + +import GF.Grammar +import GF.Grammar.Lookup + +import Debug.Trace +import Data.List(intersperse) +import Control.Monad (liftM, liftM2) +import Text.PrettyPrint + +-- for debugging +tracd m t = t +-- tracd = trace + +compute :: SourceGrammar -> Exp -> Err Exp +compute = computeAbsTerm + +computeAbsTerm :: SourceGrammar -> 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 Int,Maybe [Equation]) + +computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp +computeAbsTermIn lookd xs e = errIn (render (text "computing" <+> ppTerm Unqualified 0 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' = map snd yy ++ vv + aa' <- mapM (compt vv') aa + case look f of + Just eqs -> tracd (text "\nmatching" <+> ppTerm Unqualified 0 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 (text "by Egs:" <+> ppTerm Unqualified 0 d') $ return $ mkAbs yy $ d' + _ -> tracd (text "no match" <+> ppTerm Unqualified 0 t') $ + do + let v = mkApp f aa' + return $ mkAbs yy $ v + _ -> do + let t2 = mkAbs yy $ mkApp f aa' + tracd (text "not defined" <+> ppTerm Unqualified 0 t2) $ return t2 + + look t = case t of + (Q m f) -> case lookd m f of + Ok (_,md) -> md + _ -> Nothing + _ -> 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 b x a t -> Prod b x (beta vv a) (beta (x:vv) t) + Abs b x t -> Abs b x (beta (x:vv) t) + _ -> 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 $ render (text "no applicable case for" <+> hcat (punctuate comma (map (ppTerm Unqualified 0) terms))) + (patts,_):_ | length patts /= length terms -> + Bad (render (text "wrong number of args for patterns :" <+> + hsep (map (ppPatt Unqualified 0) patts) <+> text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms))) + (patts,val):cc -> case mapM tryMatch (zip patts terms) of + Ok substs -> return (tracd (text "value" <+> ppTerm Unqualified 0 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 + (PW, _) | 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' + (PAs x p',_) -> do + subst <- trym p' t' + return $ (x,t) : subst + _ -> Bad (render (text "no match in pattern" <+> ppPatt Unqualified 0 p <+> text "for" <+> ppTerm Unqualified 0 t)) + + notMeta e = case e of + Meta _ -> False + App f a -> notMeta f && notMeta a + Abs _ _ b -> notMeta b + _ -> True + + prtm p g = + ppPatt Unqualified 0 p <+> colon $$ hsep (punctuate semi [ppIdent x <+> char '=' <+> ppTerm Unqualified 0 y | (x,y) <- g]) diff --git a/src/compiler/GF/Compile/Abstract/TC.hs b/src/compiler/GF/Compile/Abstract/TC.hs new file mode 100644 index 000000000..163301838 --- /dev/null +++ b/src/compiler/GF/Compile/Abstract/TC.hs @@ -0,0 +1,294 @@ +---------------------------------------------------------------------- +-- | +-- 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.Compile.Abstract.TC (AExp(..), + Theory, + checkExp, + inferExp, + checkBranch, + eqVal, + whnf + ) where + +import GF.Data.Operations +import GF.Grammar +import GF.Grammar.Predef + +import Control.Monad +import Data.List (sortBy) +import Data.Maybe +import Text.PrettyPrint + +data AExp = + AVr Ident Val + | ACn QIdent Val + | AType + | AInt Integer + | AFloat Double + | AStr String + | AMeta MetaId Val + | AApp AExp AExp Val + | AAbs Ident Val AExp + | AProd Ident AExp AExp + | AEqs [([Exp],AExp)] --- not used + | ARecType [ALabelling] + | AR [AAssign] + | AP AExp Label Val + | AData Val + deriving (Eq,Show) + +type ALabelling = (Label, AExp) +type AAssign = (Label, (Val, AExp)) + +type Theory = QIdent -> Err Val + +lookupConst :: Theory -> QIdent -> Err Val +lookupConst th f = th f + +lookupVar :: Env -> Ident -> Err Val +lookupVar g x = maybe (Bad (render (text "unknown variable" <+> ppIdent 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) + RecType xs -> do xs <- mapM (\(l,e) -> eval env e >>= \e -> return (l,e)) xs + return (VRecType xs) + _ -> 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,[]) + + 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) + _ -> Bad (render (text "function type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ)) + + 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) + + R xs -> + case typ of + VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of + [] -> return () + ls -> fail (render (text "no value given for label:" <+> fsep (punctuate comma (map ppLabel ls)))) + r <- mapM (checkAssign th tenv ys) xs + let (xs,css) = unzip r + return (AR xs, concat css) + _ -> Bad (render (text "record type expected for" <+> ppTerm Unqualified 0 e <+> text "instead of" <+> ppValue Unqualified 0 typ)) + + P r l -> do (r',cs) <- checkExp th tenv r (VRecType [(l,typ)]) + return (AP r' l typ,cs) + + _ -> 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 && isPredefCat c + -> 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, []) + RecType xs -> do r <- mapM (checkLabelling th tenv) xs + let (xs,css) = unzip r + return (ARecType xs, vType, concat css) + 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) + _ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ)) + _ -> Bad (render (text "cannot infer type of expression" <+> ppTerm Unqualified 0 e)) + +checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)]) +checkLabelling th tenv (lbl,typ) = do + (atyp,cs) <- checkType th tenv typ + return ((lbl,atyp),cs) + +checkAssign :: Theory -> TCEnv -> [(Label,Val)] -> Assign -> Err (AAssign, [(Val,Val)]) +checkAssign th tenv@(k,rho,gamma) typs (lbl,(Just typ,exp)) = do + (atyp,cs1) <- checkType th tenv typ + val <- eval rho typ + cs2 <- case lookup lbl typs of + Nothing -> return [] + Just val0 -> eqVal k val val0 + (aexp,cs3) <- checkExp th tenv exp val + return ((lbl,(val,aexp)),cs1++cs2++cs3) +checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do + case lookup lbl typs of + Nothing -> do (aexp,val,cs) <- inferExp th tenv exp + return ((lbl,(val,aexp)),cs) + Just val -> do (aexp,cs) <- checkExp th tenv exp val + return ((lbl,(val,aexp)),cs) + +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 + _ -> Bad (render (text "Product expected for definiens" <+> ppTerm Unqualified 0 t <+> text "instead of" <+> ppValue Unqualified 0 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 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 (Q m c) xss : ps, j, g',k') + where (xss,j,g',k') = foldr p2t ([],i,g,k) xs + _ -> error $ render (text "undefined p2t case" <+> ppPatt Unqualified 0 p <+> text "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) + _ -> Bad (render (text "Prod expected for function" <+> ppTerm Unqualified 0 f <+> text "instead of" <+> ppValue Unqualified 0 typ)) + _ -> Bad (render (text "cannot typecheck pattern" <+> ppTerm Unqualified 0 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/compiler/GF/Compile/Abstract/TypeCheck.hs b/src/compiler/GF/Compile/Abstract/TypeCheck.hs new file mode 100644 index 000000000..2632c54dd --- /dev/null +++ b/src/compiler/GF/Compile/Abstract/TypeCheck.hs @@ -0,0 +1,83 @@ +---------------------------------------------------------------------- +-- | +-- 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.Compile.Abstract.TypeCheck (-- * top-level type checking functions; TC should not be called directly. + checkContext, + checkTyp, + checkDef, + checkConstrs, + ) where + +import GF.Data.Operations + +import GF.Infra.CheckM +import GF.Grammar +import GF.Grammar.Lookup +import GF.Grammar.Unify +import GF.Compile.Refresh +import GF.Compile.Abstract.Compute +import GF.Compile.Abstract.TC + +import Text.PrettyPrint +import Control.Monad (foldM, liftM, liftM2) + +-- | invariant way of creating TCEnv from context +initTCEnv gamma = + (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) + +-- interface to TC type checker + +type2val :: Type -> Val +type2val = VClos [] + +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 + +justTypeCheck :: SourceGrammar -> Exp -> Val -> Err Constraints +justTypeCheck gr e v = do + (_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v + (constrs1,_) <- unifyVal constrs0 + return $ filter notJustMeta constrs1 + +notJustMeta (c,k) = case (c,k) of + (VClos g1 (Meta m1), VClos g2 (Meta m2)) -> False + _ -> True + +grammar2theory :: SourceGrammar -> 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 + +checkContext :: SourceGrammar -> Context -> [Message] +checkContext st = checkTyp st . cont2exp + +checkTyp :: SourceGrammar -> Type -> [Message] +checkTyp gr typ = err (\x -> [text x]) ppConstrs $ justTypeCheck gr typ vType + +checkDef :: SourceGrammar -> Fun -> Type -> [Equation] -> [Message] +checkDef gr (m,fun) typ eqs = err (\x -> [text x]) ppConstrs $ do + bcs <- mapM (\b -> checkBranch (grammar2theory gr) (initTCEnv []) b (type2val typ)) eqs + let (bs,css) = unzip bcs + (constrs,_) <- unifyVal (concat css) + return $ filter notJustMeta constrs + +checkConstrs :: SourceGrammar -> Cat -> [Ident] -> [String] +checkConstrs gr cat _ = [] ---- check constructors! diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs new file mode 100644 index 000000000..f4765eb26 --- /dev/null +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -0,0 +1,284 @@ +---------------------------------------------------------------------- +-- | +-- 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(checkModule) where + +import GF.Infra.Ident +import GF.Infra.Modules + +import GF.Compile.Abstract.TypeCheck +import GF.Compile.Concrete.TypeCheck + +import GF.Grammar +import GF.Grammar.Lexer +import GF.Grammar.Lookup +import GF.Grammar.Predef +import GF.Grammar.PatternMatch + +import GF.Data.Operations +import GF.Infra.CheckM + +import Data.List +import qualified Data.Set as Set +import Control.Monad +import Text.PrettyPrint + +-- | checking is performed in the dependency order of modules +checkModule :: [SourceModule] -> SourceModule -> Check SourceModule +checkModule ms m@(name,mo) = checkIn (text "checking module" <+> ppIdent name) $ do + checkRestrictedInheritance ms m + m <- case mtype mo of + MTConcrete a -> do let gr = MGrammar (m:ms) + abs <- checkErr $ lookupModule gr a + checkCompleteGrammar gr (a,abs) m + _ -> return m + infos <- checkErr $ topoSortJments m + foldM updateCheckInfo m infos + where + updateCheckInfo (name,mo) (i,info) = do + info <- checkInfo ms (name,mo) i info + return (name,updateModule mo i info) + +-- 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,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 -> checkError (text "In inherited module" <+> ppIdent i <> text ", dependence of excluded constants:" $$ + nest 2 (vcat [ppIdent f <+> text "on" <+> fsep (map ppIdent is) | (f,is) <- cs])) + allDeps = concatMap (allDependencies (const True) . jments . snd) mos + +checkCompleteGrammar :: SourceGrammar -> SourceModule -> SourceModule -> Check SourceModule +checkCompleteGrammar gr (am,abs) (cm,cnc) = do + let jsa = jments abs + let jsc = jments cnc + + -- check that all concrete constants are in abstract; build types for all lin + jsc <- foldM checkCnc emptyBinTree (tree2list jsc) + + -- check that all abstract constants are in concrete; build default lin and lincats + jsc <- foldM checkAbs jsc (tree2list jsa) + + return (cm,replaceJudgements cnc jsc) + where + checkAbs js i@(c,info) = + case info of + AbsFun (Just ty) _ _ -> do let mb_def = do + let (cxt,(_,i),_) = typeForm ty + info <- lookupIdent i js + info <- case info of + (AnyInd _ m) -> do (m,info) <- lookupOrigInfo gr m i + return info + _ -> return info + case info of + CncCat (Just (RecType [])) _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt) + _ -> Bad "no def lin" + + case lookupIdent c js of + Ok (AnyInd _ _) -> return js + Ok (CncFun ty (Just def) pn) -> + return $ updateTree (c,CncFun ty (Just def) pn) js + Ok (CncFun ty Nothing pn) -> + case mb_def of + Ok def -> return $ updateTree (c,CncFun ty (Just def) pn) js + Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c + return js + _ -> do + case mb_def of + Ok def -> do (cont,val) <- linTypeOfType gr cm ty + let linty = (snd (valCat ty),cont,val) + return $ updateTree (c,CncFun (Just linty) (Just def) Nothing) js + Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c + return js + AbsCat (Just _) _ -> case lookupIdent c js of + Ok (AnyInd _ _) -> return js + Ok (CncCat (Just _) _ _) -> return js + Ok (CncCat _ mt mp) -> do + checkWarn $ + text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}" + return $ updateTree (c,CncCat (Just defLinType) mt mp) js + _ -> do + checkWarn $ + text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}" + return $ updateTree (c,CncCat (Just defLinType) Nothing Nothing) js + _ -> return js + + checkCnc js i@(c,info) = + case info of + CncFun _ d pn -> case lookupOrigInfo gr am c of + Ok (_,AbsFun (Just ty) _ _) -> + do (cont,val) <- linTypeOfType gr cm ty + let linty = (snd (valCat ty),cont,val) + return $ updateTree (c,CncFun (Just linty) d pn) js + _ -> do checkWarn $ text "function" <+> ppIdent c <+> text "is not in abstract" + return js + CncCat _ _ _ -> case lookupOrigInfo gr am c of + Ok _ -> return $ updateTree i js + _ -> do checkWarn $ text "category" <+> ppIdent c <+> text "is not in abstract" + return js + _ -> return $ updateTree i js + + +-- | General Principle: only Just-values are checked. +-- A May-value has always been checked in its origin module. +checkInfo :: [SourceModule] -> SourceModule -> Ident -> Info -> Check Info +checkInfo ms (m,mo) c info = do + checkReservedId c + case info of + AbsCat (Just cont) _ -> mkCheck "category" $ + checkContext gr cont + + AbsFun (Just typ0) ma md -> do + typ <- compAbsTyp [] typ0 -- to calculate let definitions + mkCheck "type of function" $ + checkTyp gr typ + case md of + Just eqs -> mkCheck "definition of function" $ + checkDef gr (m,c) typ eqs + Nothing -> return info + return (AbsFun (Just typ) ma md) + + CncFun linty@(Just (cat,cont,val)) (Just trm) mpr -> chIn "linearization of" $ do + (trm',_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars + mpr <- checkPrintname gr mpr + return (CncFun linty (Just trm') mpr) + + CncCat (Just typ) mdef mpr -> chIn "linearization type of" $ do + (typ,_) <- checkLType gr [] typ typeType + typ <- computeLType gr [] typ + mdef <- case mdef of + Just def -> do + (def,_) <- checkLType gr [] def (mkFunType [typeStr] typ) + return $ Just def + _ -> return mdef + mpr <- checkPrintname gr mpr + return (CncCat (Just typ) mdef mpr) + + ResOper pty pde -> chIn "operation" $ do + (pty', pde') <- case (pty,pde) of + (Just ty, Just de) -> do + ty' <- checkLType gr [] ty typeType >>= computeLType gr [] . fst + (de',_) <- checkLType gr [] de ty' + return (Just ty', Just de') + (_ , Just de) -> do + (de',ty') <- inferLType gr [] de + return (Just ty', Just de') + (_ , Nothing) -> do + checkError (text "No definition given to the operation") + return (ResOper pty' pde') + + ResOverload os tysts -> chIn "overloading" $ do + tysts' <- mapM (uncurry $ flip (checkLType gr [])) tysts -- return explicit ones + tysts0 <- checkErr $ lookupOverload gr m c -- check against inherited ones too + tysts1 <- mapM (uncurry $ flip (checkLType gr [])) + [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0] + --- this can only be a partial guarantee, since matching + --- with value type is only possible if expected type is given + checkUniq $ + sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1] + return (ResOverload os [(y,x) | (x,y) <- tysts']) + + ResParam (Just pcs) _ -> chIn "parameter type" $ do + ts <- checkErr $ liftM concat $ mapM mkPar pcs + return (ResParam (Just pcs) (Just ts)) + + _ -> return info + where + gr = MGrammar ((m,mo) : ms) + chIn cat = checkIn (text "Happened in" <+> text cat <+> ppIdent c <+> ppPosition mo c <> colon) + + mkPar (f,co) = do + vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co + return $ map (mkApp (QC m f)) vs + + checkUniq xss = case xss of + x:y:xs + | x == y -> checkError $ text "ambiguous for type" <+> + ppType (mkFunType (tail x) (head x)) + | otherwise -> checkUniq $ y:xs + _ -> return () + + mkCheck cat ss = case ss of + [] -> return info + _ -> checkError (vcat ss $$ text "in" <+> text cat <+> ppIdent c <+> ppPosition mo c) + + compAbsTyp g t = case t of + Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g + Let (x,(_,a)) b -> do + a' <- compAbsTyp g a + compAbsTyp ((x, a'):g) b + Prod b x a t -> do + a' <- compAbsTyp g a + t' <- compAbsTyp ((x,Vr x):g) t + return $ Prod b x a' t' + Abs _ _ _ -> return t + _ -> composOp (compAbsTyp g) t + + +checkPrintname :: SourceGrammar -> Maybe Term -> Check (Maybe Term) +checkPrintname gr (Just t) = do (t,_) <- checkLType gr [] t typeStr + return (Just t) +checkPrintname gr Nothing = return Nothing + +-- | for grammars obtained otherwise than by parsing ---- update!! +checkReservedId :: Ident -> Check () +checkReservedId x + | isReservedWord (ident2bs x) = checkWarn (text "reserved word used as identifier:" <+> ppIdent x) + | otherwise = return () + +-- auxiliaries + +-- | linearization types and defaults +linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type) +linTypeOfType cnc m typ = do + let (cont,cat) = 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 (render (text "extending" $$ + nest 2 (ppTerm Unqualified 0 vars) $$ + text "with" $$ + nest 2 (ppTerm Unqualified 0 val))) $ + plusRecType vars val + return (Explicit,symb,rec) + lookLin (_,c) = checks [ --- rather: update with defLinType ? + checkErr (lookupLincat cnc m c) >>= computeLType cnc [] + ,return defLinType + ] diff --git a/src/compiler/GF/Compile/Coding.hs b/src/compiler/GF/Compile/Coding.hs new file mode 100644 index 000000000..49538bd35 --- /dev/null +++ b/src/compiler/GF/Compile/Coding.hs @@ -0,0 +1,55 @@ +module GF.Compile.Coding where + +import GF.Grammar.Grammar +import GF.Grammar.Macros +import GF.Text.Coding +import GF.Infra.Modules +import GF.Infra.Option +import GF.Data.Operations + +import Data.Char + +encodeStringsInModule :: SourceModule -> SourceModule +encodeStringsInModule = codeSourceModule (encodeUnicode UTF_8) + +decodeStringsInModule :: SourceModule -> SourceModule +decodeStringsInModule mo = codeSourceModule (decodeUnicode (flag optEncoding (flagsModule mo))) mo + +codeSourceModule :: (String -> String) -> SourceModule -> SourceModule +codeSourceModule co (id,mo) = (id,replaceJudgements mo (mapTree codj (jments mo))) + where + codj (c,info) = case info of + ResOper pty pt -> ResOper (fmap (codeTerm co) pty) (fmap (codeTerm co) pt) + ResOverload es tyts -> ResOverload es [(codeTerm co ty,codeTerm co t) | (ty,t) <- tyts] + CncCat pty pt mpr -> CncCat pty (fmap (codeTerm co) pt) (fmap (codeTerm co) mpr) + CncFun mty pt mpr -> CncFun mty (fmap (codeTerm co) pt) (fmap (codeTerm co) mpr) + _ -> info + +codeTerm :: (String -> String) -> Term -> Term +codeTerm co t = case t of + K s -> K (co s) + T ty cs -> T ty [(codp p,codeTerm co v) | (p,v) <- cs] + EPatt p -> EPatt (codp p) + _ -> composSafeOp (codeTerm co) t + where + codp p = case p of --- really: composOpPatt + PR rs -> PR [(l,codp p) | (l,p) <- rs] + PString s -> PString (co s) + PChars s -> PChars (co s) + PT x p -> PT x (codp p) + PAs x p -> PAs x (codp p) + PNeg p -> PNeg (codp p) + PRep p -> PRep (codp p) + PSeq p q -> PSeq (codp p) (codp q) + PAlt p q -> PAlt (codp p) (codp q) + _ -> p + +-- | Run an encoding function on all string literals within the given string. +codeStringLiterals :: (String -> String) -> String -> String +codeStringLiterals _ [] = [] +codeStringLiterals co ('"':cs) = '"' : inStringLiteral cs + where inStringLiteral [] = error "codeStringLiterals: unterminated string literal" + inStringLiteral ('"':ds) = '"' : codeStringLiterals co ds + inStringLiteral ('\\':d:ds) = '\\' : co [d] ++ inStringLiteral ds + inStringLiteral (d:ds) = co [d] ++ inStringLiteral ds +codeStringLiterals co (c:cs) = c : codeStringLiterals co cs diff --git a/src/compiler/GF/Compile/Concrete/AppPredefined.hs b/src/compiler/GF/Compile/Concrete/AppPredefined.hs new file mode 100644 index 000000000..c05127191 --- /dev/null +++ b/src/compiler/GF/Compile/Concrete/AppPredefined.hs @@ -0,0 +1,158 @@ +---------------------------------------------------------------------- +-- | +-- 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.Compile.Concrete.AppPredefined (isInPredefined, typPredefined, appPredefined + ) where + +import GF.Infra.Ident +import GF.Data.Operations +import GF.Grammar.Predef +import GF.Grammar.Grammar +import GF.Grammar.Macros +import GF.Grammar.Printer +import qualified Data.ByteString.Char8 as BS +import Text.PrettyPrint + +-- 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 f + | f == cInt = return typePType + | f == cFloat = return typePType + | f == cErrorType = return typeType + | f == cInts = return $ mkFunType [typeInt] typePType + | f == cPBool = return typePType + | f == cError = return $ mkFunType [typeStr] typeError -- non-can. of empty set + | f == cPFalse = return $ typePBool + | f == cPTrue = return $ typePBool + | f == cDp = return $ mkFunType [typeInt,typeTok] typeTok + | f == cDrop = return $ mkFunType [typeInt,typeTok] typeTok + | f == cEqInt = return $ mkFunType [typeInt,typeInt] typePBool + | f == cLessInt = return $ mkFunType [typeInt,typeInt] typePBool + | f == cEqStr = return $ mkFunType [typeTok,typeTok] typePBool + | f == cLength = return $ mkFunType [typeTok] typeInt + | f == cOccur = return $ mkFunType [typeTok,typeTok] typePBool + | f == cOccurs = return $ mkFunType [typeTok,typeTok] typePBool + | f == cPlus = return $ mkFunType [typeInt,typeInt] (typeInt) +---- "read" -> (P : Type) -> Tok -> P + | f == cShow = return $ mkProd -- (P : PType) -> P -> Tok + [(Explicit,varP,typePType),(Explicit,identW,Vr varP)] typeStr [] + | f == cToStr = return $ mkProd -- (L : Type) -> L -> Str + [(Explicit,varL,typeType),(Explicit,identW,Vr varL)] typeStr [] + | f == cMapStr = return $ mkProd -- (L : Type) -> (Str -> Str) -> L -> L + [(Explicit,varL,typeType),(Explicit,identW,mkFunType [typeStr] typeStr),(Explicit,identW,Vr varL)] (Vr varL) [] + | f == cTake = return $ mkFunType [typeInt,typeTok] typeTok + | f == cTk = return $ mkFunType [typeInt,typeTok] typeTok + | otherwise = Bad (render (text "unknown in Predef:" <+> ppIdent f)) + +varL :: Ident +varL = identC (BS.pack "L") + +varP :: Ident +varP = identC (BS.pack "P") + +appPredefined :: Term -> Err (Term,Bool) +appPredefined t = case t of + App f x0 -> do + (x,_) <- appPredefined x0 + case f of + -- one-place functions + Q mod f | mod == cPredef -> + case x of + (K s) | f == cLength -> retb $ EInt $ toInteger $ length s + _ -> retb t + + -- two-place functions + App (Q mod f) z0 | mod == cPredef -> do + (z,_) <- appPredefined z0 + case (norm z, norm x) of + (EInt i, K s) | f == cDrop -> retb $ K (drop (fi i) s) + (EInt i, K s) | f == cTake -> retb $ K (take (fi i) s) + (EInt i, K s) | f == cTk -> retb $ K (take (max 0 (length s - fi i)) s) + (EInt i, K s) | f == cDp -> retb $ K (drop (max 0 (length s - fi i)) s) + (K s, K t) | f == cEqStr -> retb $ if s == t then predefTrue else predefFalse + (K s, K t) | f == cOccur -> retb $ if substring s t then predefTrue else predefFalse + (K s, K t) | f == cOccurs -> retb $ if any (flip elem t) s then predefTrue else predefFalse + (EInt i, EInt j) | f == cEqInt -> retb $ if i==j then predefTrue else predefFalse + (EInt i, EInt j) | f == cLessInt -> retb $ if i retb $ EInt $ i+j + (_, t) | f == cShow -> retb $ foldr C Empty $ map K $ words $ render (ppTerm Unqualified 0 t) + (_, K s) | f == cRead -> retb $ Cn (identC (BS.pack s)) --- because of K, only works for atomic tags + (_, t) | f == cToStr -> trm2str t >>= retb + _ -> retb t ---- prtBad "cannot compute predefined" t + + -- three-place functions + App (App (Q mod f) z0) y0 | mod == cPredef -> do + (y,_) <- appPredefined y0 + (z,_) <- appPredefined z0 + case (z, y, x) of + (ty,op,t) | f == cMapStr -> 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 (retc t,True) -- no further computing needed + retf t = return (retc t,False) -- must be computed further + retc t = case t of + K [] -> t + K s -> foldr1 C (map K (words s)) + _ -> t + norm t = case t of + Empty -> K [] + C u v -> case (norm u,norm v) of + (K x,K y) -> K (x +++ y) + _ -> t + _ -> t + fi = fromInteger + +-- read makes variables into constants + +predefTrue = QC cPredef cPTrue +predefFalse = QC cPredef cPFalse + +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 + _ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 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/compiler/GF/Compile/Concrete/Compute.hs b/src/compiler/GF/Compile/Concrete/Compute.hs new file mode 100644 index 000000000..9c016116b --- /dev/null +++ b/src/compiler/GF/Compile/Concrete/Compute.hs @@ -0,0 +1,456 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Compile.Concrete.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.Compile.Concrete.Compute (computeConcrete, computeTerm,computeConcreteRec) where + +import GF.Data.Operations +import GF.Grammar.Grammar +import GF.Infra.Ident +import GF.Infra.Option +import GF.Infra.Modules +import GF.Data.Str +import GF.Grammar.Printer +import GF.Grammar.Predef +import GF.Grammar.Macros +import GF.Grammar.Lookup +import GF.Compile.Refresh +import GF.Grammar.PatternMatch +import GF.Grammar.Lockfield (isLockLabel,unlockRecord) ---- + +import GF.Compile.Concrete.AppPredefined + +import Data.List (nub,intersperse) +import Control.Monad (liftM2, liftM) +import Text.PrettyPrint + +-- | 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 p c | p == cPredef -> return t + | otherwise -> look p c + + Vr x -> do + t' <- maybe (Bad (render (text "no value given to variable" <+> ppIdent x))) return $ lookup x g + case t' of + _ | t == t' -> return t + _ -> comp g t' + + -- Abs x@(IA _) b -> do + Abs _ _ _ | 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 b x a t -> do + a' <- comp g a + t' <- comp (ext x (Vr x) g) t + return $ Prod b x a' t' + + -- 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 mod f | mod == cPredef -> 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 (map snd 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 (Bad (render (text "no value for label" <+> ppLabel 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 + + S t v -> do + t' <- compTable g t + v' <- comp g v + t1 <- case t' of +---- V (RecType fs) _ -> uncurrySelect g fs t' v' +---- T (TComp (RecType fs)) _ -> uncurrySelect g fs t' v' + _ -> return $ S t' v' + compSelect g t1 + + -- 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 (d,aa) -> do + d' <- comp g d + aa' <- mapM (compInAlts g) aa + returnC (Alts (d',aa')) + + -- 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' + + ELin c r -> do + r' <- comp g r + unlockRecord c r' + + T _ _ -> compTable g t + V _ _ -> compTable g t + + -- 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' + + (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 + + 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' + _ -> Bad (render (text "pattern expected as value of" $$ nest 2 (ppPatt Unqualified 0 p))) + 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 + + compSelect g (S t' 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 _ [(PW,c)] -> comp g c --- an optimization + T _ [(PT _ PW,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 lookupR v' (zip vs [0 .. length vs - 1]) of + Just i -> comp g $ ts !! i + _ -> return $ S t' v' -- if v' is not canonical + T _ cc -> do + case matchPattern cc v' of + Ok (c,g') -> comp (g' ++ g) c + _ | isCan v' -> Bad (render (text "missing case" <+> ppTerm Unqualified 0 v' <+> text "in" <+> ppTerm Unqualified 0 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' + + --- needed to match records with and without type information + ---- todo: eliminate linear search in a list of records! + lookupR v vs = case v of + R rs -> lookup ([(x,y) | (x,(_,y)) <- rs]) + [([(x,y) | (x,(_,y)) <- rs],v) | (R rs,v) <- vs] + _ -> lookup v vs + + -- case-expand tables + -- if already expanded, don't expand again + compTable g t = case t of + 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' + V ty cs -> do + ty' <- comp g ty + -- if there are no variables, don't even go inside + cs' <- if (null g) then return cs else mapM (comp g) cs + return $ V ty' cs' + + T i cs -> do + pty0 <- getTableType i + ptyp <- comp g pty0 + case allParamValues gr ptyp of + Ok vs0 -> do + let vs = vs0 ---- [Val v ptyp i | (v,i) <- zip vs0 [0..]] + 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 + ps0 <- mapM (compPatternMacro . fst) cs + cs' <- mapM (compBranch g) (zip ps0 (map snd cs)) + +---- cs' <- mapM (compBranch g) cs + return $ T i cs' -- happens with variable types + _ -> comp g t + + 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 + + compInAlts g (v,c) = do + v' <- comp g v + c' <- comp g c + c2 <- case c' of + EPatt p -> liftM Strs $ getPatts p + _ -> return c' + return (v',c2) + where + getPatts p = case p of + PAlt a b -> liftM2 (++) (getPatts a) (getPatts b) + PString s -> return [K s] + PSeq a b -> do + as <- getPatts a + bs <- getPatts b + return [K (s ++ t) | K s <- as, K t <- bs] + _ -> fail (render (text "not valid pattern in pre expression" <+> ppPatt Unqualified 0 p)) + +{- ---- + uncurrySelect g fs t v = do + ts <- mapM (allParamValues gr . snd) fs + vs <- mapM (comp g) [P v r | r <- map fst fs] + return $ reorderSelect t fs ts vs + + reorderSelect t fs pss vs = case (t,fs,pss,vs) of + (V _ ts, f:fs1, ps:pss1, v:vs1) -> + S (V (snd f) + [reorderSelect (V (RecType fs1) t) fs1 pss1 vs1 | + t <- segments (length ts `div` length ps) ts]) v + (T (TComp _) cs, f:fs1, ps:pss1, v:vs1) -> + S (T (TComp (snd f)) + [(p,reorderSelect (T (TComp (RecType fs1)) c) fs1 pss1 vs1) | + (ep,c) <- zip ps (segments (length cs `div` length ps) cs), + let Ok p = term2patt ep]) v + _ -> t + + segments i xs = + let (x0,xs1) = splitAt i xs in x0 : takeWhile (not . null) (segments i xs1) +-} + + +-- | argument variables cannot be glued +checkNoArgVars :: Term -> Err Term +checkNoArgVars t = case t of + Vr (IA _ _) -> Bad $ glueErrorMsg $ ppTerm Unqualified 0 t + Vr (IAV _ _ _) -> Bad $ glueErrorMsg $ ppTerm Unqualified 0 t + _ -> composOp checkNoArgVars t + +glueErrorMsg s = + render (text "Cannot glue (+) term with run-time variable" <+> s <> char '.' $$ + text "Use Prelude.bind instead.") + +getArgType t = case t of + V ty _ -> return ty + T (TComp ty) _ -> return ty + _ -> Bad (render (text "cannot get argument type of table" $$ nest 2 (ppTerm Unqualified 0 t))) diff --git a/src/compiler/GF/Compile/Concrete/TypeCheck.hs b/src/compiler/GF/Compile/Concrete/TypeCheck.hs new file mode 100644 index 000000000..670f36625 --- /dev/null +++ b/src/compiler/GF/Compile/Concrete/TypeCheck.hs @@ -0,0 +1,690 @@ +{-# LANGUAGE PatternGuards #-} +module GF.Compile.Concrete.TypeCheck( checkLType, inferLType, computeLType, ppType ) where + +import GF.Infra.CheckM +import GF.Infra.Modules +import GF.Data.Operations + +import GF.Grammar +import GF.Grammar.Lookup +import GF.Grammar.Predef +import GF.Grammar.PatternMatch +import GF.Grammar.Lockfield (isLockLabel, lockRecType, unlockRecord) +import GF.Compile.Concrete.AppPredefined + +import Data.List +import Control.Monad +import Text.PrettyPrint + +computeLType :: SourceGrammar -> Context -> Type -> Check Type +computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t + where + comp g ty = case ty of + _ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed + | isPredefConstant ty -> return ty ---- shouldn't be needed + + Q m ident -> checkIn (text "module" <+> ppIdent m) $ do + ty' <- checkErr (lookupResDef gr m ident) + if ty' == ty then return ty else comp g ty' --- is this necessary to test? + + Vr ident -> checkLookup ident g -- never needed to compute! + + App f a -> do + f' <- comp g f + a' <- comp g a + case f' of + Abs b x t -> comp ((b,x,a'):g) t + _ -> return $ App f' a' + + Prod bt x a b -> do + a' <- comp g a + b' <- comp ((bt,x,Vr x) : g) b + return $ Prod bt x a' b' + + Abs bt x b -> do + b' <- comp ((bt,x,Vr x):g) b + return $ Abs bt x b' + + ExtR r s -> do + r' <- comp g r + s' <- comp g s + case (r',s') of + (RecType rs, RecType ss) -> checkErr (plusRecType r' s') >>= comp g + _ -> return $ ExtR r' s' + + RecType fs -> do + let fs' = sortRec fs + liftM RecType $ mapPairsM (comp g) fs' + + ELincat c t -> do + t' <- comp g t + checkErr $ lockRecType c t' ---- locking to be removed AR 20/6/2009 + + _ | ty == typeTok -> return typeStr + _ | isPredefConstant ty -> return ty + + _ -> composOp (comp g) ty + +-- the underlying algorithms + +inferLType :: SourceGrammar -> Context -> Term -> Check (Term, Type) +inferLType gr g 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) >>= computeLType gr g + , + checkErr (lookupResDef gr m ident) >>= inferLType gr g + , + checkError (text "cannot infer type of constant" <+> ppTerm Unqualified 0 trm) + ] + + QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident) + + QC m ident -> checks [ + termWith trm $ checkErr (lookupResType gr m ident) >>= computeLType gr g + , + checkErr (lookupResDef gr m ident) >>= inferLType gr g + , + checkError (text "cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm) + ] + + Vr ident -> termWith trm $ checkLookup ident g + + Typed e t -> do + t' <- computeLType gr g t + checkLType gr g e t' + return (e,t') + + App f a -> do + over <- getOverload gr g Nothing trm + case over of + Just trty -> return trty + _ -> do + (f',fty) <- inferLType gr g f + fty' <- computeLType gr g fty + case fty' of + Prod bt z arg val -> do + a' <- justCheck g a arg + ty <- if isWildIdent z + then return val + else substituteLType [(bt,z,a')] val + return (App f' a',ty) + _ -> checkError (text "A function type is expected for" <+> ppTerm Unqualified 0 f <+> text "instead of type" <+> ppType fty) + + S f x -> do + (f', fty) <- inferLType gr g f + case fty of + Table arg val -> do + x'<- justCheck g x arg + return (S f' x', val) + _ -> checkError (text "table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm)) + + P t i -> do + (t',ty) <- inferLType gr g t --- ?? + ty' <- computeLType gr g ty + let tr2 = P t' i + termWith tr2 $ case ty' of + RecType ts -> case lookup i ts of + Nothing -> checkError (text "unknown label" <+> ppLabel i <+> text "in" $$ nest 2 (ppTerm Unqualified 0 ty')) + Just x -> return x + _ -> checkError (text "record type expected for:" <+> ppTerm Unqualified 0 t $$ + text " instead of the inferred:" <+> ppTerm Unqualified 0 ty') + + R r -> do + let (ls,fs) = unzip r + fsts <- mapM inferM fs + let ts = [ty | (Just ty,_) <- fsts] + checkCond (text "cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 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 + checkLType gr g trm (Table arg val) + T (TComp arg) pts -> do + (_,val) <- checks $ map (inferCase (Just arg)) pts + checkLType gr g 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 + [] -> checkError (text "cannot infer table type of" <+> ppTerm Unqualified 0 trm) +---- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] + _ -> do + (arg,val) <- checks $ map (inferCase Nothing) pts' + checkLType gr g trm (Table arg val) + V arg pts -> do + (_,val) <- checks $ map (inferLType gr g) pts + return (trm, Table arg val) + + K s -> do + if elem ' ' s + then do + let ss = foldr C Empty (map K (words s)) + ----- removed irritating warning AR 24/5/2008 + ----- checkWarn ("token \"" ++ s ++ + ----- "\" converted to token list" ++ prt ss) + return (ss, typeStr) + else return (trm, typeStr) + + EInt i -> return (trm, typeInt) + + EFloat i -> return (trm, typeFloat) + + Empty -> return (trm, typeStr) + + C s1 s2 -> + check2 (flip (justCheck g) typeStr) C s1 s2 typeStr + + Glue s1 s2 -> + check2 (flip (justCheck g) typeStr) Glue s1 s2 typeStr ---- typeTok + +---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007 + Strs (Cn c : ts) | c == cConflict -> do + checkWarn (text "unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts)) + inferLType gr g (head ts) + + Strs ts -> do + ts' <- mapM (\t -> justCheck g t typeStr) ts + return (Strs ts', typeStrs) + + Alts (t,aa) -> do + t' <- justCheck g t typeStr + aa' <- flip mapM aa (\ (c,v) -> do + c' <- justCheck g c typeStr + v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr] + return (c',v')) + return (Alts (t',aa'), typeStr) + + RecType r -> do + let (ls,ts) = unzip r + ts' <- mapM (flip (justCheck g) typeType) ts + return (RecType (zip ls ts'), typeType) + + ExtR r s -> do + (r',rT) <- inferLType gr g r + rT' <- computeLType gr g rT + (s',sT) <- inferLType gr g s + sT' <- computeLType gr g 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' + checkLType gr g trm' rt ---- return (trm', rt) + _ | rT' == typeType && sT' == typeType -> return (trm', typeType) + _ -> checkError (text "records or record types expected in" <+> ppTerm Unqualified 0 trm) + + Sort _ -> + termWith trm $ return typeType + + Prod bt x a b -> do + a' <- justCheck g a typeType + b' <- justCheck ((bt,x,a'):g) b typeType + return (Prod bt x a' b', typeType) + + Table p t -> do + p' <- justCheck g p typeType --- check p partype! + t' <- justCheck g t typeType + return $ (Table p' t', typeType) + + FV vs -> do + (_,ty) <- checks $ map (inferLType gr g) vs +--- checkIfComplexVariantType trm ty + checkLType gr g trm ty + + EPattType ty -> do + ty' <- justCheck g ty typeType + return (EPattType ty',typeType) + EPatt p -> do + ty <- inferPatt p + return (trm, EPattType ty) + + ELin c trm -> do + (trm',ty) <- inferLType gr g trm + ty' <- checkErr $ lockRecType c ty ---- lookup c; remove lock AR 20/6/2009 + return $ (ELin c trm', ty') + + _ -> checkError (text "cannot infer lintype of" <+> ppTerm Unqualified 0 trm) + + where + isPredef m = elem m [cPredef,cPredefAbs] + + justCheck g ty te = checkLType gr g ty te >>= return . fst + + -- for record fields, which may be typed + inferM (mty, t) = do + (t', ty') <- case mty of + Just ty -> checkLType gr g ty t + _ -> inferLType gr g t + return (Just ty',t') + + inferCase mty (patt,term) = do + arg <- maybe (inferPatt patt) return mty + cont <- pattContext gr g arg patt + (_,val) <- inferLType gr (reverse cont ++ g) term + 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 $ liftM valTypeCnc (lookupResType gr q c) + 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 + _ -> inferLType gr g (patt2term p) >>= return . snd + + +-- type inference: Nothing, type checking: Just t +-- the latter permits matching with value type +getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type)) +getOverload gr g mt ot = case appForm ot of + (f@(Q m c), ts) -> case lookupOverload gr m c of + Ok typs -> do + ttys <- mapM (inferLType gr g) ts + v <- matchOverload f typs ttys + return $ Just v + _ -> return Nothing + _ -> return Nothing + where + matchOverload f typs ttys = do + let (tts,tys) = unzip ttys + let vfs = lookupOverloadInstance tys typs + let matches = [vf | vf@((v,_),_) <- vfs, matchVal mt v] + + case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of + ([(val,fun)],_) -> return (mkApp fun tts, val) + ([],[(val,fun)]) -> do + checkWarn (text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot) + return (mkApp fun tts, val) + ([],[]) -> do + let showTypes ty = hsep (map ppType ty) + checkError $ text "no overload instance of" <+> ppTerm Unqualified 0 f $$ + text "for" $$ + nest 2 (showTypes tys) $$ + text "among" $$ + nest 2 (vcat [showTypes ty | (ty,_) <- typs]) $$ + maybe empty (\x -> text "with value type" <+> ppType x) mt + + (vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of + ([(val,fun)],_) -> do + return (mkApp fun tts, val) + ([],[(val,fun)]) -> do + checkWarn (text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot) + return (mkApp fun tts, val) + +----- unsafely exclude irritating warning AR 24/5/2008 +----- checkWarn $ "overloading of" +++ prt f +++ +----- "resolved by excluding partial applications:" ++++ +----- unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)] + + + _ -> checkError $ text "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+> + text "for" <+> hsep (map ppType tys) $$ + text "with alternatives" $$ + nest 2 (vcat [ppType ty | (ty,_) <- if null vfs1 then vfs2 else vfs2]) + + matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)] + + unlocked v = case v of + RecType fs -> RecType $ filter (not . isLockLabel . fst) fs + _ -> v + ---- TODO: accept subtypes + ---- TODO: use a trie + lookupOverloadInstance tys typs = + [((mkFunType rest val, t),isExact) | + let lt = length tys, + (ty,(val,t)) <- typs, length ty >= lt, + let (pre,rest) = splitAt lt ty, + let isExact = pre == tys, + isExact || map unlocked pre == map unlocked tys + ] + + noProds vfs = [(v,f) | (v,f) <- vfs, noProd v] + + noProd ty = case ty of + Prod _ _ _ _ -> False + _ -> True + +checkLType :: SourceGrammar -> Context -> Term -> Type -> Check (Term, Type) +checkLType gr g trm typ0 = do + + typ <- computeLType gr g typ0 + + case trm of + + Abs bt x c -> do + case typ of + Prod bt' z a b -> do + (c',b') <- if isWildIdent z + then checkLType gr ((bt,x,a):g) c b + else do b' <- checkIn (text "abs") $ substituteLType [(bt',z,Vr x)] b + checkLType gr ((bt,x,a):g) c b' + return $ (Abs bt x c', Prod bt' x a b') + _ -> checkError $ text "function type expected instead of" <+> ppType typ + + App f a -> do + over <- getOverload gr g (Just typ) trm + case over of + Just trty -> return trty + _ -> do + (trm',ty') <- inferLType gr g trm + termWith trm' $ checkEqLType gr g typ ty' trm' + + Q _ _ -> do + over <- getOverload gr g (Just typ) trm + case over of + Just trty -> return trty + _ -> do + (trm',ty') <- inferLType gr g trm + termWith trm' $ checkEqLType gr g typ ty' trm' + + T _ [] -> + checkError (text "found empty table in type" <+> ppTerm Unqualified 0 typ) + T _ cs -> case typ of + Table arg val -> do + case allParamValues gr arg of + Ok vs -> do + let ps0 = map fst cs + ps <- checkErr $ testOvershadow ps0 vs + if null ps + then return () + else checkWarn (text "patterns never reached:" $$ + nest 2 (vcat (map (ppPatt Unqualified 0) ps))) + _ -> return () -- happens with variable types + cs' <- mapM (checkCase arg val) cs + return (T (TTyped arg) cs', typ) + _ -> checkError $ text "table type expected for table instead of" $$ nest 2 (ppType 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 + + _ -> checkError (text "record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ)) + + ExtR r s -> case typ of + _ | typ == typeType -> do + trm' <- computeLType gr g trm + case trm' of + RecType _ -> termWith trm $ return typeType + ExtR (Vr _) (RecType _) -> termWith trm $ return typeType + -- ext t = t ** ... + _ -> checkError (text "invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm)) + RecType rr -> do + (r',ty,s') <- checks [ + do (r',ty) <- inferLType gr g r + return (r',ty,s) + , + do (s',ty) <- inferLType gr g s + return (s',ty,r) + ] + case ty of + RecType rr1 -> do + let (rr0,rr2) = recParts rr rr1 + r2 <- justCheck g r' rr0 + s2 <- justCheck g s' rr2 + return $ (ExtR r2 s2, typ) + _ -> checkError (text "record type expected in extension of" <+> ppTerm Unqualified 0 r $$ + text "but found" <+> ppTerm Unqualified 0 ty) + + ExtR ty ex -> do + r' <- justCheck g r ty + s' <- justCheck g s ex + return $ (ExtR r' s', typ) --- is this all? + + _ -> checkError (text "record extension not meaningful for" <+> ppTerm Unqualified 0 typ) + + FV vs -> do + ttys <- mapM (flip (checkLType gr g) typ) vs +--- checkIfComplexVariantType trm typ + return (FV (map fst ttys), typ) --- typ' ? + + S tab arg -> checks [ do + (tab',ty) <- inferLType gr g tab + ty' <- computeLType gr g ty + case ty' of + Table p t -> do + (arg',val) <- checkLType gr g arg p + checkEqLType gr g typ t trm + return (S tab' arg', t) + _ -> checkError (text "table type expected for applied table instead of" <+> ppType ty') + , do + (arg',ty) <- inferLType gr g arg + ty' <- computeLType gr g ty + (tab',_) <- checkLType gr g tab (Table ty' typ) + return (S tab' arg', typ) + ] + Let (x,(mty,def)) body -> case mty of + Just ty -> do + (def',ty') <- checkLType gr g def ty + body' <- justCheck ((Explicit,x,ty'):g) body typ + return (Let (x,(Just ty',def')) body', typ) + _ -> do + (def',ty) <- inferLType gr g def -- tries to infer type of local constant + checkLType gr g (Let (x,(Just ty,def')) body) typ + + ELin c tr -> do + tr1 <- checkErr $ unlockRecord c tr + checkLType gr g tr1 typ + + _ -> do + (trm',ty') <- inferLType gr g trm + termWith trm' $ checkEqLType gr g typ ty' trm' + where + justCheck g ty te = checkLType gr g ty te >>= return . fst + + 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 + checkEqLType gr g ty ty0 t + (t',ty') <- checkLType gr g t ty + return (l,(Just ty',t')) + Just (_,t) -> do + (t',ty') <- checkLType gr g t ty + return (l,(Just ty',t')) + _ -> checkError $ + if isLockLabel l + then let cat = drop 5 (showIdent (label2ident l)) + in ppTerm Unqualified 0 (R rms) <+> text "is not in the lincat of" <+> text cat <> + text "; try wrapping it with lin" <+> text cat + else text "cannot find value for label" <+> ppLabel l <+> text "in" <+> ppTerm Unqualified 0 (R rms) + + checkCase arg val (p,t) = do + cont <- pattContext gr g arg p + t' <- justCheck (reverse cont ++ g) t val + return (p,t') + +pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context +pattContext env g typ p = case p of + PV x -> return [(Explicit,x,typ)] + PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006 + t <- checkErr $ lookupResType env q c + let (cont,v) = typeFormCnc t + checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p) + (length cont == length ps) + checkEqLType env g typ v (patt2term p) + mapM (\((_,_,ty),p) -> pattContext env g ty p) (zip cont ps) >>= return . concat + PR r -> do + typ' <- computeLType env g 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 g)) pts >>= return . concat + _ -> checkError (text "record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ') + PT t p' -> do + checkEqLType env g typ t (patt2term p') + pattContext env g typ p' + + PAs x p -> do + g' <- pattContext env g typ p + return ((Explicit,x,typ):g') + + PAlt p' q -> do + g1 <- pattContext env g typ p' + g2 <- pattContext env g typ q + let pts = nub ([x | pt@(_,x,_) <- g1, notElem pt g2] ++ [x | pt@(_,x,_) <- g2, notElem pt g1]) + checkCond + (text "incompatible bindings of" <+> + fsep (map ppIdent pts) <+> + text "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts) + return g1 -- must be g1 == g2 + PSeq p q -> do + g1 <- pattContext env g typ p + g2 <- pattContext env g typ q + return $ g1 ++ g2 + PRep p' -> noBind typeStr p' + PNeg p' -> noBind typ p' + + _ -> return [] ---- check types! + where + noBind typ p' = do + co <- pattContext env g typ p' + if not (null co) + then checkWarn (text "no variable bound inside pattern" <+> ppPatt Unqualified 0 p) + >> return [] + else return [] + +checkEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check Type +checkEqLType gr g t u trm = do + (b,t',u',s) <- checkIfEqLType gr g t u trm + case b of + True -> return t' + False -> checkError $ text s <+> text "type of" <+> ppTerm Unqualified 0 trm $$ + text "expected:" <+> ppType t $$ + text "inferred:" <+> ppType u + +checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String) +checkIfEqLType gr g t u trm = do + t' <- computeLType gr g t + u' <- computeLType gr g 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 $ text "missing lock field" <+> fsep (map ppLabel 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 + (_,u) | u == typeError -> 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 + (t,u) | Just m <- isTypeInts t, Just n <- isTypeInts t -> m >= n + | Just _ <- isTypeInts t, u == typeInt -> True ---- check size! + | t == typeInt, Just _ <- isTypeInts u -> True ---- why this ???? AR 11/12/2005 + + ---- this should be made in Rename + (Q m a, Q n b) | a == b -> elem m (allExtendsPlus gr n) + || elem n (allExtendsPlus gr m) + || m == n --- for Predef + (QC m a, QC n b) | a == b -> elem m (allExtendsPlus gr n) + || elem n (allExtendsPlus gr m) + (QC m a, Q n b) | a == b -> elem m (allExtendsPlus gr n) + || elem n (allExtendsPlus gr m) + (Q m a, QC n b) | a == b -> elem m (allExtendsPlus gr n) + || elem n (allExtendsPlus gr 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 $ render (text "missing record fields:" <+> fsep (punctuate comma (map ppLabel 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] + +-- auxiliaries + +-- | 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 [(x,t) | (_,x,t) <- g] + _ -> composOp (substituteLType g) t + +termWith :: Term -> Check Type -> Check (Term, Type) +termWith t ct = do + ty <- ct + return (t,ty) + +-- | 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) + +-- printing a type with a lock field lock_C as C +ppType :: Type -> Doc +ppType ty = + case ty of + RecType fs -> case filter isLockLabel $ map fst fs of + [lock] -> text (drop 5 (showIdent (label2ident lock))) + _ -> ppTerm Unqualified 0 ty + Prod _ x a b -> ppType a <+> text "->" <+> ppType b + _ -> ppTerm Unqualified 0 ty + +checkLookup :: Ident -> Context -> Check Type +checkLookup x g = + case [ty | (b,y,ty) <- g, x == y] of + [] -> checkError (text "unknown variable" <+> ppIdent x) + (ty:_) -> return ty diff --git a/src/compiler/GF/Compile/Export.hs b/src/compiler/GF/Compile/Export.hs new file mode 100644 index 000000000..d03eb947e --- /dev/null +++ b/src/compiler/GF/Compile/Export.hs @@ -0,0 +1,64 @@ +module GF.Compile.Export where + +import PGF.CId +import PGF.Data (PGF(..)) +import GF.Compile.GFCCtoHaskell +import GF.Compile.GFCCtoProlog +import GF.Compile.GFCCtoJS +import GF.Compile.PGFPretty +import GF.Infra.Option +import GF.Speech.CFG +import GF.Speech.PGFToCFG +import GF.Speech.SRGS_ABNF +import GF.Speech.SRGS_XML +import GF.Speech.JSGF +import GF.Speech.GSL +import GF.Speech.SRG +import GF.Speech.VoiceXML +import GF.Speech.SLF +import GF.Speech.PrRegExp + +import Data.Maybe +import System.FilePath + +-- top-level access to code generation + +exportPGF :: Options + -> OutputFormat + -> PGF + -> [(FilePath,String)] -- ^ List of recommended file names and contents. +exportPGF opts fmt pgf = + case fmt of + FmtPGFPretty -> multi "txt" prPGFPretty + FmtPMCFGPretty -> single "pmcfg" prPMCFGPretty + FmtJavaScript -> multi "js" pgf2js + FmtHaskell -> multi "hs" (grammar2haskell opts name) + FmtProlog -> multi "pl" grammar2prolog + FmtProlog_Abs -> multi "pl" grammar2prolog_abs + FmtBNF -> single "bnf" bnfPrinter + FmtEBNF -> single "ebnf" (ebnfPrinter opts) + FmtSRGS_XML -> single "grxml" (srgsXmlPrinter opts) + FmtSRGS_XML_NonRec -> single "grxml" (srgsXmlNonRecursivePrinter opts) + FmtSRGS_ABNF -> single "gram" (srgsAbnfPrinter opts) + FmtSRGS_ABNF_NonRec -> single "gram" (srgsAbnfNonRecursivePrinter opts) + FmtJSGF -> single "jsgf" (jsgfPrinter opts) + FmtGSL -> single "gsl" (gslPrinter opts) + FmtVoiceXML -> single "vxml" grammar2vxml + FmtSLF -> single "slf" slfPrinter + FmtRegExp -> single "rexp" regexpPrinter + FmtFA -> single "dot" slfGraphvizPrinter + where + name = fromMaybe (showCId (absname pgf)) (flag optName opts) + + multi :: String -> (PGF -> String) -> [(FilePath,String)] + multi ext pr = [(name <.> ext, pr pgf)] + + single :: String -> (PGF -> CId -> String) -> [(FilePath,String)] + single ext pr = [(showCId cnc <.> ext, pr pgf cnc) | cnc <- cncnames pgf] + +-- | Get the name of the concrete syntax to generate output from. +-- FIXME: there should be an option to change this. +outputConcr :: PGF -> CId +outputConcr pgf = case cncnames pgf of + [] -> error "No concrete syntax." + cnc:_ -> cnc diff --git a/src/compiler/GF/Compile/GFCCtoHaskell.hs b/src/compiler/GF/Compile/GFCCtoHaskell.hs new file mode 100644 index 000000000..d44d6705c --- /dev/null +++ b/src/compiler/GF/Compile/GFCCtoHaskell.hs @@ -0,0 +1,230 @@ +---------------------------------------------------------------------- +-- | +-- 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.Compile.GFCCtoHaskell (grammar2haskell) where + +import PGF.CId +import PGF.Data +import PGF.Macros + +import GF.Data.Operations +import GF.Infra.Option +import GF.Text.UTF8 + +import Data.List --(isPrefixOf, find, intersperse) +import qualified Data.Map as Map + +type Prefix = String -> String + +-- | the main function +grammar2haskell :: Options + -> String -- ^ Module name. + -> PGF + -> String +grammar2haskell opts name gr = encodeUTF8 $ foldr (++++) [] $ + pragmas ++ haskPreamble name ++ [types, gfinstances gId lexical gr'] + where gr' = hSkeleton gr + gadt = haskellOption opts HaskellGADT + lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat + gId | haskellOption opts HaskellNoPrefix = id + | otherwise = ("G"++) + pragmas | gadt = ["{-# OPTIONS_GHC -fglasgow-exts #-}"] + | otherwise = [] + types | gadt = datatypesGADT gId lexical gr' + | otherwise = datatypes gId lexical gr' + +haskPreamble name = + [ + "module " ++ name ++ " where", + "", + "import PGF", + "----------------------------------------------------", + "-- automatic translation from GF to Haskell", + "----------------------------------------------------", + "", + "class Gf a where", + " gf :: a -> Tree", + " fg :: Tree -> a", + "", + predefInst "GString" "String" "unStr" "mkStr", + "", + predefInst "GInt" "Integer" "unInt" "mkInt", + "", + predefInst "GFloat" "Double" "unDouble" "mkDouble", + "", + "----------------------------------------------------", + "-- below this line machine-generated", + "----------------------------------------------------", + "" + ] + +predefInst gtyp typ destr consr = + "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++ + "instance Gf" +++ gtyp +++ "where" ++++ + " gf (" ++ gtyp +++ "x) =" +++ consr +++ "x" ++++ + " fg t =" ++++ + " case "++destr++" t of" ++++ + " Just x -> " +++ gtyp +++ "x" ++++ + " Nothing -> error (\"no" +++ gtyp +++ "\" ++ show t)" + +type OIdent = String + +type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] + +datatypes :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String +datatypes gId lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId lexical)) . snd + +gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String +gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g + + +hDatatype :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String +hDatatype _ _ ("Cn",_) = "" --- +hDatatype _ _ (cat,[]) = "" +hDatatype gId _ (cat,rules) | isListCat (cat,rules) = + "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" + +++ "deriving Show" +hDatatype gId lexical (cat,rules) = + "data" +++ gId cat +++ "=" ++ + (if length rules == 1 then "" else "\n ") +++ + foldr1 (\x y -> x ++ "\n |" +++ y) constructors ++++ + " deriving Show" + where + constructors = [gId f +++ foldr (+++) "" (map (gId) xx) | (f,xx) <- nonLexicalRules (lexical cat) rules] + ++ if lexical cat then [lexicalConstructor cat +++ "String"] else [] + +nonLexicalRules :: Bool -> [(OIdent, [OIdent])] -> [(OIdent, [OIdent])] +nonLexicalRules False rules = rules +nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)] + +lexicalConstructor :: OIdent -> String +lexicalConstructor cat = "Lex" ++ cat + +-- GADT version of data types +datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String +datatypesGADT gId lexical (_,skel) = + unlines (concatMap (hCatTypeGADT gId) skel) + +++++ + "data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT gId lexical) skel) + +hCatTypeGADT :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String] +hCatTypeGADT gId (cat,rules) + = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_", + "data"+++gId cat++"_"] + +hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String] +hDatatypeGADT gId lexical (cat, rules) + | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t] + | otherwise = + [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t + | (f,args) <- nonLexicalRules (lexical cat) rules ] + ++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else [] + where t = "Tree" +++ gId cat ++ "_" + +gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String +gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs + +----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004 +hInstance _ _ m (cat,[]) = "" +hInstance gId lexical 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) <- nonLexicalRules (lexical cat) rules] + ++ if lexical cat then [" gf (" ++ lexicalConstructor cat +++ "x) = mkApp (mkCId x) []"] else []) + 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 = "mkApp (mkCId \"" ++ f ++ "\")" +++ + "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" + + +----fInstance m ("Cn",_) = "" --- +fInstance _ _ m (cat,[]) = "" +fInstance gId lexical m (cat,rules) = + " fg t =" ++++ + " case unApp t of" ++++ + unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++ + (if lexical cat then " (i,[]) -> " ++ lexicalConstructor cat +++ "(prCId i)" else "") ++++ + " _ -> error (\"no" +++ cat ++ " \" ++ show t)" + where + mkInst f xx = + " Just (i," ++ + "[" ++ prTList "," xx' ++ "])" +++ + "| i == mkCId \"" ++ f ++ "\" ->" +++ 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 :: PGF -> (String,HSkeleton) +hSkeleton gr = + (showCId (absname gr), + [(showCId c, [(showCId f, map showCId 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 + 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/compiler/GF/Compile/GFCCtoJS.hs b/src/compiler/GF/Compile/GFCCtoJS.hs new file mode 100644 index 000000000..312701e3b --- /dev/null +++ b/src/compiler/GF/Compile/GFCCtoJS.hs @@ -0,0 +1,138 @@ +module GF.Compile.GFCCtoJS (pgf2js) where + +import PGF.CId +import PGF.Data hiding (mkStr) +import qualified PGF.Macros as M +import qualified GF.JavaScript.AbsJS as JS +import qualified GF.JavaScript.PrintJS as JS + +import GF.Text.UTF8 +import GF.Data.ErrM +import GF.Infra.Option + +import Control.Monad (mplus) +import Data.Array.Unboxed (UArray) +import qualified Data.Array.IArray as Array +import Data.Maybe (fromMaybe) +import Data.Map (Map) +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap + +pgf2js :: PGF -> String +pgf2js pgf = + encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]] + where + n = showCId $ absname pgf + as = abstract pgf + cs = Map.assocs (concretes pgf) + start = showCId $ M.lookStartCat pgf + grammar = new "GFGrammar" [js_abstract, js_concrete] + js_abstract = abstract2js start as + js_concrete = JS.EObj $ map (concrete2js start n) cs + +abstract2js :: String -> Abstr -> JS.Expr +abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))] + +absdef2js :: (CId,(Type,Int,[Equation])) -> JS.Property +absdef2js (f,(typ,_,_)) = + let (args,cat) = M.catSkeleton typ in + JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)]) + +concrete2js :: String -> String -> (CId,Concr) -> JS.Property +concrete2js start n (c, cnc) = + JS.Prop l (new "GFConcrete" ([flags,(JS.EObj $ ((map (cncdef2js n (showCId c)) ds) ++ litslins))] ++ + maybe [] (parser2js start) (parser cnc))) + where + flags = mapToJSObj JS.EStr $ cflags cnc + l = JS.IdentPropName (JS.Ident (showCId c)) + ds = concatMap Map.assocs [lins cnc, opers cnc, 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,Term) -> JS.Property +cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)]) + +term2js :: String -> String -> Term -> JS.Expr +term2js n l t = f t + where + f t = + case t of + R xs -> new "Arr" (map f xs) + P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y] + S xs -> mkSeq (map f xs) + K t -> tokn2js t + V i -> JS.EIndex (JS.EVar children) (JS.EInt i) + C i -> new "Int" [JS.EInt i] + F 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 (showCId f), JS.EVar children] + FV xs -> new "Variants" (map f xs) + W str x -> new "Suffix" [JS.EStr str, f x] + TM _ -> new "Meta" [] + +tokn2js :: Tokn -> JS.Expr +tokn2js (KS s) = mkStr s +tokn2js (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 -> ParserInfo -> [JS.Expr] +parser2js start p = [new "Parser" [JS.EStr start, + JS.EArray $ [frule2js p cat prod | (cat,set) <- IntMap.toList (productions p), prod <- Set.toList set], + JS.EObj $ map cats (Map.assocs (startCats p))]] + where + cats (c,is) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EArray (map JS.EInt is)) + +frule2js :: ParserInfo -> FCat -> Production -> JS.Expr +frule2js p res (FApply funid args) = new "Rule" [JS.EInt res, name2js (f,ps), JS.EArray (map JS.EInt args), lins2js p lins] + where + FFun f ps lins = functions p Array.! funid +frule2js p res (FCoerce arg) = new "Rule" [JS.EInt res, daughter 0, JS.EArray [JS.EInt arg], JS.EArray [JS.EArray [sym2js (FSymCat 0 i)] | i <- [0..catLinArity arg-1]]] + where + catLinArity :: FCat -> Int + catLinArity c = maximum (1:[Array.rangeSize (Array.bounds rhs) | (FFun _ _ rhs, _) <- topdownRules c]) + + topdownRules cat = f cat [] + where + f cat rules = maybe rules (Set.fold g rules) (IntMap.lookup cat (productions p)) + + g (FApply funid args) rules = (functions p Array.! funid,args) : rules + g (FCoerce cat) rules = f cat rules + + +name2js :: (CId,[Profile]) -> JS.Expr +name2js (f,ps) = new "FunApp" $ [JS.EStr $ showCId f, JS.EArray (map fromProfile ps)] + where + fromProfile :: Profile -> JS.Expr + fromProfile [] = new "MetaVar" [] + fromProfile [x] = daughter x + fromProfile args = new "Unify" [JS.EArray (map daughter args)] + +daughter i = new "Arg" [JS.EInt i] + +lins2js :: ParserInfo -> UArray FIndex SeqId -> JS.Expr +lins2js p ls = JS.EArray [JS.EArray [sym2js s | s <- Array.elems (sequences p Array.! seqid)] | seqid <- Array.elems ls] + +sym2js :: FSymbol -> JS.Expr +sym2js (FSymCat n l) = new "ArgProj" [JS.EInt n, JS.EInt l] +sym2js (FSymLit n l) = new "ArgProj" [JS.EInt n, JS.EInt l] +sym2js (FSymKS [t]) = new "Terminal" [JS.EStr t] + +new :: String -> [JS.Expr] -> JS.Expr +new f xs = JS.ENew (JS.Ident f) xs + +mapToJSObj :: (a -> JS.Expr) -> Map CId a -> JS.Expr +mapToJSObj f m = JS.EObj [ JS.Prop (JS.IdentPropName (JS.Ident (showCId k))) (f v) | (k,v) <- Map.toList m ] diff --git a/src/compiler/GF/Compile/GFCCtoProlog.hs b/src/compiler/GF/Compile/GFCCtoProlog.hs new file mode 100644 index 000000000..702d4afe5 --- /dev/null +++ b/src/compiler/GF/Compile/GFCCtoProlog.hs @@ -0,0 +1,279 @@ +---------------------------------------------------------------------- +-- | +-- Module : GFCCtoProlog +-- Maintainer : Peter Ljunglöf +-- Stability : (stable) +-- Portability : (portable) +-- +-- to write a GF grammar into a Prolog module +----------------------------------------------------------------------------- + +module GF.Compile.GFCCtoProlog (grammar2prolog, grammar2prolog_abs) where + +import PGF.CId +import PGF.Data +import PGF.Macros + +import GF.Data.Operations +import GF.Text.UTF8 + +import qualified Data.Map as Map +import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper, ord) +import Data.List (isPrefixOf,mapAccumL) + +grammar2prolog, grammar2prolog_abs :: PGF -> String +-- Most prologs have problems with UTF8 encodings, so we skip that: +grammar2prolog = {- encodeUTF8 . -} foldr (++++) [] . pgf2clauses +grammar2prolog_abs = {- encodeUTF8 . -} foldr (++++) [] . pgf2clauses_abs + + +pgf2clauses :: PGF -> [String] +pgf2clauses (PGF absname cncnames gflags abstract concretes) = + [":- " ++ plFact "module" [plp absname, "[]"]] ++ + clauseHeader "%% concrete(?Module)" + [plFact "concrete" [plp cncname] | cncname <- cncnames] ++ + clauseHeader "%% flag(?Flag, ?Value): global flags" + (map (plpFact2 "flag") (Map.assocs gflags)) ++ + plAbstract (absname, abstract) ++ + concatMap plConcrete (Map.assocs concretes) + +pgf2clauses_abs :: PGF -> [String] +pgf2clauses_abs (PGF absname _cncnames gflags abstract _concretes) = + [":- " ++ plFact "module" [plp absname, "[]"]] ++ + clauseHeader "%% flag(?Flag, ?Value): global flags" + (map (plpFact2 "flag") (Map.assocs gflags)) ++ + plAbstract (absname, abstract) + +clauseHeader :: String -> [String] -> [String] +clauseHeader hdr [] = [] +clauseHeader hdr clauses = "":hdr:clauses + + +---------------------------------------------------------------------- +-- abstract syntax + +plAbstract :: (CId, Abstr) -> [String] +plAbstract (name, Abstr aflags funs cats _catfuns) = + ["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%", + "%% abstract module: " ++ plp name] ++ + clauseHeader "%% absflag(?Flag, ?Value): flags for abstract syntax" + (map (plpFact2 "absflag") (Map.assocs aflags)) ++ + clauseHeader "%% cat(?Type, ?[X:Type,...])" + (map plCat (Map.assocs cats)) ++ + clauseHeader "%% fun(?Fun, ?Type, ?[X:Type,...])" + (map plFun (Map.assocs funs)) ++ + clauseHeader "%% def(?Fun, ?Expr)" + (concatMap plFundef (Map.assocs funs)) + +plCat :: (CId, [Hypo]) -> String +plCat (cat, hypos) = plFact "cat" (plTypeWithHypos typ) + where ((_,subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos + args = reverse [EFun x | (_,x) <- subst] + typ = DTyp hypos' cat args + +plFun :: (CId, (Type, Int, [Equation])) -> String +plFun (fun, (typ,_,_)) = plFact "fun" (plp fun : plTypeWithHypos typ') + where typ' = snd $ alphaConvert emptyEnv typ + +plTypeWithHypos :: Type -> [String] +plTypeWithHypos (DTyp hypos cat args) = [plTerm (plp cat) (map plp args), plList (map (\(_,x,ty) -> plOper ":" (plp x) (plp ty)) hypos)] + +plFundef :: (CId, (Type,Int,[Equation])) -> [String] +plFundef (fun, (_,_,[])) = [] +plFundef (fun, (_,_,eqs)) = [plFact "def" [plp fun, plp fundef']] + where fundef' = snd $ alphaConvert emptyEnv eqs + + +---------------------------------------------------------------------- +-- concrete syntax + +plConcrete :: (CId, Concr) -> [String] +plConcrete (cncname, Concr cflags lins opers lincats lindefs + _printnames _paramlincats _parser) = + ["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%", + "%% concrete module: " ++ plp cncname] ++ + clauseHeader "%% cncflag(?Flag, ?Value): flags for concrete syntax" + (map (mod . plpFact2 "cncflag") (Map.assocs cflags)) ++ + clauseHeader "%% lincat(?Cat, ?Linearization type)" + (map (mod . plpFact2 "lincat") (Map.assocs lincats)) ++ + clauseHeader "%% lindef(?Cat, ?Linearization default)" + (map (mod . plpFact2 "lindef") (Map.assocs lindefs)) ++ + clauseHeader "%% lin(?Fun, ?Linearization)" + (map (mod . plpFact2 "lin") (Map.assocs lins)) ++ + clauseHeader "%% oper(?Oper, ?Linearization)" + (map (mod . plpFact2 "oper") (Map.assocs opers)) + where mod clause = plp cncname ++ ": " ++ clause + + +---------------------------------------------------------------------- +-- prolog-printing pgf datatypes + +instance PLPrint Type where + plp (DTyp hypos cat args) | null hypos = result + | otherwise = plOper " -> " (plList (map (\(_,x,ty) -> plOper ":" (plp x) (plp ty)) hypos)) result + where result = plTerm (plp cat) (map plp args) + +instance PLPrint Expr where + plp (EFun x) = plp x + plp (EAbs _ x e)= plOper "^" (plp x) (plp e) + plp (EApp e e') = plOper " * " (plp e) (plp e') + plp (ELit lit) = plp lit + plp (EMeta n) = "Meta_" ++ show n + +instance PLPrint Patt where + plp (PVar x) = plp x + plp (PApp f ps) = plOper " * " (plp f) (plp ps) + plp (PLit lit) = plp lit + +instance PLPrint Equation where + plp (Equ patterns result) = plOper ":" (plp patterns) (plp result) + +instance PLPrint Term where + plp (S terms) = plTerm "s" [plp terms] + plp (C n) = plTerm "c" [show n] + plp (K tokn) = plTerm "k" [plp tokn] + plp (FV trms) = plTerm "fv" [plp trms] + plp (P t1 t2) = plTerm "p" [plp t1, plp t2] + plp (W s trm) = plTerm "w" [plp s, plp trm] + plp (R terms) = plTerm "r" [plp terms] + plp (F oper) = plTerm "f" [plp oper] + plp (V n) = plTerm "v" [show n] + plp (TM str) = plTerm "tm" [plp str] + +{-- more prolog-like syntax for PGF terms, but also more difficult to handle: +instance PLPrint Term where + plp (S terms) = plp terms + plp (C n) = show n + plp (K token) = plp token + plp (FV terms) = prCurlyList (map plp terms) + plp (P t1 t2) = plOper "/" (plp t1) (plp t2) + plp (W s trm) = plOper "+" (plp s) (plp trm) + plp (R terms) = plTerm "r" (map plp terms) + plp (F oper) = plTerm "f" [plp oper] + plp (V n) = plTerm "arg" [show n] + plp (TM str) = plTerm "meta" [plp str] +--} + +instance PLPrint CId where + plp cid | isLogicalVariable str || + cid == wildCId = plVar str + | otherwise = plAtom str + where str = showCId cid + +instance PLPrint Literal where + plp (LStr s) = plp s + plp (LInt n) = plp (show n) + plp (LFlt f) = plp (show f) + +instance PLPrint Tokn where + plp (KS tokn) = plp tokn + plp (KP strs alts) = plTerm "kp" [plp strs, plList [plOper "/" (plp ss1) (plp ss2) | + Alt ss1 ss2 <- alts]] + +---------------------------------------------------------------------- +-- basic prolog-printing + +class PLPrint a where + plp :: a -> String + plps :: [a] -> String + plps = plList . map plp + +instance PLPrint Char where + plp c = plAtom [c] + plps s = plAtom s + +instance PLPrint a => PLPrint [a] where + plp = plps + +plpFact2 :: (PLPrint a, PLPrint b) => String -> (a, b) -> String +plpFact2 fun (arg1, arg2) = plFact fun [plp arg1, plp arg2] + +plFact :: String -> [String] -> String +plFact fun args = plTerm fun args ++ "." + +plTerm :: String -> [String] -> String +plTerm fun args = plAtom fun ++ prParenth (prTList ", " args) + +plList :: [String] -> String +plList = prBracket . prTList "," + +plOper :: String -> String -> String -> String +plOper op a b = prParenth (a ++ op ++ b) + +plVar :: String -> String +plVar = varPrefix . concatMap changeNonAlphaNum + where varPrefix var@(c:_) | isAsciiUpper c || c=='_' = var + | otherwise = "_" ++ var + changeNonAlphaNum c | isAlphaNumUnderscore c = [c] + | otherwise = "_" ++ show (ord c) ++ "_" + +plAtom :: String -> String +plAtom "" = "''" +plAtom atom@(c:cs) | isAsciiLower c && all isAlphaNumUnderscore cs + || c == '\'' && cs /= "" && last cs == '\'' = atom + | otherwise = "'" ++ concatMap changeQuote atom ++ "'" + where changeQuote '\'' = "\\'" + changeQuote c = [c] + +isAlphaNumUnderscore :: Char -> Bool +isAlphaNumUnderscore c = isAlphaNum c || c == '_' + + +---------------------------------------------------------------------- +-- prolog variables + +createLogicalVariable :: Int -> CId +createLogicalVariable n = mkCId (logicalVariablePrefix ++ show n) + +isLogicalVariable :: String -> Bool +isLogicalVariable = isPrefixOf logicalVariablePrefix + +logicalVariablePrefix :: String +logicalVariablePrefix = "X" + +---------------------------------------------------------------------- +-- alpha convert variables to (unique) logical variables +-- * this is needed if we want to translate variables to Prolog variables +-- * used for abstract syntax, not concrete +-- * not (yet?) used for variables bound in pattern equations + +type ConvertEnv = (Int, [(CId,CId)]) + +emptyEnv :: ConvertEnv +emptyEnv = (0, []) + +class AlphaConvert a where + alphaConvert :: ConvertEnv -> a -> (ConvertEnv, a) + +instance AlphaConvert a => AlphaConvert [a] where + alphaConvert env [] = (env, []) + alphaConvert env (a:as) = (env'', a':as') + where (env', a') = alphaConvert env a + (env'', as') = alphaConvert env' as + +instance AlphaConvert Type where + alphaConvert env@(_,subst) (DTyp hypos cat args) + = ((ctr,subst), DTyp hypos' cat args') + where (env', hypos') = mapAccumL alphaConvertHypo env hypos + ((ctr,_), args') = alphaConvert env' args + +alphaConvertHypo env (b,x,typ) = ((ctr+1,(x,x'):subst), (b,x',typ')) + where ((ctr,subst), typ') = alphaConvert env typ + x' = createLogicalVariable ctr + +instance AlphaConvert Expr where + alphaConvert (ctr,subst) (EAbs b x e) = ((ctr',subst), EAbs b x' e') + where ((ctr',_), e') = alphaConvert (ctr+1,(x,x'):subst) e + x' = createLogicalVariable ctr + alphaConvert env (EApp e1 e2) = (env'', EApp e1' e2') + where (env', e1') = alphaConvert env e1 + (env'', e2') = alphaConvert env' e2 + alphaConvert env expr@(EFun i) = (env, maybe expr EFun (lookup i (snd env))) + alphaConvert env expr = (env, expr) + +-- pattern variables are not alpha converted +-- (but they probably should be...) +instance AlphaConvert Equation where + alphaConvert env@(_,subst) (Equ patterns result) + = ((ctr,subst), Equ patterns result') + where ((ctr,_), result') = alphaConvert env result diff --git a/src/compiler/GF/Compile/GenerateFCFG.hs b/src/compiler/GF/Compile/GenerateFCFG.hs new file mode 100644 index 000000000..52e95f686 --- /dev/null +++ b/src/compiler/GF/Compile/GenerateFCFG.hs @@ -0,0 +1,568 @@ +---------------------------------------------------------------------- +-- | +-- 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.Compile.GenerateFCFG + (convertConcrete) where + +import PGF.CId +import PGF.Data +import PGF.Macros --hiding (prt) +import PGF.Parsing.FCFG.Utilities + +import GF.Data.BacktrackM +import GF.Data.SortedList +import GF.Data.Utilities (updateNthM, sortNub) + +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import qualified Data.Set as Set +import qualified Data.List as List +import qualified Data.ByteString.Char8 as BS +import Data.Array.IArray +import Data.Maybe +import Control.Monad + +---------------------------------------------------------------------- +-- main conversion function + +convertConcrete :: Abstr -> Concr -> ParserInfo +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,Int,[Equation]))] -> TermMap -> TermMap -> ([(CId,(Type,Int,[Equation]))],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,a,e)) | (f,(ty,a,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),0,[])) | 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,0,[])) | 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 " ++ showCId 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 = mkCId "_Var" + + catName :: (Int,CId) -> CId + catName (0,c) = c + catName (n,c) = mkCId ("_" ++ show n ++ showCId c) + + funName :: (Int,CId) -> CId + funName (n,c) = mkCId ("__" ++ show n ++ showCId c) + + varFunName :: CId -> CId + varFunName c = mkCId ("_Var_" ++ showCId c) + +-- replaces __NCat with _B and _Var_Cat with _. +-- the temporary names are just there to avoid name collisions. +fixHoasFuns :: ParserInfo -> ParserInfo +fixHoasFuns pinfo = pinfo{functions=mkArray [FFun (fixName n) prof lins | FFun n prof lins <- elems (functions pinfo)]} + where fixName (CId n) | BS.pack "__" `BS.isPrefixOf` n = (mkCId "_B") + | BS.pack "_Var_" `BS.isPrefixOf` n = wildCId + fixName n = n + +convert :: [(CId,(Type,Int,[Equation]))] -> TermMap -> TermMap -> ParserInfo +convert abs_defs cnc_defs cat_defs = getParserInfo (loop grammarEnv) + where + srules = [ + (XRule id args res (map findLinType args) (findLinType res) term) | + (id, (ty,_,_)) <- abs_defs, let (args,res) = catSkeleton ty, + term <- maybeToList (Map.lookup id cnc_defs)] + + findLinType id = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs) + + (xrulesMap,grammarEnv) = List.foldl' helper (Map.empty,emptyFFunsEnv) srules + where + helper (xrulesMap,grammarEnv) rule@(XRule id abs_args abs_res cnc_args cnc_res term) = + let xrulesMap' = Map.insertWith (++) abs_res [rule] xrulesMap + grammarEnv' = List.foldl' (\env selector -> convertRule cnc_defs selector rule env) + grammarEnv + (mkSingletonSelectors cnc_defs cnc_res) + in xrulesMap' `seq` grammarEnv' `seq` (xrulesMap',grammarEnv') + + loop grammarEnv = + let (todo, grammarEnv') = takeToDoRules xrulesMap grammarEnv + in case todo of + [] -> grammarEnv' + _ -> loop $! List.foldl' (\env (srules,selector) -> + List.foldl' (\env srule -> convertRule cnc_defs selector srule env) env srules) grammarEnv' todo + +convertRule :: TermMap -> TermSelector -> XRule -> GrammarEnv -> GrammarEnv +convertRule cnc_defs selector (XRule fun args cat ctypes ctype term) grammarEnv = + foldBM addRule + grammarEnv + (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..]) + + (env3,newLinRec) = List.mapAccumL (translateLin idxArgs linRec) env2 (case newCat' of {PFCat _ rcs _ -> rcs}) + + (_,newProfile) = List.mapAccumL accumProf 0 newArgs' + where + accumProf nr (PFCat _ [] _,_ ) = (nr, [] ) + accumProf nr (_ ,xpaths) = (nr+cnt+1, [nr..nr+cnt]) + where cnt = length xpaths + + (env4,funid) = addFFun env3 (FFun fun newProfile (mkArray newLinRec)) + + in addProduction env4 newCat (FApply funid newArgs) + +translateLin idxArgs [] grammarEnv lbl' = error "translateLin" +translateLin idxArgs ((lbl,syms) : lins) grammarEnv lbl' + | lbl' == lbl = addFSeq grammarEnv (lbl,map instSym syms) + | otherwise = translateLin idxArgs lins grammarEnv lbl' + where + instSym = either (\(lbl, nr, xnr) -> instCat lbl nr xnr 0 idxArgs) + (\t -> case t of + KS s -> FSymKS [s] + KP strs vars -> FSymKP strs vars) + instCat lbl nr xnr nr' ((idx,xargs):idxArgs) + | nr == idx = let (fcat, PFCat _ rcs _) = xargs !! xnr + in FSymCat (nr'+xnr) (index lbl rcs 0) + | 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 FPath = [FIndex] +type Env = (ProtoFCat, [(ProtoFCat,[FPath])], Term, [Term]) +type LinRec = [(FPath, [Either (FPath, FIndex, Int) Tokn])] + +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,Right (KS str) : lin) : lins) +convertTerm cnc_defs selector (K (KP strs vars))((lbl_path,lin) : lins) = + do projectHead lbl_path + toks <- member (strs:[strs' | Alt strs' _ <- vars]) + return ((lbl_path, map (Right . KS) toks ++ lin) : lins) +convertTerm cnc_defs selector (F id) lins = case Map.lookup id cnc_defs of + Just term -> convertTerm cnc_defs selector term lins + Nothing -> mzero +convertTerm cnc_defs selector (W s t) ((lbl_path,lin) : lins) = do + ss <- case t of + R ss -> return ss + F f -> case Map.lookup f cnc_defs of + Just (R ss) -> return ss + _ -> mzero + 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, Left (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 (F id) = case Map.lookup id cnc_defs of + Just term -> evalTerm cnc_defs path term + Nothing -> mzero +evalTerm cnc_defs path x = error ("evalTerm ("++show x++")") + +unifyPType :: FIndex -> FPath -> Term -> CnvMonad FIndex +unifyPType nr path (C max_index) = + do (_, args, _, _) <- get + 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 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) + + +---------------------------------------------------------------------- +-- GrammarEnv + + +data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int FCatSet FSeqSet FFunSet (IntMap.IntMap (Set.Set Production)) +type FCatSet = Map.Map CId (Map.Map [FPath] (Map.Map [(FPath,FIndex)] (Either FCat FCat))) +type FSeqSet = Map.Map FSeq SeqId +type FFunSet = Map.Map FFun FunId + +data ProtoFCat = PFCat CId [FPath] [(FPath,FIndex)] + +protoFCat :: CId -> ProtoFCat +protoFCat cat = PFCat cat [] [] + +emptyFFunsEnv = GrammarEnv 0 initFCatSet Map.empty Map.empty IntMap.empty + where + initFCatSet = (ins fcatString (mkCId "String") [[0]] [] $ + ins fcatInt (mkCId "Int") [[0]] [] $ + ins fcatFloat (mkCId "Float") [[0]] [] $ + ins fcatVar (mkCId "_Var") [[0]] [] $ + Map.empty) + + ins fcat cat rcs tcs catSet = + Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs right_fcat) rcs tmap_s) cat rmap_s catSet + where + right_fcat = Right fcat + tmap_s = Map.singleton tcs right_fcat + rmap_s = Map.singleton rcs tmap_s + +addProduction :: GrammarEnv -> FCat -> Production -> GrammarEnv +addProduction (GrammarEnv last_id catSet seqSet funSet prodSet) cat p = + GrammarEnv last_id catSet seqSet funSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet) + +addFSeq :: GrammarEnv -> (FPath,[FSymbol]) -> (GrammarEnv,SeqId) +addFSeq env@(GrammarEnv last_id catSet seqSet funSet prodSet) (_,lst) = + case Map.lookup seq seqSet of + Just id -> (env,id) + Nothing -> let !last_seq = Map.size seqSet + in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet prodSet,last_seq) + where + seq = mkArray lst + +addFFun :: GrammarEnv -> FFun -> (GrammarEnv,FunId) +addFFun env@(GrammarEnv last_id catSet seqSet funSet prodSet) fun = + case Map.lookup fun funSet of + Just id -> (env,id) + Nothing -> let !last_funid = Map.size funSet + in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) prodSet,last_funid) + +getParserInfo :: GrammarEnv -> ParserInfo +getParserInfo (GrammarEnv last_id catSet seqSet funSet prodSet) = + ParserInfo { functions = mkArray funSet + , sequences = mkArray seqSet + , productions0= prodSet + , productions = prodSet + , startCats = Map.map getFCatList catSet + , totalCats = last_id+1 + } + where + mkArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] + + getFCatList rcs = Map.fold (\tcs lst -> Map.fold (\x lst -> either id id x : lst) lst tcs) [] rcs + + +genFCatHead :: GrammarEnv -> ProtoFCat -> (GrammarEnv, FCat) +genFCatHead env@(GrammarEnv last_id catSet seqSet funSet prodSet) (PFCat cat rcs tcs) = + case Map.lookup cat catSet >>= Map.lookup rcs >>= Map.lookup tcs of + Just (Left fcat) -> (GrammarEnv last_id (ins fcat) seqSet funSet prodSet, fcat) + Just (Right fcat) -> (env, fcat) + Nothing -> let fcat = last_id+1 + in (GrammarEnv fcat (ins fcat) seqSet funSet prodSet, fcat) + where + ins fcat = Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs right_fcat) rcs tmap_s) cat rmap_s catSet + where + right_fcat = Right fcat + tmap_s = Map.singleton tcs right_fcat + rmap_s = Map.singleton rcs tmap_s + +genFCatArg :: TermMap -> Term -> GrammarEnv -> ProtoFCat -> (GrammarEnv, FCat) +genFCatArg cnc_defs ctype env@(GrammarEnv last_id catSet seqSet funSet prodSet) (PFCat cat rcs tcs) = + case Map.lookup cat catSet >>= 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,prodSet1) + = foldBM (\tcs st (either_fcat,last_id,tmap,prodSet) -> + let (last_id1,tmap1,fcat_arg) = addArg tcs last_id tmap + p = FCoerce fcat_arg + prodSet1 = IntMap.insertWith Set.union fcat (Set.singleton p) prodSet + in if st + then (Right fcat, last_id1,tmap1,prodSet1) + else (either_fcat,last_id, tmap ,prodSet )) + (Left fcat,fcat,Map.insert tcs either_fcat tmap,prodSet) + (gen_tcs ctype [] []) + False + rmap1 = Map.singleton rcs tmap1 + in (GrammarEnv last_id1 (Map.insertWith (\_ -> Map.insert rcs tmap1) cat rmap1 catSet) seqSet funSet prodSet1, 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 (C max_index) path acc = + case List.lookup path tcs of + Just index -> return $! addConstraint path index acc + Nothing -> do put 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: "++showCId 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 -> GrammarEnv -> ([([XRule], TermSelector)], GrammarEnv) +takeToDoRules xrulesMap (GrammarEnv last_id catSet seqSet funSet prodSet) = + (todo,GrammarEnv last_id catSet' seqSet funSet prodSet) + where + (todo,catSet') = + 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)) [] catSet + + +------------------------------------------------------------ +-- 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 (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: "++showCId 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) <- get + return (ctypes !! nr) + +restrictArg :: FIndex -> FPath -> FIndex -> CnvMonad () +restrictArg nr path index = do + (head, args, ctype, ctypes) <- get + args' <- updateNthM (\(xcat,xs) -> do xcat <- restrictProtoFCat path index xcat + return (xcat,xs) ) nr args + put (head, args', ctype, ctypes) + +projectArg :: FIndex -> FPath -> CnvMonad Int +projectArg nr path = do + (head, args, ctype, ctypes) <- get + (xnr,args') <- updateArgs nr args + put (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, _) <- get + return ctype + +restrictHead :: FPath -> FIndex -> CnvMonad () +restrictHead path term + = do (head, args, ctype, ctypes) <- get + head' <- restrictProtoFCat path term head + put (head', args, ctype, ctypes) + +projectHead :: FPath -> CnvMonad () +projectHead path + = do (head, args, ctype, ctypes) <- get + head' <- projectProtoFCat path head + put (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 + +mkArray lst = listArray (0,length lst-1) lst diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs new file mode 100644 index 000000000..458cf3f5c --- /dev/null +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -0,0 +1,510 @@ +{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses #-} +---------------------------------------------------------------------- +-- | +-- Maintainer : Krasimir Angelov +-- Stability : (stable) +-- Portability : (portable) +-- +-- Convert PGF grammar to PMCFG grammar. +-- +----------------------------------------------------------------------------- + +module GF.Compile.GeneratePMCFG + (convertConcrete) where + +import PGF.CId +import PGF.Data +import PGF.Macros + +import GF.Infra.Option +import GF.Data.BacktrackM +import GF.Data.Utilities (updateNthM, updateNth, sortNub) + +import System.IO +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.List as List +import qualified Data.IntMap as IntMap +import qualified Data.ByteString.Char8 as BS +import Data.Array.IArray +import Data.Maybe +import Control.Monad +import Control.Exception + +---------------------------------------------------------------------- +-- main conversion function + + +convertConcrete :: Options -> Abstr -> CId -> Concr -> IO ParserInfo +convertConcrete opts abs lang cnc = do + let env0 = emptyGrammarEnv cnc_defs cat_defs + when (flag optProf opts) $ do + profileGrammar lang cnc_defs env0 pfrules + let env1 = expandHOAS abs_defs cnc_defs cat_defs lin_defs env0 + env2 = List.foldl' (convertRule cnc_defs) env1 pfrules + return $ getParserInfo env2 + where + abs_defs = Map.assocs (funs abs) + cnc_defs = Map.union (opers cnc) (lins cnc) -- "union big+small most efficient" + cat_defs = Map.insert cidVar (S []) (lincats cnc) + lin_defs = lindefs cnc + + pfrules = [ + (PFRule id args (0,res) (map findLinType args) (findLinType (0,res)) term) | + (id, (ty,_,_)) <- abs_defs, let (args,res) = typeSkeleton ty, + term <- maybeToList (Map.lookup id cnc_defs)] + + findLinType (_,id) = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs) + +profileGrammar lang cnc_defs (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfrules = do + hPutStrLn stderr "" + hPutStrLn stderr ("Language: " ++ show lang) + hPutStrLn stderr "" + hPutStrLn stderr "Categories Count" + hPutStrLn stderr "--------------------------------" + case IntMap.lookup 0 catSet of + Just cats -> mapM_ profileCat (Map.toList cats) + Nothing -> return () + hPutStrLn stderr "--------------------------------" + hPutStrLn stderr "" + hPutStrLn stderr "Rules Count" + hPutStrLn stderr "--------------------------------" + mapM_ profileRule pfrules + hPutStrLn stderr "--------------------------------" + where + profileCat (cid,(fcat1,fcat2,_)) = do + hPutStrLn stderr (lformat 23 cid ++ rformat 9 (fcat2-fcat1+1)) + + profileRule (PFRule fun args res ctypes ctype term) = do + let pargs = zipWith (protoFCat cnc_defs) args ctypes + hPutStrLn stderr (lformat 23 fun ++ rformat 9 (product [length xs | PFCat _ _ _ tcs <- pargs, (_,xs) <- tcs])) + + lformat :: Show a => Int -> a -> String + lformat n x = s ++ replicate (n-length s) ' ' + where + s = show x + + rformat :: Show a => Int -> a -> String + rformat n x = replicate (n-length s) ' ' ++ s + where + s = show x + +brk :: (GrammarEnv -> GrammarEnv) -> (GrammarEnv -> GrammarEnv) +brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = + case f (GrammarEnv last_id catSet seqSet funSet crcSet IntMap.empty) of + (GrammarEnv last_id catSet seqSet funSet crcSet topdown1) -> IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) topdown1 + where + optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | FApply funid args <- Set.toList ps]) + where + ff :: FunId -> [[FCat]] -> GrammarEnv -> GrammarEnv + ff funid xs env + | product (map Set.size ys) == count = + case List.mapAccumL (\env c -> addFCoercion env (Set.toList c)) env ys of + (env,args) -> addProduction env cat (FApply funid args) + | otherwise = List.foldl (\env args -> addProduction env cat (FApply funid args)) env xs + where + count = length xs + ys = foldr (zipWith Set.insert) (repeat Set.empty) xs + +convertRule :: TermMap -> GrammarEnv -> ProtoFRule -> GrammarEnv +convertRule cnc_defs grammarEnv (PFRule fun args res ctypes ctype term) = + let pres = protoFCat cnc_defs res ctype + pargs = zipWith (protoFCat cnc_defs) args ctypes + + b = runBranchM (convertTerm cnc_defs [] ctype term) (pargs,[]) + (grammarEnv1,b1) = addSequences' grammarEnv b + grammarEnv2 = brk (\grammarEnv -> foldBM addRule + grammarEnv + (go' b1 [] []) + (pres,pargs) ) grammarEnv1 + in grammarEnv2 + where + addRule lins (newCat', newArgs') env0 = + let [newCat] = getFCats env0 newCat' + (env1, newArgs) = List.mapAccumL (\env -> addFCoercion env . getFCats env) env0 newArgs' + + (env2,funid) = addFFun env1 (FFun fun [[n] | n <- [0..length newArgs-1]] (mkArray lins)) + + in addProduction env2 newCat (FApply funid newArgs) + +---------------------------------------------------------------------- +-- Branch monad + +newtype BranchM a = BM (forall b . (a -> ([ProtoFCat],[FSymbol]) -> Branch b) -> ([ProtoFCat],[FSymbol]) -> Branch b) + +instance Monad BranchM where + return a = BM (\c s -> c a s) + BM m >>= k = BM (\c s -> m (\a s -> unBM (k a) c s) s) + where unBM (BM m) = m + +instance MonadState ([ProtoFCat],[FSymbol]) BranchM where + get = BM (\c s -> c s s) + put s = BM (\c _ -> c () s) + +instance Functor BranchM where + fmap f (BM m) = BM (\c s -> m (c . f) s) + +runBranchM :: BranchM (Value a) -> ([ProtoFCat],[FSymbol]) -> Branch a +runBranchM (BM m) s = m (\v s -> Return v) s + +variants :: [a] -> BranchM a +variants xs = BM (\c s -> Variant (go xs c s)) + where + go [] c s = [] + go (x:xs) c s = c x s : go xs c s + +choices :: Int -> FPath -> BranchM FIndex +choices nr path = BM (\c s -> let (args,_) = s + PFCat _ _ _ tcs = args !! nr + in case fromMaybe (error "evalTerm: wrong path") (lookup path tcs) of + [index] -> c index s + indices -> Case nr path (go indices c s)) + where + go [] c s = [] + go (i:is) c s = (c i (updateEnv i s)) : go is c s + + updateEnv index (args,seq) = (updateNth (restrictArg path index) nr args,seq) + + restrictArg path index (PFCat n cat rcs tcs) = PFCat n cat rcs (addConstraint path index tcs) + + addConstraint path0 index0 [] = error "restrictProtoFCat: unknown path" + addConstraint path0 index0 (c@(path,indices) : tcs) + | path0 == path = ((path,[index0]) : tcs) + | otherwise = c : addConstraint path0 index0 tcs + +mkRecord :: [BranchM (Value a)] -> BranchM (Value a) +mkRecord xs = BM (\c -> go xs (c . Rec)) + where + go [] c s = c [] s + go (BM m:fs) c s = go fs (\bs s -> c (m (\v s -> Return v) s : bs) s) s + +-- cutBranch :: BranchM (Value a) -> BranchM (Branch a) +-- cutBranch (BM m) = BM (\c e -> c (m (\v e -> Return v) e) e) + + +---------------------------------------------------------------------- +-- term conversion + +type CnvMonad a = BranchM a + +type FPath = [FIndex] +data ProtoFCat = PFCat Int CId [FPath] [(FPath,[FIndex])] +type Env = (ProtoFCat, [ProtoFCat]) +data ProtoFRule = PFRule CId {- function -} + [(Int,CId)] {- argument types: context size and category -} + (Int,CId) {- result type : context size (always 0) and category -} + [Term] {- argument lin-types representation -} + Term {- result lin-type representation -} + Term {- body -} +type TermMap = Map.Map CId Term + + +protoFCat :: TermMap -> (Int,CId) -> Term -> ProtoFCat +protoFCat cnc_defs (n,cat) ctype = + let (rcs,tcs) = loop [] [] [] ctype' + in PFCat n cat rcs tcs + where + ctype' -- extend the high-order linearization type + | n > 0 = case ctype of + R xs -> R (xs ++ replicate n (S [])) + _ -> error $ "Not a record: " ++ show ctype + | otherwise = ctype + + loop path rcs tcs (R record) = List.foldl' (\(rcs,tcs) (index,term) -> loop (index:path) rcs tcs term) (rcs,tcs) (zip [0..] record) + loop path rcs tcs (C i) = ( rcs,(path,[0..i]):tcs) + loop path rcs tcs (S _) = (path:rcs, tcs) + loop path rcs tcs (F id) = case Map.lookup id cnc_defs of + Just term -> loop path rcs tcs term + Nothing -> error ("unknown identifier: "++show id) + +data Branch a + = Case Int FPath [Branch a] + | Variant [Branch a] + | Return (Value a) + +data Value a + = Rec [Branch a] + | Str a + | Con FIndex + + +go' :: Branch SeqId -> FPath -> [SeqId] -> BacktrackM Env [SeqId] +go' (Case nr path_ bs) path ss = do (index,b) <- member (zip [0..] bs) + restrictArg nr path_ index + go' b path ss +go' (Variant bs) path ss = do b <- member bs + go' b path ss +go' (Return v) path ss = go v path ss + +go :: Value SeqId -> FPath -> [SeqId] -> BacktrackM Env [SeqId] +go (Rec xs) path ss = foldM (\ss (lbl,b) -> go' b (lbl:path) ss) ss (zip [0..] xs) +go (Str seqid) path ss = return (seqid : ss) +go (Con i) path ss = restrictHead path i >> return ss + +addSequences' :: GrammarEnv -> Branch [FSymbol] -> (GrammarEnv, Branch SeqId) +addSequences' env (Case nr path bs) = let (env1,bs1) = List.mapAccumL addSequences' env bs + in (env1,Case nr path bs1) +addSequences' env (Variant bs) = let (env1,bs1) = List.mapAccumL addSequences' env bs + in (env1,Variant bs1) +addSequences' env (Return v) = let (env1,v1) = addSequences env v + in (env1,Return v1) + +addSequences :: GrammarEnv -> Value [FSymbol] -> (GrammarEnv, Value SeqId) +addSequences env (Rec vs) = let (env1,vs1) = List.mapAccumL addSequences' env vs + in (env1,Rec vs1) +addSequences env (Str lin) = let (env1,seqid) = addFSeq env (optimizeLin lin) + in (env1,Str seqid) +addSequences env (Con i) = (env,Con i) + + +optimizeLin [] = [] +optimizeLin lin@(FSymKS _ : _) = + let (ts,lin') = getRest lin + in FSymKS ts : optimizeLin lin' + where + getRest (FSymKS ts : lin) = let (ts1,lin') = getRest lin + in (ts++ts1,lin') + getRest lin = ([],lin) +optimizeLin (sym : lin) = sym : optimizeLin lin + + +convertTerm :: TermMap -> FPath -> Term -> Term -> CnvMonad (Value [FSymbol]) +convertTerm cnc_defs sel ctype (V nr) = convertArg ctype nr (reverse sel) +convertTerm cnc_defs sel ctype (C nr) = convertCon ctype nr (reverse sel) +convertTerm cnc_defs sel ctype (R record) = convertRec cnc_defs sel ctype record +convertTerm cnc_defs sel ctype (P term p) = do nr <- evalTerm cnc_defs [] p + convertTerm cnc_defs (nr:sel) ctype term +convertTerm cnc_defs sel ctype (FV vars) = do term <- variants vars + convertTerm cnc_defs sel ctype term +convertTerm cnc_defs sel ctype (S ts) = do vs <- mapM (convertTerm cnc_defs sel ctype) ts + return (Str (concat [s | Str s <- vs])) +convertTerm cnc_defs sel ctype (K (KS t)) = return (Str [FSymKS [t]]) +convertTerm cnc_defs sel ctype (K (KP s v))=return (Str [FSymKP s v]) +convertTerm cnc_defs sel ctype (F id) = case Map.lookup id cnc_defs of + Just term -> convertTerm cnc_defs sel ctype term + Nothing -> error ("unknown id " ++ showCId id) +convertTerm cnc_defs sel ctype (W s t) = do + ss <- case t of + R ss -> return ss + F f -> case Map.lookup f cnc_defs of + Just (R ss) -> return ss + _ -> error ("unknown id " ++ showCId f) + convertRec cnc_defs sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss] +convertTerm cnc_defs sel ctype x = error ("convertTerm ("++show x++")") + +convertArg :: Term -> Int -> FPath -> CnvMonad (Value [FSymbol]) +convertArg (R ctypes) nr path = do + mkRecord (zipWith (\lbl ctype -> convertArg ctype nr (lbl:path)) [0..] ctypes) +convertArg (C max) nr path = do + index <- choices nr path + return (Con index) +convertArg (S _) nr path = do + (args,_) <- get + let PFCat _ cat rcs tcs = args !! nr + l = index path rcs 0 + sym | isLiteralCat cat = FSymLit nr l + | otherwise = FSymCat nr l + return (Str [sym]) + where + index lbl' (lbl:lbls) idx + | lbl' == lbl = idx + | otherwise = index lbl' lbls $! (idx+1) + +convertCon (C max) index [] = return (Con index) +convertCon x _ _ = fail $ "SimpleToFCFG.convertCon: " ++ show x + +convertRec cnc_defs [] (R ctypes) record = do + mkRecord (zipWith (convertTerm cnc_defs []) ctypes record) +convertRec cnc_defs (index:sub_sel) ctype record = + convertTerm cnc_defs sub_sel ctype (record !! index) + + +------------------------------------------------------------ +-- eval a term to ground terms + +evalTerm :: TermMap -> FPath -> Term -> CnvMonad FIndex +evalTerm cnc_defs path (V nr) = choices nr (reverse path) +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) = variants terms >>= evalTerm cnc_defs path +evalTerm cnc_defs path (F id) = case Map.lookup id cnc_defs of + Just term -> evalTerm cnc_defs path term + Nothing -> error ("unknown id " ++ showCId id) +evalTerm cnc_defs path x = error ("evalTerm ("++show x++")") + + +---------------------------------------------------------------------- +-- GrammarEnv + +data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet CoerceSet (IntMap.IntMap (Set.Set Production)) +type CatSet = IntMap.IntMap (Map.Map CId (FCat,FCat,[Int])) +type SeqSet = Map.Map FSeq SeqId +type FunSet = Map.Map FFun FunId +type CoerceSet= Map.Map [FCat] FCat + +emptyGrammarEnv cnc_defs lincats = + let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats + in GrammarEnv last_id (IntMap.singleton 0 catSet) Map.empty Map.empty Map.empty IntMap.empty + where + computeCatRange index cat ctype + | cat == cidString = (index, (fcatString,fcatString,[])) + | cat == cidInt = (index, (fcatInt, fcatInt, [])) + | cat == cidFloat = (index, (fcatFloat, fcatFloat, [])) + | cat == cidVar = (index, (fcatVar, fcatVar, [])) + | otherwise = (index+size,(index,index+size-1,poly)) + where + (size,poly) = getMultipliers 1 [] ctype + + getMultipliers m ms (R record) = foldl (\(m,ms) t -> getMultipliers m ms t) (m,ms) record + getMultipliers m ms (S _) = (m,ms) + getMultipliers m ms (C max_index) = (m*(max_index+1),m : ms) + getMultipliers m ms (F id) = case Map.lookup id cnc_defs of + Just term -> getMultipliers m ms term + Nothing -> error ("unknown identifier: "++showCId id) + +expandHOAS abs_defs cnc_defs lincats lindefs env = + foldl add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) hoCats + where + hoTypes :: [(Int,CId)] + hoTypes = sortNub [(n,c) | (_,(ty,_,_)) <- abs_defs + , (n,c) <- fst (typeSkeleton ty), n > 0] + + hoCats :: [CId] + hoCats = sortNub [c | (_,(ty,_,_)) <- abs_defs + , h <- case ty of {DTyp hyps val _ -> hyps} + , let ty = typeOfHypo h + , c <- fst (catSkeleton ty)] + + -- add a range of PMCFG categories for each GF high-order category + add_hoCat env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,cat) = + case IntMap.lookup 0 catSet >>= Map.lookup cat of + Just (start,end,ms) -> let !catSet' = IntMap.insertWith Map.union n (Map.singleton cat (last_id,last_id+(end-start),ms)) catSet + !last_id' = last_id+(end-start)+1 + in (GrammarEnv last_id' catSet' seqSet funSet crcSet prodSet) + Nothing -> env + + -- add one PMCFG function for each high-order type: _B : Cat -> Var -> ... -> Var -> HoCat + add_hoFun env (n,cat) = + let linRec = reverse $ + [[FSymCat 0 i] | (l,i) <- case arg of {PFCat _ _ rcs _ -> zip rcs [0..]}] ++ + [[FSymLit i 0] | i <- [1..n]] + (env1,lins) = List.mapAccumL addFSeq env linRec + newLinRec = mkArray lins + + (env2,funid) = addFFun env1 (FFun _B [[i] | i <- [0..n]] newLinRec) + + env3 = foldl (\env (arg,res) -> addProduction env res (FApply funid (arg : replicate n fcatVar))) + env2 + (zip (getFCats env2 arg) (getFCats env2 res)) + in env3 + where + (arg,res) = case Map.lookup cat lincats of + Nothing -> error $ "No lincat for " ++ showCId cat + Just ctype -> (protoFCat cnc_defs (0,cat) ctype, protoFCat cnc_defs (n,cat) ctype) + + -- add one PMCFG function for each high-order category: _V : Var -> Cat + add_varFun env cat = + convertRule cnc_defs env (PFRule _V [(0,cidVar)] (0,cat) [arg] res lindef) + where + lindef = + case Map.lookup cat lindefs of + Nothing -> error $ "No lindef for " ++ showCId cat + Just def -> def + + arg = + case Map.lookup cidVar lincats of + Nothing -> error $ "No lincat for " ++ showCId cat + Just ctype -> ctype + + res = + case Map.lookup cat lincats of + Nothing -> error $ "No lincat for " ++ showCId cat + Just ctype -> ctype + + _B = mkCId "_B" + _V = mkCId "_V" + +addProduction :: GrammarEnv -> FCat -> Production -> GrammarEnv +addProduction (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) cat p = + GrammarEnv last_id catSet seqSet funSet crcSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet) + +addFSeq :: GrammarEnv -> [FSymbol] -> (GrammarEnv,SeqId) +addFSeq env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) lst = + case Map.lookup seq seqSet of + Just id -> (env,id) + Nothing -> let !last_seq = Map.size seqSet + in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet crcSet prodSet,last_seq) + where + seq = mkArray lst + +addFFun :: GrammarEnv -> FFun -> (GrammarEnv,FunId) +addFFun env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) fun = + case Map.lookup fun funSet of + Just id -> (env,id) + Nothing -> let !last_funid = Map.size funSet + in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) crcSet prodSet,last_funid) + +addFCoercion :: GrammarEnv -> [FCat] -> (GrammarEnv,FCat) +addFCoercion env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) sub_fcats = + case sub_fcats of + [fcat] -> (env,fcat) + _ -> case Map.lookup sub_fcats crcSet of + Just fcat -> (env,fcat) + Nothing -> let !fcat = last_id+1 + in (GrammarEnv fcat catSet seqSet funSet (Map.insert sub_fcats fcat crcSet) prodSet,fcat) + +getParserInfo :: GrammarEnv -> ParserInfo +getParserInfo (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = + ParserInfo { functions = mkArray funSet + , sequences = mkArray seqSet + , productions0= productions0 + , productions = filterProductions productions0 + , startCats = maybe Map.empty (Map.map (\(start,end,_) -> range (start,end))) (IntMap.lookup 0 catSet) + , totalCats = last_id+1 + } + where + mkArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] + + productions0 = IntMap.union prodSet coercions + coercions = IntMap.fromList [(fcat,Set.fromList (map FCoerce sub_fcats)) | (sub_fcats,fcat) <- Map.toList crcSet] + +getFCats :: GrammarEnv -> ProtoFCat -> [FCat] +getFCats (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat rcs tcs) = + case IntMap.lookup n catSet >>= Map.lookup cat of + Just (start,end,ms) -> reverse (solutions (variants ms tcs start) ()) + where + variants _ [] fcat = return fcat + variants (m:ms) ((_,indices) : tcs) fcat = do index <- member indices + variants ms tcs ((m*index) + fcat) + + +------------------------------------------------------------ +-- updating the MCF rule + +restrictArg :: FIndex -> FPath -> FIndex -> BacktrackM Env () +restrictArg nr path index = do + (head, args) <- get + args' <- updateNthM (restrictProtoFCat path index) nr args + put (head, args') + +restrictHead :: FPath -> FIndex -> BacktrackM Env () +restrictHead path term + = do (head, args) <- get + head' <- restrictProtoFCat path term head + put (head', args) + +restrictProtoFCat :: FPath -> FIndex -> ProtoFCat -> BacktrackM Env ProtoFCat +restrictProtoFCat path0 index0 (PFCat n cat rcs tcs) = do + tcs <- addConstraint tcs + return (PFCat n cat rcs tcs) + where + addConstraint [] = error "restrictProtoFCat: unknown path" + addConstraint (c@(path,indices) : tcs) + | path0 == path = guard (index0 `elem` indices) >> + return ((path,[index0]) : tcs) + | otherwise = liftM (c:) (addConstraint tcs) + +mkArray lst = listArray (0,length lst-1) lst diff --git a/src/compiler/GF/Compile/GeneratePMCFGOld.hs b/src/compiler/GF/Compile/GeneratePMCFGOld.hs new file mode 100644 index 000000000..244ed68fe --- /dev/null +++ b/src/compiler/GF/Compile/GeneratePMCFGOld.hs @@ -0,0 +1,374 @@ +{-# LANGUAGE BangPatterns, CPP #-} +---------------------------------------------------------------------- +-- | +-- 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.Compile.GeneratePMCFG + (convertConcrete) where + +import PGF.CId +import PGF.Data +import PGF.Macros --hiding (prt) + +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 qualified Data.IntMap as IntMap +import qualified Data.ByteString.Char8 as BS +import Data.Array.IArray +import Data.Maybe +import Control.Monad +import Debug.Trace + +---------------------------------------------------------------------- +-- main conversion function + +convertConcrete :: Abstr -> Concr -> ParserInfo +convertConcrete abs cnc = 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 + +convert :: [(CId,(Type,Expr))] -> TermMap -> TermMap -> ParserInfo +convert abs_defs cnc_defs cat_defs = + let env = expandHOAS abs_defs cnc_defs cat_defs (emptyGrammarEnv cnc_defs cat_defs) + in getParserInfo (List.foldl' (convertRule cnc_defs) env xrules) + where + xrules = [ + (XRule id args (0,res) (map findLinType args) (findLinType (0,res)) term) | + (id, (ty,_)) <- abs_defs, let (args,res) = typeSkeleton ty, + term <- maybeToList (Map.lookup id cnc_defs)] + + findLinType (_,id) = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs) + +brk :: (GrammarEnv -> GrammarEnv) -> (GrammarEnv -> GrammarEnv) +brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = + case f (GrammarEnv last_id catSet seqSet funSet crcSet IntMap.empty) of + (GrammarEnv last_id catSet seqSet funSet crcSet topdown1) -> IntMap.foldWithKey optimize (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) topdown1 + where + optimize cat ps env = IntMap.foldWithKey ff env (IntMap.fromListWith (++) [(funid,[args]) | FApply funid args <- Set.toList ps]) + where + ff :: FunId -> [[FCat]] -> GrammarEnv -> GrammarEnv + ff funid xs env + | product (map Set.size ys) == count = + case List.mapAccumL (\env c -> addFCoercion env (Set.toList c)) env ys of + (env,args) -> addProduction env cat (FApply funid args) + | otherwise = List.foldl (\env args -> addProduction env cat (FApply funid args)) env xs + where + count = length xs + ys = foldr (zipWith Set.insert) (repeat Set.empty) xs + +convertRule :: TermMap -> GrammarEnv -> XRule -> GrammarEnv +convertRule cnc_defs grammarEnv (XRule fun args res ctypes ctype term) = + brk (\grammarEnv -> foldBM addRule + grammarEnv + (convertTerm cnc_defs [] ctype term [([],[])]) + (protoFCat cnc_defs res ctype, zipWith (protoFCat cnc_defs) args ctypes)) grammarEnv + where + addRule linRec (newCat', newArgs') env0 = + let [newCat] = getFCats env0 newCat' + (env1, newArgs) = List.mapAccumL (\env -> addFCoercion env . getFCats env) env0 newArgs' + + (env2,lins) = List.mapAccumL addFSeq env1 linRec + newLinRec = mkArray lins + + (env3,funid) = addFFun env2 (FFun fun [[n] | n <- [0..length newArgs-1]] newLinRec) + + in addProduction env3 newCat (FApply funid newArgs) + +---------------------------------------------------------------------- +-- term conversion + +type CnvMonad a = BacktrackM Env a + +type FPath = [FIndex] +data ProtoFCat = PFCat Int CId [FPath] [(FPath,[FIndex])] +type Env = (ProtoFCat, [ProtoFCat]) +type LinRec = [(FPath, [FSymbol])] +data XRule = XRule CId {- function -} + [(Int,CId)] {- argument types: context size and category -} + (Int,CId) {- result type : context size (always 0) and category -} + [Term] {- argument lin-types representation -} + Term {- result lin-type representation -} + Term {- body -} + +protoFCat :: TermMap -> (Int,CId) -> Term -> ProtoFCat +protoFCat cnc_defs (n,cat) ctype = + let (rcs,tcs) = loop [] [] [] ctype' + in PFCat n cat rcs tcs + where + ctype' -- extend the high-order linearization type + | n > 0 = case ctype of + R xs -> R (xs ++ replicate n (S [])) + _ -> error $ "Not a record: " ++ show ctype + | otherwise = ctype + + loop path rcs tcs (R record) = List.foldl' (\(rcs,tcs) (index,term) -> loop (index:path) rcs tcs term) (rcs,tcs) (zip [0..] record) + loop path rcs tcs (C i) = ( rcs,(path,[0..i]):tcs) + loop path rcs tcs (S _) = (path:rcs, tcs) + loop path rcs tcs (F id) = case Map.lookup id cnc_defs of + Just term -> loop path rcs tcs term + Nothing -> error ("unknown identifier: "++show id) + +type TermMap = Map.Map CId Term + +convertTerm :: TermMap -> FPath -> Term -> Term -> LinRec -> CnvMonad LinRec +convertTerm cnc_defs sel ctype (V nr) ((lbl_path,lin) : lins) = convertArg ctype nr (reverse sel) lbl_path lin lins +convertTerm cnc_defs sel ctype (C nr) ((lbl_path,lin) : lins) = convertCon ctype nr (reverse sel) lbl_path lin lins +convertTerm cnc_defs sel ctype (R record) ((lbl_path,lin) : lins) = convertRec cnc_defs sel ctype record lbl_path lin lins +convertTerm cnc_defs sel ctype (P term p) lins = do nr <- evalTerm cnc_defs [] p + convertTerm cnc_defs (nr:sel) ctype term lins +convertTerm cnc_defs sel ctype (FV vars) lins = do term <- member vars + convertTerm cnc_defs sel ctype term lins +convertTerm cnc_defs sel ctype (S ts) lins = foldM (\lins t -> convertTerm cnc_defs sel ctype t lins) lins (reverse ts) +--convertTerm cnc_defs sel ctype (K t) ((lbl_path,lin) : lins) = return ((lbl_path,FSymTok t : lin) : lins) +convertTerm cnc_defs sel ctype (K (KS t)) ((lbl_path,lin) : lins) = return ((lbl_path,FSymTok (KS t) : lin) : lins) +convertTerm cnc_defs sel ctype (K (KP strs vars))((lbl_path,lin) : lins) = + do toks <- member (strs:[strs' | Alt strs' _ <- vars]) + return ((lbl_path, map (FSymTok . KS) toks ++ lin) : lins) +convertTerm cnc_defs sel ctype (F id) lins = case Map.lookup id cnc_defs of + Just term -> convertTerm cnc_defs sel ctype term lins + Nothing -> mzero +convertTerm cnc_defs sel ctype (W s t) ((lbl_path,lin) : lins) = do + ss <- case t of + R ss -> return ss + F f -> case Map.lookup f cnc_defs of + Just (R ss) -> return ss + _ -> mzero + convertRec cnc_defs sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss] lbl_path lin lins +convertTerm cnc_defs sel ctype x lins = error ("convertTerm ("++show x++")") + + +convertArg (R record) nr path lbl_path lin lins = + foldM (\lins (lbl, ctype) -> convertArg ctype nr (lbl:path) (lbl:lbl_path) lin lins) lins (zip [0..] record) +convertArg (C max) nr path lbl_path lin lins = do + index <- member [0..max] + restrictHead lbl_path index + restrictArg nr path index + return lins +convertArg (S _) nr path lbl_path lin lins = do + (_, args) <- get + let PFCat _ cat rcs tcs = args !! nr + l = index path rcs 0 + sym | isLiteralCat cat = FSymLit nr l + | otherwise = FSymCat nr l + return ((lbl_path, sym : lin) : lins) + where + index lbl' (lbl:lbls) idx + | lbl' == lbl = idx + | otherwise = index lbl' lbls $! (idx+1) + + +convertCon (C max) index [] lbl_path lin lins = do + guard (index <= max) + restrictHead lbl_path index + return lins +convertCon x _ _ _ _ _ = error $ "SimpleToFCFG,convertCon: " ++ show x + +convertRec cnc_defs [] (R ctypes) record lbl_path lin lins = + foldM (\lins (index,ctype,val) -> convertTerm cnc_defs [] ctype val ((index:lbl_path,lin) : lins)) + lins + (zip3 [0..] ctypes record) +convertRec cnc_defs (index:sub_sel) ctype record lbl_path lin lins = do + convertTerm cnc_defs sub_sel ctype (record !! index) ((lbl_path,lin) : lins) + + +------------------------------------------------------------ +-- eval a term to ground terms + +evalTerm :: TermMap -> FPath -> Term -> CnvMonad FIndex +evalTerm cnc_defs path (V nr) = do (_, args) <- get + let PFCat _ _ _ tcs = args !! nr + rpath = reverse path + index <- member (fromMaybe (error "evalTerm: wrong path") (lookup rpath tcs)) + restrictArg nr rpath index + return index +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 (F id) = case Map.lookup id cnc_defs of + Just term -> evalTerm cnc_defs path term + Nothing -> mzero +evalTerm cnc_defs path x = error ("evalTerm ("++show x++")") + + +---------------------------------------------------------------------- +-- GrammarEnv + +data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int CatSet SeqSet FunSet CoerceSet (IntMap.IntMap (Set.Set Production)) +type CatSet = IntMap.IntMap (Map.Map CId (FCat,FCat,[Int])) +type SeqSet = Map.Map FSeq SeqId +type FunSet = Map.Map FFun FunId +type CoerceSet= Map.Map [FCat] FCat + +emptyGrammarEnv cnc_defs lincats = + let (last_id,catSet) = Map.mapAccumWithKey computeCatRange 0 lincats + in GrammarEnv last_id (IntMap.singleton 0 catSet) Map.empty Map.empty Map.empty IntMap.empty + where + computeCatRange index cat ctype + | cat == cidString = (index, (fcatString,fcatString,[])) + | cat == cidInt = (index, (fcatInt, fcatInt, [])) + | cat == cidFloat = (index, (fcatFloat, fcatFloat, [])) + | otherwise = (index+size,(index,index+size-1,poly)) + where + (size,poly) = getMultipliers 1 [] ctype + + getMultipliers m ms (R record) = foldl (\(m,ms) t -> getMultipliers m ms t) (m,ms) record + getMultipliers m ms (S _) = (m,ms) + getMultipliers m ms (C max_index) = (m*(max_index+1),m : ms) + getMultipliers m ms (F id) = case Map.lookup id cnc_defs of + Just term -> getMultipliers m ms term + Nothing -> error ("unknown identifier: "++prCId id) + + +expandHOAS abs_defs cnc_defs lincats env = + foldl add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) hoCats + where + hoTypes :: [(Int,CId)] + hoTypes = sortNub [(n,c) | (_,(ty,_)) <- abs_defs + , (n,c) <- fst (typeSkeleton ty), n > 0] + + hoCats :: [CId] + hoCats = sortNub [c | (_,(ty,_)) <- abs_defs + , Hyp _ ty <- case ty of {DTyp hyps val _ -> hyps} + , c <- fst (catSkeleton ty)] + + -- add a range of PMCFG categories for each GF high-order category + add_hoCat env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,cat) = + case IntMap.lookup 0 catSet >>= Map.lookup cat of + Just (start,end,ms) -> let !catSet' = IntMap.insertWith Map.union n (Map.singleton cat (last_id,last_id+(end-start),ms)) catSet + !last_id' = last_id+(end-start)+1 + in (GrammarEnv last_id' catSet' seqSet funSet crcSet prodSet) + Nothing -> env + + -- add one PMCFG function for each high-order type: _B : Cat -> Var -> ... -> Var -> HoCat + add_hoFun env (n,cat) = + let linRec = reverse $ + [(l ,[FSymCat 0 i]) | (l,i) <- case arg of {PFCat _ _ rcs _ -> zip rcs [0..]}] ++ + [([],[FSymLit i 0]) | i <- [1..n]] + (env1,lins) = List.mapAccumL addFSeq env linRec + newLinRec = mkArray lins + + (env2,funid) = addFFun env1 (FFun _B [[i] | i <- [0..n]] newLinRec) + + env3 = foldl (\env (arg,res) -> addProduction env res (FApply funid (arg : replicate n fcatVar))) + env2 + (zip (getFCats env2 arg) (getFCats env2 res)) + in env3 + where + (arg,res) = case Map.lookup cat lincats of + Nothing -> error $ "No lincat for " ++ prCId cat + Just ctype -> (protoFCat cnc_defs (0,cat) ctype, protoFCat cnc_defs (n,cat) ctype) + + -- add one PMCFG function for each high-order category: _V : Var -> Cat + add_varFun env cat = + let (env1,seqid) = addFSeq env ([],[FSymLit 0 0]) + lins = replicate (case res of {PFCat _ _ rcs _ -> length rcs}) seqid + (env2,funid) = addFFun env1 (FFun _V [[0]] (mkArray lins)) + env3 = foldl (\env res -> addProduction env2 res (FApply funid [fcatVar])) + env2 + (getFCats env2 res) + in env3 + where + res = case Map.lookup cat lincats of + Nothing -> error $ "No lincat for " ++ prCId cat + Just ctype -> protoFCat cnc_defs (0,cat) ctype + + _B = mkCId "_B" + _V = mkCId "_V" + + +addProduction :: GrammarEnv -> FCat -> Production -> GrammarEnv +addProduction (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) cat p = + GrammarEnv last_id catSet seqSet funSet crcSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet) + +addFSeq :: GrammarEnv -> (FPath,[FSymbol]) -> (GrammarEnv,SeqId) +addFSeq env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (_,lst) = + case Map.lookup seq seqSet of + Just id -> (env,id) + Nothing -> let !last_seq = Map.size seqSet + in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet crcSet prodSet,last_seq) + where + seq = mkArray lst + +addFFun :: GrammarEnv -> FFun -> (GrammarEnv,FunId) +addFFun env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) fun = + case Map.lookup fun funSet of + Just id -> (env,id) + Nothing -> let !last_funid = Map.size funSet + in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) crcSet prodSet,last_funid) + +addFCoercion :: GrammarEnv -> [FCat] -> (GrammarEnv,FCat) +addFCoercion env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) sub_fcats = + case sub_fcats of + [fcat] -> (env,fcat) + _ -> case Map.lookup sub_fcats crcSet of + Just fcat -> (env,fcat) + Nothing -> let !fcat = last_id+1 + in (GrammarEnv fcat catSet seqSet funSet (Map.insert sub_fcats fcat crcSet) prodSet,fcat) + +getParserInfo :: GrammarEnv -> ParserInfo +getParserInfo (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = + ParserInfo { functions = mkArray funSet + , sequences = mkArray seqSet + , productions = IntMap.union prodSet coercions + , startCats = maybe Map.empty (Map.map (\(start,end,_) -> range (start,end))) (IntMap.lookup 0 catSet) + , totalCats = last_id+1 + } + where + mkArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] + + coercions = IntMap.fromList [(fcat,Set.fromList (map FCoerce sub_fcats)) | (sub_fcats,fcat) <- Map.toList crcSet] + +getFCats :: GrammarEnv -> ProtoFCat -> [FCat] +getFCats (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (PFCat n cat rcs tcs) = + case IntMap.lookup n catSet >>= Map.lookup cat of + Just (start,end,ms) -> reverse (solutions (variants ms tcs start) ()) + where + variants _ [] fcat = return fcat + variants (m:ms) ((_,indices) : tcs) fcat = do index <- member indices + variants ms tcs ((m*index) + fcat) + +------------------------------------------------------------ +-- updating the MCF rule + +restrictArg :: FIndex -> FPath -> FIndex -> CnvMonad () +restrictArg nr path index = do + (head, args) <- get + args' <- updateNthM (restrictProtoFCat path index) nr args + put (head, args') + +restrictHead :: FPath -> FIndex -> CnvMonad () +restrictHead path term + = do (head, args) <- get + head' <- restrictProtoFCat path term head + put (head', args) + +restrictProtoFCat :: FPath -> FIndex -> ProtoFCat -> CnvMonad ProtoFCat +restrictProtoFCat path0 index0 (PFCat n cat rcs tcs) = do + tcs <- addConstraint tcs + return (PFCat n cat rcs tcs) + where + addConstraint [] = error "restrictProtoFCat: unknown path" + addConstraint (c@(path,indices) : tcs) + | path0 == path = guard (index0 `elem` indices) >> + return ((path,[index0]) : tcs) + | otherwise = liftM (c:) (addConstraint tcs) + +mkArray lst = listArray (0,length lst-1) lst diff --git a/src/compiler/GF/Compile/GetGrammar.hs b/src/compiler/GF/Compile/GetGrammar.hs new file mode 100644 index 000000000..c85f9588f --- /dev/null +++ b/src/compiler/GF/Compile/GetGrammar.hs @@ -0,0 +1,52 @@ +---------------------------------------------------------------------- +-- | +-- 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, addOptionsToModule) where + +import GF.Data.Operations + +import GF.Infra.UseIO +import GF.Infra.Modules +import GF.Infra.Option +import GF.Grammar.Lexer +import GF.Grammar.Parser +import GF.Grammar.Grammar + +import GF.Compile.ReadFiles + +import Data.Char (toUpper) +import Data.List (nub) +import qualified Data.ByteString.Char8 as BS +import Control.Monad (foldM) +import System.Cmd (system) + +getSourceModule :: Options -> FilePath -> IOE SourceModule +getSourceModule opts file0 = ioe $ + catch (do file <- foldM runPreprocessor file0 (flag optPreprocessors opts) + content <- BS.readFile file + case runP pModDef content of + Left (Pn l c,msg) -> return (Bad (file++":"++show l++":"++show c++": "++msg)) + Right mo -> return (Ok (addOptionsToModule opts mo))) + (\e -> return (Bad (show e))) + +addOptionsToModule :: Options -> SourceModule -> SourceModule +addOptionsToModule opts = mapSourceModule (\m -> m { flags = flags m `addOptions` opts }) + +-- FIXME: should use System.IO.openTempFile +runPreprocessor :: FilePath -> String -> IO FilePath +runPreprocessor file0 p = do + let tmp = "_gf_preproc.tmp" + cmd = p +++ file0 ++ ">" ++ tmp + system cmd + return tmp diff --git a/src/compiler/GF/Compile/GrammarToGFCC.hs b/src/compiler/GF/Compile/GrammarToGFCC.hs new file mode 100644 index 000000000..fb92ef74c --- /dev/null +++ b/src/compiler/GF/Compile/GrammarToGFCC.hs @@ -0,0 +1,587 @@ +{-# LANGUAGE PatternGuards #-} +module GF.Compile.GrammarToGFCC (mkCanon2gfcc,addParsers) where + +import GF.Compile.Export +import qualified GF.Compile.GenerateFCFG as FCFG +import qualified GF.Compile.GeneratePMCFG as PMCFG + +import PGF.CId +import qualified PGF.Macros as CM +import qualified PGF.Data as C +import qualified PGF.Data as D +import GF.Grammar.Predef +import GF.Grammar.Printer +import GF.Grammar.Grammar +import qualified GF.Grammar.Lookup as Look +import qualified GF.Grammar as A +import qualified GF.Grammar.Macros as GM +import qualified GF.Compile.Concrete.Compute as Compute ---- +import qualified GF.Infra.Modules as M +import qualified GF.Infra.Option as O + +import GF.Infra.Ident +import GF.Infra.Option +import GF.Data.Operations + +import Data.List +import Data.Char (isDigit,isSpace) +import qualified Data.Map as Map +import qualified Data.ByteString.Char8 as BS +import Text.PrettyPrint +import Debug.Trace ---- + +-- when developing, swap commenting +--traceD s t = trace s t +traceD s t = t + + +-- the main function: generate PGF from GF. +mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.PGF) +mkCanon2gfcc opts cnc gr = + (showIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon opts abs) gr) + where + abs = err (const c) id $ M.abstractOfConcrete gr c where c = identC (BS.pack cnc) + pars = mkParamLincat gr + +-- Adds parsers for all concretes +addParsers :: Options -> D.PGF -> IO D.PGF +addParsers opts pgf = do cncs <- sequence [conv lang cnc | (lang,cnc) <- Map.toList (D.concretes pgf)] + return pgf { D.concretes = Map.fromList cncs } + where + conv lang cnc = do pinfo <- if flag optErasing (erasingFromCnc `addOptions` opts) + then PMCFG.convertConcrete opts (D.abstract pgf) lang cnc + else return $ FCFG.convertConcrete (D.abstract pgf) cnc + return (lang,cnc { D.parser = Just pinfo }) + where + erasingFromCnc = modifyFlags (\o -> o { optErasing = Map.lookup (mkCId "erasing") (D.cflags cnc) == Just "on"}) + +-- Generate PGF from GFCM. +-- this assumes a grammar translated by canon2canon + +canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.PGF +canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) = + (if dump opts DumpCanon then trace (render (vcat (map (ppModule Qualified) (M.modules cgr)))) else id) $ + D.PGF an cns gflags abs cncs + where + -- abstract + an = (i2i a) + cns = map (i2i . fst) cms + abs = D.Abstr aflags funs cats catfuns + gflags = Map.empty + aflags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF (M.flags abm)] + + mkDef (Just eqs) = [C.Equ ps' (mkExp scope' e) | (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] + mkDef Nothing = [] + + mkArrity (Just a) = a + mkArrity Nothing = 0 + + -- concretes + lfuns = [(f', (mkType [] ty, mkArrity ma, mkDef pty)) | + (f,AbsFun (Just ty) ma pty) <- tree2list (M.jments abm), let f' = i2i f] + funs = Map.fromAscList lfuns + lcats = [(i2i c, snd (mkContext [] cont)) | + (c,AbsCat (Just 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,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 [(mkCId f,x) | (f,x) <- optionsPGF (M.flags mo)] + opers = Map.fromAscList [] -- opers will be created as optimization + utf = id -- trace (show lang0 +++ show flags) $ + -- if moduleFlag optEncoding (moduleOptions (M.flags mo)) == UTF_8 + -- then id else id + ---- then (trace "decode" D.convertStringsInTerm decodeUTF8) else id + umkTerm = utf . mkTerm + lins = Map.fromAscList + [(f', umkTerm tr) | (f,CncFun _ (Just tr) _) <- js, + let f' = i2i f, exists f'] -- eliminating lins without fun + -- needed even here because of restricted inheritance + lincats = Map.fromAscList + [(i2i c, mkCType ty) | (c,CncCat (Just ty) _ _) <- js] + lindefs = Map.fromAscList + [(i2i c, umkTerm tr) | (c,CncCat _ (Just tr) _) <- js] + printnames = Map.union + (Map.fromAscList [(i2i f, umkTerm tr) | (f,CncFun _ _ (Just tr)) <- js]) + (Map.fromAscList [(i2i f, umkTerm tr) | (f,CncCat _ _ (Just tr)) <- js]) + params = Map.fromAscList + [(i2i c, pars lang0 c) | (c,CncCat (Just ty) _ _) <- js] + fcfg = Nothing + + exists f = Map.member f funs + +i2i :: Ident -> CId +i2i = CId . ident2bs + +b2b :: A.BindType -> C.BindType +b2b A.Explicit = C.Explicit +b2b A.Implicit = C.Implicit + +mkType :: [Ident] -> A.Type -> C.Type +mkType scope t = + case GM.typeForm t of + (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps + in C.DTyp hyps' (i2i cat) (map (mkExp scope') args) + +mkExp :: [Ident] -> A.Term -> C.Expr +mkExp scope t = case GM.termForm t of + Ok (xs,c,args) -> mkAbs xs (mkApp (map snd (reverse xs)++scope) c (map (mkExp scope) args)) + where + mkAbs xs t = foldr (\(b,v) -> C.EAbs (b2b b) (i2i v)) t xs + mkApp scope c args = case c of + Q _ c -> foldl C.EApp (C.EFun (i2i c)) args + QC _ c -> foldl C.EApp (C.EFun (i2i c)) args + Vr x -> case lookup x (zip scope [0..]) of + Just i -> foldl C.EApp (C.EVar i) args + Nothing -> foldl C.EApp (C.EMeta 0) args + EInt i -> C.ELit (C.LInt i) + EFloat f -> C.ELit (C.LFlt f) + K s -> C.ELit (C.LStr s) + Meta i -> C.EMeta i + _ -> C.EMeta 0 + +mkPatt scope p = + case p of + A.PP _ c ps -> let (scope',ps') = mapAccumL mkPatt scope ps + in (scope',C.PApp (i2i c) ps') + A.PV x -> (x:scope,C.PVar (i2i x)) + A.PW -> ( scope,C.PWild) + A.PInt i -> ( scope,C.PLit (C.LInt i)) + A.PFloat f -> ( scope,C.PLit (C.LFlt f)) + A.PString s -> ( scope,C.PLit (C.LStr s)) + + +mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo]) +mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty + in if x == identW + then ( scope,(b2b bt,i2i x,ty')) + else (x:scope,(b2b bt,i2i x,ty'))) scope 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 (BS.last s) -> + C.V ((read . BS.unpack . snd . BS.spanEnd isDigit) 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.Alt (strings u) (strings v) | (u,v) <- tvs]) + _ -> prtTrace tr $ C.S [C.K (C.KS (render (A.ppTerm Unqualified 0 tr <+> int 66662)))] ---- for debugging + where + mkLab (LIdent l) = case BS.unpack 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 PGF-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) + _ | Just i <- GM.isTypeInts pt -> C.R $ replicate (fromInteger i) $ mkCType vt + + Sort s | s == cStr -> C.S [] --- Str only + _ | Just i <- GM.isTypeInts t -> 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 $ showIdent (label2ident 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 s | s == cStr -> return $ C.S [] + _ -> return $ + C.FV $ map (kks . filter showable . render . ppTerm Unqualified 0) $ + 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.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs poss): + [(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] [] (sorted2tree js) poss) + | (c,(fs,js)) <- cncs] + where + poss = emptyBinTree -- positions no longer needed + mos = M.modules cg + adefs = sorted2tree $ sortIds $ + predefADefs ++ Look.allOrigInfos cg abs + predefADefs = + [(c, AbsCat (Just []) Nothing) | c <- [cFloat,cInt,cString]] + aflags = + concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo] + + cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs] + concr la = (flags, + sortIds (predefCDefs ++ jments)) where + jments = Look.allOrigInfos cg la + flags = concatOptions + [M.flags mo | + (i,mo) <- mos, M.isModCnc mo, + Just r <- [lookup i (M.allExtendSpecs cg la)]] + + predefCDefs = + [(c, CncCat (Just GM.defLinType) Nothing Nothing) | c <- [cInt,cFloat,cString]] + + sortIds = sortBy (\ (f,_) (g,_) -> compare 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.modules cg, + lang <- case M.allConcretes cg abs of + [] -> [abs] -- to make pgf nonempty even when there are no concretes + cncs -> cncs, + let mo = errVal + (error (render (text "no module found for" <+> A.ppIdent lang))) $ M.lookupModule cg lang + ] + +-- translate tables and records to arrays, parameters and labels to indices + +canon2canon :: Options -> Ident -> SourceGrammar -> SourceGrammar +canon2canon opts abs cg0 = + (recollect . map cl2cl . repartition abs . purgeGrammar abs) cg0 + 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,mo) = (c, M.replaceJudgements mo $ mapTree f2 (M.jments mo)) + + j2j cg (f,j) = + let debug = if verbAtLeast opts Verbose then trace ("+ " ++ showIdent f) else id in + case j of + CncFun x (Just tr) z -> CncFun x (Just (debug (t2t (unfactor cg0 tr)))) z + CncCat (Just ty) (Just x) y -> CncCat (Just (ty2ty ty)) (Just (t2t (unfactor cg0 x))) y + _ -> j + where + cg1 = cg + t2t = term2term f cg1 pv + ty2ty = type2type cg1 pv + pv@(labels,untyps,typs) = trs $ paramValues cg1 + + 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] + _ -> GM.composSafeOp unfac t + where + unfac = unfactor gr + vals = err error id . Look.allParamValues gr + restore x u t = case t of + Vr y | y == x -> u + _ -> GM.composSafeOp (restore x u) t + + -- flatten record arguments of param constructors + p2p (f,j) = case j of + ResParam (Just ps) (Just vs) -> + ResParam (Just [(c,concatMap unRec cont) | (c,cont) <- ps]) (Just (map unrec vs)) + _ -> j + unRec (bt,x,ty) = case ty of + RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (Explicit,identW,typ)] + _ -> [(bt,x,ty)] + unrec t = case t of + App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs] + _ -> GM.composSafeOp unrec t + + +---- + trs v = traceD (render (tr v)) v + + tr (labels,untyps,typs) = + (text "LABELS:" <+> + vcat [A.ppIdent c <> char '.' <> hsep (map A.ppLabel l) <+> char '=' <+> text (show i) | ((c,l),i) <- Map.toList labels]) $$ + (text "UNTYPS:" <+> + vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show i) | (t,i) <- Map.toList untyps]) $$ + (text "TYPS: " <+> + vcat [A.ppTerm Unqualified 0 t <+> char '=' <+> text (show (Map.assocs i)) | (t,i) <- Map.toList typs]) +---- + +purgeGrammar :: Ident -> SourceGrammar -> SourceGrammar +purgeGrammar abstr gr = + (M.MGrammar . list . filter complete . purge . M.modules) gr + where + list ms = traceD (render (text "MODULES" <+> hsep (punctuate comma (map (ppIdent . 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) = M.isCompleteModule m --- not . isIncompleteCanon + +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 (Just ty0) _ _)) <- jments, + ty <- typsFrom ty0 + ] ++ [ + Q m ty | + (m,(ty,ResParam _ _)) <- jments + ] ++ [ty | + (_,(_,CncFun _ (Just 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 = (if isParam ty then (ty:) else id) $ case ty of + Table p t -> typsFrom p ++ typsFrom t + RecType ls -> concat [typsFrom t | (_, t) <- ls] + _ -> [] + + isParam ty = case ty of + Q _ _ -> True + QC _ _ -> True + RecType rs -> all isParam (map snd rs) + _ -> False + + 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 + + mods = traceD (render (hsep (map (ppIdent . fst) ms))) ms where ms = M.modules cgr + + jments = + [(m,j) | (m,mo) <- mods, 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 = + [(cat,[f | let RecType fs = GM.defLinType, f <- fs]) | cat <- [cInt,cFloat, cString]] ++ + reverse ---- TODO: really those lincats that are reached + ---- reverse is enough to expel overshadowed ones... + [(cat,ls) | (_,(cat,CncCat (Just ty) _ _)) <- jments, + RecType ls <- [unlockTy ty]] + 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 :: Ident -> SourceGrammar -> ParamEnv -> Term -> Term +term2term fun 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..] (GM.sortRec (unlock rs))] + P t l -> r2r tr + + T (TWild _) _ -> error $ (render (text "wild" <+> ppTerm Qualified 0 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 fun 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: + comp t = errVal t $ Compute.computeConcreteRec cgr 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 $ (BS.pack (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 $ render (text "doVar1" <+> A.ppTerm Unqualified 0 ty) + _ -> error $ render (text "doVar2" <+> A.ppTerm Unqualified 0 tr <+> text (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 (render (A.ppTerm Unqualified 0 tr <+> prtTrace tr (int 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 = BS.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] -> let msg = render (text "DEBUG" <+> ppIdent fun <> text ": error in valNum" <+> ppTerm Qualified 0 tr) in + trace msg $ error (showIdent fun) + _ -> 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 (BS.pack ("_" ++ 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 $ GM.sortRec [(l, unlockTy t) | (l,t) <- ls, notlock (l,t)] + _ -> GM.composSafeOp unlockTy ty + + +prtTrace tr n = + trace (render (text "-- INTERNAL COMPILER ERROR" <+> A.ppTerm Unqualified 0 tr $$ text (show n))) n +prTrace tr n = trace (render (text "-- OBSERVE" <+> A.ppTerm Unqualified 0 tr <+> text (show n) <+> text (show tr))) n + + +-- | 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 -> M.MGrammar i a -> i -> [i] +requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where + exts = M.allExtends gr c + ops = if isSingle + then map fst (M.modules gr) + else iterFix (concatMap more) $ exts + more i = errVal [] $ do + m <- M.lookupModule gr i + return $ M.extends m ++ [o | o <- map M.openedModule (M.opens m)] + notReuse i = errVal True $ do + m <- M.lookupModule gr i + return $ M.isModRes m -- to exclude reused Cnc and Abs from required diff --git a/src/compiler/GF/Compile/ModDeps.hs b/src/compiler/GF/Compile/ModDeps.hs new file mode 100644 index 000000000..1e689aabc --- /dev/null +++ b/src/compiler/GF/Compile/ModDeps.hs @@ -0,0 +1,145 @@ +---------------------------------------------------------------------- +-- | +-- 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.Printer +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 :: [SourceModule] -> 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 = test [n | OQualif n v <- opens mo, n /= v] + 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 :: [SourceModule] -> Err Dependencies +moduleDeps ms = mapM deps ms where + deps (c,m) = errIn ("checking dependencies of module" +++ prt c) $ 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 + (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 + _ -> case mt of + MTResource -> 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 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 <- lookupModule gr i + return $ extends m ++ [o | o <- map openedModule (opens m)] + notReuse i = errVal True $ do + m <- lookupModule 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/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs new file mode 100644 index 000000000..2c556b36f --- /dev/null +++ b/src/compiler/GF/Compile/Optimize.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE PatternGuards #-} +---------------------------------------------------------------------- +-- | +-- 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.Printer +import GF.Grammar.Macros +import GF.Grammar.Lookup +import GF.Grammar.Predef +import GF.Compile.Refresh +import GF.Compile.Concrete.Compute +import GF.Compile.CheckGrammar +import GF.Compile.Update + +import GF.Data.Operations +import GF.Infra.CheckM +import GF.Infra.Option + +import Control.Monad +import Data.List +import qualified Data.Set as Set +import Text.PrettyPrint +import Debug.Trace +import qualified Data.ByteString.Char8 as BS + + +-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005. + +optimizeModule :: Options -> [SourceModule] -> SourceModule -> Err SourceModule +optimizeModule opts ms m@(name,mi) + | mstatus mi == MSComplete = do + ids <- topoSortJments m + mi <- foldM updateEvalInfo mi ids + return (name,mi) + | otherwise = return m + where + oopts = opts `addOptions` flagsModule m + + updateEvalInfo mi (i,info) = do + info' <- evalInfo oopts ms (name,mi) i info + return (updateModule mi i info') + +evalInfo :: Options -> [SourceModule] -> SourceModule -> Ident -> Info -> Err Info +evalInfo opts ms m c info = do + + (if verbAtLeast opts Verbose then trace (" " ++ showIdent c) else id) return () + + errIn ("optimizing " ++ showIdent c) $ case info of + + CncCat ptyp pde ppr -> do + pde' <- case (ptyp,pde) of + (Just typ, Just de) -> do + de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de + return (Just (factor param c 0 de)) + (Just typ, Nothing) -> do + de <- mkLinDefault gr typ + de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de + return (Just (factor param c 0 de)) + _ -> return pde -- indirection + + ppr' <- liftM Just $ evalPrintname gr c ppr (Just $ K $ showIdent c) + + return (CncCat ptyp pde' ppr') + + CncFun (mt@(Just (_,cont,val))) pde ppr -> --trace (prt c) $ + eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do + pde' <- case pde of + Just de -> do de <- partEval opts gr (cont,val) de + return (Just (factor param c 0 de)) + Nothing -> return pde + ppr' <- liftM Just $ evalPrintname gr c ppr pde' + return $ CncFun mt pde' ppr' -- only cat in type actually needed + + ResOper pty pde + | OptExpand `Set.member` optim -> do + pde' <- case pde of + Just de -> do de <- computeConcrete gr de + return (Just (factor param c 0 de)) + Nothing -> return Nothing + return $ ResOper pty pde' + + _ -> return info + where + gr = MGrammar (m : ms) + optim = flag optOptimizations opts + param = OptParametrize `Set.member` optim + eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon)) + +-- | the main function for compiling linearizations +partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term +partEval opts gr (context, val) trm = errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $ do + let vars = map (\(bt,x,t) -> x) context + args = map Vr vars + subst = [(v, Vr v) | v <- vars] + trm1 = mkApp trm args + trm2 <- computeTerm gr subst trm1 + trm3 <- if rightType trm2 + then computeTerm gr subst trm2 + else recordExpand val trm2 >>= computeTerm gr subst + return $ mkAbs [(Explicit,v) | v <- vars] trm3 + where + -- don't eta expand records of right length (correct by type checking) + rightType (R rs) = case val of + RecType ts -> length rs == length ts + _ -> False + rightType _ = 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 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 = liftM (Abs Explicit varStr) $ mkDefField typ + where + mkDefField typ = case typ of + Table p t -> do + t' <- mkDefField t + let T _ cs = mkWildCases t' + return $ T (TWild p) cs + Sort s | s == cStr -> return $ Vr varStr + QC q p -> do vs <- lookupParamValues gr q p + case vs of + v:_ -> return v + _ -> Bad (render (text "no parameter values given to type" <+> ppIdent p)) + RecType r -> do + let (ls,ts) = unzip r + ts <- mapM mkDefField ts + return $ R (zipWith assign ls ts) + _ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val + _ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 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 -> Maybe Term -> Maybe Term -> Err Term +evalPrintname gr c ppr lin = + case ppr of + Just pr -> comp pr + Nothing -> case lin of + Just t -> return $ K $ clean $ render (ppTerm Unqualified 0 (oneBranch t)) + Nothing -> return $ K $ showIdent 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 + + +-- do even more: factor parametric branches + +factor :: Bool -> Ident -> Int -> Term -> Term +factor param c i t = + case t of + T (TComp ty) cs -> factors ty [(p, factor param c (i+1) v) | (p, v) <- cs] + _ -> composSafeOp (factor param c i) t + where + factors ty pvs0 + | not param = V ty (map snd pvs0) + factors ty [] = V ty [] + factors ty pvs0@[(p,v)] = V ty [v] + factors ty pvs0@(pv:pvs) = + let t = mkFun pv + ts = map mkFun pvs + in if all (==t) ts + then T (TTyped ty) (mkCases t) + else V ty (map snd pvs0) + + --- we hope this will be fresh and don't check... in GFC would be safe + qvar = identC (BS.pack ("q_" ++ showIdent c ++ "__" ++ show i)) + + mkFun (patt, val) = replace (patt2term patt) (Vr qvar) val + mkCases t = [(PV qvar, t)] + +-- 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 _ _ | trm == old -> new + R _ | trm == old -> new + App x y -> App (replace old new x) (replace old new y) + _ -> composSafeOp (replace old new) trm diff --git a/src/compiler/GF/Compile/OptimizeGFCC.hs b/src/compiler/GF/Compile/OptimizeGFCC.hs new file mode 100644 index 000000000..2a218e1bb --- /dev/null +++ b/src/compiler/GF/Compile/OptimizeGFCC.hs @@ -0,0 +1,121 @@ +module GF.Compile.OptimizeGFCC where + +import PGF.CId +import PGF.Data +import PGF.Macros + +import GF.Data.Operations + +import Data.List +import qualified Data.Map as Map + + +-- back-end optimization: +-- suffix analysis followed by common subexpression elimination + +optPGF :: PGF -> PGF +optPGF = cseOptimize . suffixOptimize + +suffixOptimize :: PGF -> PGF +suffixOptimize = mapConcretes opt + where + opt cnc = cnc { + lins = Map.map optTerm (lins cnc), + lindefs = Map.map optTerm (lindefs cnc), + printnames = Map.map optTerm (printnames cnc) + } + +cseOptimize :: PGF -> PGF +cseOptimize = mapConcretes subex + +-- 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 = err error id $ 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 = mkCId $ "_" ++ 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/compiler/GF/Compile/PGFPretty.hs b/src/compiler/GF/Compile/PGFPretty.hs new file mode 100644 index 000000000..679714db5 --- /dev/null +++ b/src/compiler/GF/Compile/PGFPretty.hs @@ -0,0 +1,93 @@ +-- | Print a part of a PGF grammar on the human-readable format used in +-- the paper "PGF: A Portable Run-Time Format for Type-Theoretical Grammars". +module GF.Compile.PGFPretty (prPGFPretty, prPMCFGPretty) where + +import PGF.CId +import PGF.Data +import PGF.Macros +import PGF.PMCFG + +import GF.Data.Operations + +import Data.Map (Map) +import qualified Data.Map as Map +import Text.PrettyPrint.HughesPJ + + +prPGFPretty :: PGF -> String +prPGFPretty pgf = render $ prAbs (abstract pgf) $$ prAll (prCnc (abstract pgf)) (concretes pgf) + +prPMCFGPretty :: PGF -> CId -> String +prPMCFGPretty pgf lang = render $ + case lookParser pgf lang of + Nothing -> empty + Just pinfo -> text "language" <+> ppCId lang $$ ppPMCFG pinfo + + +prAbs :: Abstr -> Doc +prAbs a = prAll prCat (cats a) $$ prAll prFun (funs a) + +prCat :: CId -> [Hypo] -> Doc +prCat c h | isLiteralCat c = empty + | otherwise = text "cat" <+> ppCId c + +prFun :: CId -> (Type,Int,[Equation]) -> Doc +prFun f (t,_,_) = text "fun" <+> ppCId f <+> text ":" <+> prType t + +prType :: Type -> Doc +prType t = parens (hsep (punctuate (text ",") (map ppCId cs))) <+> text "->" <+> ppCId c + where (cs,c) = catSkeleton t + + +-- FIXME: show concrete name +-- FIXME: inline opers first +prCnc :: Abstr -> CId -> Concr -> Doc +prCnc abstr name c = prAll prLinCat (lincats c) $$ prAll prLin (lins (expand c)) + where + prLinCat :: CId -> Term -> Doc + prLinCat c t | isLiteralCat c = empty + | otherwise = text "lincat" <+> ppCId c <+> text "=" <+> pr 0 t + where + pr p (R ts) = prec p 1 (hsep (punctuate (text " *") (map (pr 1) ts))) + pr _ (S []) = text "Str" + pr _ (C n) = text "Int_" <> text (show (n+1)) + + prLin :: CId -> Term -> Doc + prLin f t = text "lin" <+> ppCId f <+> text "=" <+> pr 0 t + where + pr :: Int -> Term -> Doc + pr p (R ts) = text "<" <+> hsep (punctuate (text ",") (map (pr 0) ts)) <+> text ">" + pr p (P t1 t2) = prec p 3 (pr 3 t1 <> text "!" <> pr 3 t2) + pr p (S ts) = prec p 2 (hsep (punctuate (text " ++") (map (pr 2) ts))) + pr p (K (KS t)) = doubleQuotes (text t) + pr p (V i) = text ("argv_" ++ show (i+1)) + pr p (C i) = text (show (i+1)) + pr p (FV ts) = prec p 1 (hsep (punctuate (text " |") (map (pr 1) ts))) + pr _ t = error $ "PGFPretty.prLin " ++ show t + +linCat :: Concr -> CId -> Term +linCat cnc c = Map.findWithDefault (error $ "lincat: " ++ showCId c) c (lincats cnc) + +prec :: Int -> Int -> Doc -> Doc +prec p m | p >= m = parens + | otherwise = id + +expand :: Concr -> Concr +expand cnc = cnc { lins = Map.map (f "") (lins cnc) } + where + -- FIXME: handle KP + f :: String -> Term -> Term + f w (R ts) = R (map (f w) ts) + f w (P t1 t2) = P (f w t1) (f w t2) + f w (S []) = S (if null w then [] else [K (KS w)]) + f w (S (t:ts)) = S (f w t : map (f "") ts) + f w (FV ts) = FV (map (f w) ts) + f w (W s t) = f (w++s) t + f w (K (KS t)) = K (KS (w++t)) + f w (F o) = f w (Map.findWithDefault (error $ "Bad oper: " ++ showCId o) o (opers cnc)) + f w t = t + +-- Utilities + +prAll :: (a -> b -> Doc) -> Map a b -> Doc +prAll p m = vcat [ p k v | (k,v) <- Map.toList m] \ No newline at end of file diff --git a/src/compiler/GF/Compile/ReadFiles.hs b/src/compiler/GF/Compile/ReadFiles.hs new file mode 100644 index 000000000..b96d3127b --- /dev/null +++ b/src/compiler/GF/Compile/ReadFiles.hs @@ -0,0 +1,220 @@ +---------------------------------------------------------------------- +-- | +-- 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.Compile.ReadFiles + ( getAllFiles,ModName,ModEnv,importsOfModule, + gfoFile,gfFile,isGFO,gf2gfo, + getOptionsFromFile) where + +import GF.Infra.UseIO +import GF.Infra.Option +import GF.Infra.Ident +import GF.Infra.Modules +import GF.Data.Operations +import GF.Grammar.Lexer +import GF.Grammar.Parser +import GF.Grammar.Grammar +import GF.Grammar.Binary + +import Control.Monad +import Data.Char +import Data.List +import Data.Maybe(isJust) +import qualified Data.ByteString.Char8 as BS +import qualified Data.Map as Map +import System.Time +import System.Directory +import System.FilePath +import Text.PrettyPrint + +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) + ioeIO $ putIfVerb opts $ "all modules:" +++ show [name | (name,_,_,_,_) <- ds] + return $ paths ds + where + -- construct list of paths to read + paths ds = concatMap mkFile ds + where + mkFile (f,st,gfTime,gfoTime,p) = + case st of + CSComp -> [p gfFile f] + CSRead | isJust gfTime -> [gf2gfo opts (p gfFile f)] + | otherwise -> [p gfoFile f] + CSEnv -> [] + + -- | 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,_,t1,_,_) <- ds, elem f imps && liftM2 (>=) t0 t1 /= Just True] + = (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 $ getFilePath ps (gfFile name) + case mb_gfFile of + Just gfFile -> do gfTime <- ioeIO $ getModificationTime gfFile + mb_gfoTime <- ioeIO $ catch (liftM Just $ getModificationTime (gf2gfo opts gfFile)) + (\_->return Nothing) + return (gfFile, Just gfTime, mb_gfoTime) + Nothing -> do mb_gfoFile <- ioeIO $ getFilePath (maybe id (:) (flag optGFODir opts) ps) (gfoFile name) + case mb_gfoFile of + Just gfoFile -> do gfoTime <- ioeIO $ getModificationTime gfoFile + return (gfoFile, Nothing, Just gfoTime) + Nothing -> ioeErr $ Bad (render (text "File" <+> text (gfFile name) <+> text "does not exist." $$ + text "searched in:" <+> vcat (map text ps))) + + + let mb_envmod = Map.lookup name env + (st,t) = selectFormat opts (fmap fst mb_envmod) gfTime gfoTime + + (mname,imps) <- case st of + CSEnv -> return (name, maybe [] snd mb_envmod) + CSRead -> ioeIO $ fmap importsOfModule (decodeModHeader ((if isGFO file then id else gf2gfo opts) file)) + CSComp -> do s <- ioeIO $ BS.readFile file + case runP pModHeader s of + Left (Pn l c,msg) -> ioeBad (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg) + Right mo -> return (importsOfModule mo) + ioeErr $ testErr (mname == name) + ("module name" +++ mname +++ "differs from file name" +++ name) + 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" + +gf2gfo :: Options -> FilePath -> FilePath +gf2gfo opts file = maybe (gfoFile (dropExtension file)) + (\dir -> dir gfoFile (dropExtension (takeFileName file))) + (flag optGFODir opts) + +-- 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 + (_,Just tgfo,Nothing) -> (CSRead,Just tgfo) -- source does not exist + _ -> (CSComp,Nothing) + where + fromComp = flag optRecomp opts == NeverRecomp + fromSrc = flag optRecomp opts == AlwaysRecomp + + +-- 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 :: SourceModule -> (ModName,[ModName]) +importsOfModule (m,mi) = (modName m,depModInfo mi []) + where + depModInfo mi = + depModType (mtype mi) . + depExtends (extend mi) . + depWith (mwith mi) . + depExDeps (mexdeps mi). + depOpens (opens mi) + + depModType (MTAbstract) xs = xs + depModType (MTResource) xs = xs + depModType (MTInterface) xs = xs + depModType (MTConcrete m2) xs = modName m2:xs + depModType (MTInstance m2) xs = modName m2:xs + + depExtends es xs = foldr depInclude xs es + + depWith (Just (m,_,is)) xs = modName m : depInsts is xs + depWith Nothing xs = xs + + depExDeps eds xs = map modName eds ++ xs + + depOpens os xs = foldr depOpen xs os + + depInsts is xs = foldr depInst xs is + + depInclude (m,_) xs = modName m:xs + + depOpen (OSimple n ) xs = modName n:xs + depOpen (OQualif _ n) xs = modName n:xs + + depInst (m,n) xs = modName m:modName n:xs + + modName = showIdent + +-- | options can be passed to the compiler by comments in @--#@, in the main file +getOptionsFromFile :: FilePath -> IOE Options +getOptionsFromFile file = do + s <- ioe $ catch (fmap Ok $ BS.readFile file) + (\_ -> return (Bad $ "File " ++ file ++ " does not exist")) + let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s + fs = map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls + ioeErr $ parseModuleOptions fs + +getFilePath :: [FilePath] -> String -> IO (Maybe FilePath) +getFilePath paths file = get paths + where + get [] = 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) diff --git a/src/compiler/GF/Compile/Refresh.hs b/src/compiler/GF/Compile/Refresh.hs new file mode 100644 index 000000000..04800fcce --- /dev/null +++ b/src/compiler/GF/Compile/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.Compile.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 b x t -> liftM2 (Abs b) (refVarPlus x) (refresh t) + + Prod b x a t -> do + a' <- refresh a + x' <- refVar x + t' <- refresh t + return $ Prod b x' a' t' + + 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,mo) + | isModCnc mo || isModRes mo = do + (k',js') <- foldM refreshRes (k,[]) $ tree2list $ jments mo + return (k', (i, replaceJudgements mo (buildTree js')) : ms) + | otherwise = return (k, mi:ms) + where + refreshRes (k,cs) ci@(c,info) = case info of + ResOper ptyp (Just trm) -> do ---- refresh ptyp + (k',trm') <- refreshTermKN k trm + return $ (k', (c, ResOper ptyp (Just trm')):cs) + ResOverload os tyts -> do + (k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $ + appSTM (mapPairsM refresh tyts) (initIdStateN k) + return $ (k', (c, ResOverload os tyts'):cs) + CncCat mt (Just trm) pn -> do ---- refresh mt, pn + (k',trm') <- refreshTermKN k trm + return $ (k', (c, CncCat mt (Just trm') pn):cs) + CncFun mt (Just trm) pn -> do ---- refresh pn + (k',trm') <- refreshTermKN k trm + return $ (k', (c, CncFun mt (Just trm') pn):cs) + _ -> return (k, ci:cs) + diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs new file mode 100644 index 000000000..30616b4cb --- /dev/null +++ b/src/compiler/GF/Compile/Rename.hs @@ -0,0 +1,313 @@ +---------------------------------------------------------------------- +-- | +-- 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 ( + renameSourceTerm, + renameModule + ) where + +import GF.Grammar.Grammar +import GF.Grammar.Values +import GF.Grammar.Predef +import GF.Infra.Modules +import GF.Infra.Ident +import GF.Infra.CheckM +import GF.Grammar.Macros +import GF.Grammar.Printer +import GF.Grammar.Lookup +import GF.Grammar.Printer +import GF.Data.Operations + +import Control.Monad +import Data.List (nub) +import Text.PrettyPrint + +-- | this gives top-level access to renaming term input in the cc command +renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term +renameSourceTerm g m t = do + mo <- checkErr $ lookupModule g m + status <- buildStatus g m mo + renameTerm status [] t + +renameModule :: [SourceModule] -> SourceModule -> Check SourceModule +renameModule ms (name,mo) = checkIn (text "renaming module" <+> ppIdent name) $ do + let js1 = jments mo + status <- buildStatus (MGrammar ms) name mo + js2 <- checkMap (renameInfo mo status) js1 + return (name, mo {opens = map forceQualif (opens mo), jments = js2}) + +type Status = (StatusTree, [(OpenSpec Ident, StatusTree)]) + +type StatusTree = BinTree Ident StatusInfo + +type StatusInfo = Ident -> Term + +renameIdentTerm :: Status -> Term -> Check Term +renameIdentTerm env@(act,imps) t = + checkIn (text "atomic term" <+> ppTerm Qualified 0 t $$ text "given" <+> hsep (punctuate comma (map (ppIdent . fst) qualifs))) $ + case t of + Vr c -> ident predefAbs c + Cn c -> ident (\_ s -> checkError s) c + Q m' c | m' == cPredef {- && isInPredefined c -} -> return t + Q m' c -> do + m <- checkErr (lookupErr m' qualifs) + f <- lookupTree showIdent c m + return $ f c + QC m' c | m' == cPredef {- && isInPredefined c -} -> return t + QC m' c -> do + m <- checkErr (lookupErr m' qualifs) + f <- lookupTree showIdent 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 + | isPredefCat c = return $ Q cPredefAbs c + | otherwise = checkError s + + ident alt c = case lookupTree showIdent c act of + Ok f -> return $ f c + _ -> case lookupTreeManyAll showIdent opens c of + [f] -> return $ f c + [] -> alt c (text "constant not found:" <+> ppIdent c) + fs -> case nub [f c | f <- fs] of + [tr] -> return tr + ts@(t:_) -> do checkWarn (text "conflict" <+> hsep (punctuate comma (map (ppTerm Qualified 0) ts))) + return t + -- a warning will be generated in CheckGrammar, and the head returned + -- in next V: + -- Bad $ "conflicting imports:" +++ unwords (map prt ts) + +info2status :: Maybe Ident -> (Ident,Info) -> StatusInfo +info2status mq (c,i) = case i of + AbsFun _ _ Nothing -> 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 -> Check Status +buildStatus gr c mo = let mo' = self2status c mo in do + let gr1 = MGrammar ((c,mo) : modules gr) + ops = [OSimple e | e <- allExtends gr1 c] ++ opens mo + mods <- checkErr $ mapM (lookupModule gr1 . openedModule) ops + let sts = map modInfo2status $ zip ops mods + return $ if isModCnc mo + 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,mo) = (o,tree2status o (jments mo)) + +self2status :: Ident -> SourceModInfo -> StatusTree +self2status c m = mapTree (info2status (Just c)) (jments m) + +forceQualif o = case o of + OSimple i -> OQualif i i + OQualif _ i -> OQualif i i + +renameInfo :: SourceModInfo -> Status -> Ident -> Info -> Check Info +renameInfo mo status i info = checkIn + (text "renaming definition of" <+> ppIdent i <+> ppPosition mo i) $ + case info of + AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco) + (renPerh (mapM rent) pfs) + AbsFun pty pa ptr -> liftM3 AbsFun (ren pty) (return pa) (renPerh (mapM (renameEquation status [])) ptr) + ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr) + ResOverload os tysts -> + liftM (ResOverload os) (mapM (pairM rent) tysts) + + ResParam (Just pp) m -> do + pp' <- mapM (renameParam status) pp + return (ResParam (Just pp') m) + ResValue t -> do + t <- rent t + return (ResValue 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 (Just t) = liftM Just $ ren t +renPerh ren Nothing = return Nothing + +renameTerm :: Status -> [Ident] -> Term -> Check Term +renameTerm env vars = ren vars where + ren vs trm = case trm of + Abs b x t -> liftM (Abs b x) (ren (x:vs) t) + Prod bt x a b -> liftM2 (Prod bt 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 + 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 -- Here we have $r.l$ and this is ambiguous it could be either + -- record projection from variable or constant $r$ or qualified expression with module $r$ + | elem r vs -> return trm -- try var proj first .. + | otherwise -> checks [ renid (Q r (label2ident l)) -- .. and qualified expression second. + , renid t >>= \t -> return (P t l) -- try as a constant at the end + , checkError (text "unknown qualified constant" <+> ppTerm Unqualified 0 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 -> Check (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 + _ -> checkError (text "unresolved pattern" <+> ppPatt Unqualified 0 patt) + + PC c ps -> do + c' <- renid $ Cn c + case c' of + QC m c -> do psvss <- mapM renp ps + let (ps,vs) = unzip psvss + return (PP m c ps, concat vs) + Q _ _ -> checkError (text "data constructor expected but" <+> ppTerm Qualified 0 c' <+> text "is found instead") + _ -> checkError (text "unresolved data constructor" <+> ppTerm Qualified 0 c') + + PP p c ps -> do + (QC p' c') <- renid (QC p c) + psvss <- mapM renp ps + let (ps',vs) = unzip psvss + return (PP p' c' ps', concat vs) + + PM p c -> do + x <- renid (Q p c) + (p',c') <- case x of + (Q p' c') -> return (p',c') + _ -> checkError (text "not a pattern macro" <+> ppPatt Qualified 0 patt) + return (PM p' c', []) + + PV x -> checks [ renid (Vr x) >>= \t' -> case t' of + QC m c -> return (PP m c [],[]) + _ -> checkError (text "not a constructor") + , 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) -> Check (Ident, Context) +renameParam env (c,co) = do + co' <- renameContext env co + return (c,co') + +renameContext :: Status -> Context -> Check Context +renameContext b = renc [] where + renc vs cont = case cont of + (bt,x,t) : xts + | isWildIdent x -> do + t' <- ren vs t + xts' <- renc vs xts + return $ (bt,x,t') : xts' + | otherwise -> do + t' <- ren vs t + let vs' = x:vs + xts' <- renc vs' xts + return $ (bt,x,t') : xts' + _ -> return cont + ren = renameTerm b + +-- | vars not needed in env, since patterns always overshadow old vars +renameEquation :: Status -> [Ident] -> Equation -> Check 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/compiler/GF/Compile/SubExOpt.hs b/src/compiler/GF/Compile/SubExOpt.hs new file mode 100644 index 000000000..c7dbb5d3d --- /dev/null +++ b/src/compiler/GF/Compile/SubExOpt.hs @@ -0,0 +1,142 @@ +---------------------------------------------------------------------- +-- | +-- Module : SubExOpt +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- This module implements a simple common subexpression elimination +-- for .gfo 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 +-- +----------------------------------------------------------------------------- + +module GF.Compile.SubExOpt (subexpModule,unsubexpModule) where + +import GF.Grammar.Grammar +import GF.Grammar.Lookup +import GF.Infra.Ident +import qualified GF.Grammar.Macros as C +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 qualified Data.ByteString.Char8 as BS +import Data.List + +subexpModule :: SourceModule -> SourceModule +subexpModule (n,mo) = errVal (n,mo) $ do + let ljs = tree2list (M.jments mo) + (tree,_) <- appSTM (getSubtermsMod n ljs) (Map.empty,0) + js2 <- liftM buildTree $ addSubexpConsts n tree $ ljs + return (n,M.replaceJudgements mo js2) + +unsubexpModule :: SourceModule -> SourceModule +unsubexpModule sm@(i,mo) + | hasSub ljs = (i,M.replaceJudgements mo (rebuild (map unparInfo ljs))) + | otherwise = sm + where + ljs = tree2list (M.jments mo) + + -- perform this iff the module has opers + hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs] + unparInfo (c,info) = case info of + CncFun xs (Just t) m -> [(c, CncFun xs (Just (unparTerm t)) m)] + ResOper (Just (EInt 8)) _ -> [] -- subexp-generated opers + ResOper pty (Just t) -> [(c, ResOper pty (Just (unparTerm t)))] + _ -> [(c,info)] + unparTerm t = case t of + Q m c | isOperIdent c -> --- name convention of subexp opers + errVal t $ liftM unparTerm $ lookupResDef gr m c + _ -> C.composSafeOp unparTerm t + gr = M.MGrammar [sm] + 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 (Just trm) pn -> do + trm' <- recomp f trm + return (f,CncFun xs (Just trm') pn) + ResOper ty (Just trm) -> do + trm' <- recomp f trm + return (f,ResOper ty (Just trm')) + _ -> return (f,def) + recomp f t = case Map.lookup t tree of + Just (_,id) | operIdent id /= f -> return $ Q mo (operIdent id) + _ -> C.composOp (recomp f) t + + list = Map.toList tree + + oper id trm = (operIdent id, ResOper (Just (EInt 8)) (Just 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 (Just trm) pn -> do + get trm + return $ fi + ResOper ty (Just 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 + +operIdent :: Int -> Ident +operIdent i = identC (operPrefix `BS.append` (BS.pack (show i))) --- + +isOperIdent :: Ident -> Bool +isOperIdent id = BS.isPrefixOf operPrefix (ident2bs id) + +operPrefix = BS.pack ("A''") diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs new file mode 100644 index 000000000..1e39a2e03 --- /dev/null +++ b/src/compiler/GF/Compile/Update.hs @@ -0,0 +1,226 @@ +---------------------------------------------------------------------- +-- | +-- 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 (buildAnyTree, extendModule, rebuildModule) where + +import GF.Infra.Ident +import GF.Grammar.Grammar +import GF.Grammar.Printer +import GF.Grammar.Lookup +import GF.Infra.Modules +import GF.Infra.Option + +import GF.Data.Operations + +import Data.List +import qualified Data.Map as Map +import Control.Monad +import Text.PrettyPrint + +-- | combine a list of definitions into a balanced binary search tree +buildAnyTree :: Ident -> [(Ident,Info)] -> Err (BinTree Ident Info) +buildAnyTree m = go Map.empty + where + go map [] = return map + go map ((c,j):is) = do + case Map.lookup c map of + Just i -> case unifyAnyInfo m i j of + Ok k -> go (Map.insert c k map) is + Bad _ -> fail $ render (text "cannot unify the informations" $$ + nest 4 (ppJudgement Qualified (c,i)) $$ + text "and" $+$ + nest 4 (ppJudgement Qualified (c,j)) $$ + text "in module" <+> ppIdent m) + Nothing -> go (Map.insert c j map) is + +extendModule :: SourceGrammar -> SourceModule -> Err SourceModule +extendModule gr (name,m) + ---- 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 + | mstatus m == MSIncomplete && isModCnc m = return (name,m) + | otherwise = do m' <- foldM extOne m (extend m) + return (name,m') + where + extOne mo (n,cond) = do + m0 <- lookupModule gr n + + -- test that the module types match, and find out if the old is complete + testErr (sameMType (mtype m) (mtype mo)) + ("illegal extension type to module" +++ showIdent name) + + let isCompl = isCompleteModule m0 + + -- build extension in a way depending on whether the old module is complete + js1 <- extendMod gr isCompl (n, isInherited cond) name (jments m0) (jments mo) + + -- if incomplete, throw away extension information + return $ + if isCompl + then mo {jments = js1} + else mo {extend = filter ((/=n) . fst) (extend mo) + ,mexdeps= nub (n : mexdeps mo) + ,jments = js1 + } + +-- | rebuilding instance + interface, and "with" modules, prior to renaming. +-- AR 24/10/2003 +rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule +rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do +---- 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 mw of + + -- add the information given in interface into an instance module + Nothing -> do + testErr (null is || mstatus mi == MSIncomplete) + ("module" +++ showIdent i +++ + "has open interfaces and must therefore be declared incomplete") + case mt of + MTInstance i0 -> do + m1 <- lookupModule gr i0 + testErr (isModRes m1) ("interface expected instead of" +++ showIdent i0) + js' <- extendMod gr False (i0,const True) i (jments m1) (jments mi) + --- to avoid double inclusions, in instance I of I0 = J0 ** ... + case extends mi of + [] -> return $ replaceJudgements mi js' + j0s -> do + m0s <- mapM (lookupModule gr) j0s + let notInM0 c _ = all (not . isInBinTree c . jments) m0s + let js2 = filterBinTree notInM0 js' + return $ (replaceJudgements mi js2) + {positions = Map.union (positions m1) (positions mi)} + _ -> return mi + + -- add the instance opens to an incomplete module "with" instances + Just (ext,incl,ops) -> do + let (infs,insts) = unzip ops + let stat' = ifNull MSComplete (const MSIncomplete) + [i | i <- is, notElem i infs] + testErr (stat' == MSComplete || stat == MSIncomplete) + ("module" +++ showIdent i +++ "remains incomplete") + ModInfo mt0 _ fs me' _ ops0 _ js ps0 <- lookupModule gr ext + let ops1 = nub $ + ops_ ++ -- N.B. js has been name-resolved already + [OQualif i j | (i,j) <- ops] ++ + [o | o <- ops0, notElem (openedModule o) infs] ++ + [OQualif i i | i <- insts] ++ + [OSimple i | i <- insts] + + --- check if me is incomplete + let fs1 = fs `addOptions` fs_ -- new flags have priority + let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c] + let js1 = buildTree (tree2list js_ ++ js0) + let ps1 = Map.union ps_ ps0 + let med1= nub (ext : infs ++ insts ++ med_) + return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 js1 ps1 + + return (i,mi') + +-- | 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 :: SourceGrammar -> + Bool -> (Ident,Ident -> Bool) -> Ident -> + BinTree Ident Info -> BinTree Ident Info -> + Err (BinTree Ident Info) +extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old + where + try new (c,i) + | not (cond c) = return new + | otherwise = case Map.lookup c new of + Just j -> case unifyAnyInfo name i j of + Ok k -> return $ updateTree (c,k) new + Bad _ -> do (base,j) <- case j of + AnyInd _ m -> lookupOrigInfo gr m c + _ -> return (base,j) + (name,i) <- case i of + AnyInd _ m -> lookupOrigInfo gr m c + _ -> return (name,i) + fail $ render (text "cannot unify the information" $$ + nest 4 (ppJudgement Qualified (c,i)) $$ + text "in module" <+> ppIdent name <+> text "with" $$ + nest 4 (ppJudgement Qualified (c,j)) $$ + text "in module" <+> ppIdent base) + Nothing-> if isCompl + then return $ updateTree (c,indirInfo name i) new + else return $ updateTree (c,i) new + + indirInfo :: Ident -> Info -> Info + indirInfo n info = AnyInd b n' where + (b,n') = case info of + ResValue _ -> (True,n) + ResParam _ _ -> (True,n) + AbsFun _ _ Nothing -> (True,n) + AnyInd b k -> (b,k) + _ -> (False,n) ---- canonical in Abs + +unifyAnyInfo :: Ident -> Info -> Info -> Err Info +unifyAnyInfo m i j = case (i,j) of + (AbsCat mc1 mf1, AbsCat mc2 mf2) -> + liftM2 AbsCat (unifMaybe mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs + (AbsFun mt1 ma1 md1, AbsFun mt2 ma2 md2) -> + liftM3 AbsFun (unifMaybe mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) -- adding defs + + (ResParam mt1 mv1, ResParam mt2 mv2) -> + liftM2 ResParam (unifMaybe mt1 mt2) (unifMaybe mv1 mv2) + (ResValue t1, ResValue t2) + | t1==t2 -> return (ResValue t1) + | otherwise -> fail "" + (_, ResOverload ms t) | elem m ms -> + return $ ResOverload ms t + (ResOper mt1 m1, ResOper mt2 m2) -> + liftM2 ResOper (unifMaybe mt1 mt2) (unifMaybe m1 m2) + + (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> + liftM3 CncCat (unifMaybe mc1 mc2) (unifMaybe mf1 mf2) (unifMaybe mp1 mp2) + (CncFun m mt1 md1, CncFun _ mt2 md2) -> + liftM2 (CncFun m) (unifMaybe mt1 mt2) (unifMaybe md1 md2) ---- adding defs + + (AnyInd b1 m1, AnyInd b2 m2) -> do + testErr (b1 == b2) $ "indirection status" + testErr (m1 == m2) $ "different sources of indirection" + return i + + _ -> fail "informations" + +-- | this is what happens when matching two values in the same module +unifMaybe :: Eq a => Maybe a -> Maybe a -> Err (Maybe a) +unifMaybe Nothing Nothing = return Nothing +unifMaybe (Just p1) Nothing = return (Just p1) +unifMaybe Nothing (Just p2) = return (Just p2) +unifMaybe (Just p1) (Just p2) + | p1==p2 = return (Just p1) + | otherwise = fail "" + +unifAbsArrity :: Maybe Int -> Maybe Int -> Err (Maybe Int) +unifAbsArrity Nothing Nothing = return Nothing +unifAbsArrity (Just a ) Nothing = return (Just a ) +unifAbsArrity Nothing (Just a ) = return (Just a ) +unifAbsArrity (Just a1) (Just a2) + | a1==a2 = return (Just a1) + | otherwise = fail "" + +unifAbsDefs :: Maybe [Equation] -> Maybe [Equation] -> Err (Maybe [Equation]) +unifAbsDefs Nothing Nothing = return Nothing +unifAbsDefs (Just _ ) Nothing = fail "" +unifAbsDefs Nothing (Just _ ) = fail "" +unifAbsDefs (Just xs) (Just ys) = return (Just (xs ++ ys)) + +unifConstrs :: Maybe [Term] -> Maybe [Term] -> Err (Maybe [Term]) +unifConstrs p1 p2 = case (p1,p2) of + (Nothing, _) -> return p2 + (_, Nothing) -> return p1 + (Just bs, Just ds) -> return $ Just $ bs ++ ds diff --git a/src/compiler/GF/Data/Assoc.hs b/src/compiler/GF/Data/Assoc.hs new file mode 100644 index 000000000..f775319ea --- /dev/null +++ b/src/compiler/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/compiler/GF/Data/BacktrackM.hs b/src/compiler/GF/Data/BacktrackM.hs new file mode 100644 index 000000000..36317ebb6 --- /dev/null +++ b/src/compiler/GF/Data/BacktrackM.hs @@ -0,0 +1,86 @@ +---------------------------------------------------------------------- +-- | +-- 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, + -- * monad specific utilities + member, + cut, + -- * running the monad + foldBM, runBM, + foldSolutions, solutions, + foldFinalStates, finalStates, + + -- * reexport the 'MonadState' class + module Control.Monad.State.Class, + ) where + +import Data.List +import Control.Monad +import Control.Monad.State.Class + +---------------------------------------------------------------------- +-- 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 + +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 _ = mzero + +instance Functor (BacktrackM s) where + fmap f (BM m) = BM (\c s b -> m (\a s b -> c (f a) s b) s b) + +instance MonadPlus (BacktrackM s) where + mzero = BM (\c s b -> b) + (BM f) `mplus` (BM g) = BM (\c s b -> g c s $! f c s b) + +instance MonadState s (BacktrackM s) where + get = BM (\c s b -> c s s b) + put s = BM (\c _ b -> c () s b) + +-- * 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) + +cut :: BacktrackM s a -> BacktrackM s [(s,a)] +cut f = BM (\c s b -> c (runBM f s) s b) diff --git a/src/compiler/GF/Data/ErrM.hs b/src/compiler/GF/Data/ErrM.hs new file mode 100644 index 000000000..e8cea12d4 --- /dev/null +++ b/src/compiler/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/compiler/GF/Data/Graph.hs b/src/compiler/GF/Data/Graph.hs new file mode 100644 index 000000000..bfb289860 --- /dev/null +++ b/src/compiler/GF/Data/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.Data.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/compiler/GF/Data/Graphviz.hs b/src/compiler/GF/Data/Graphviz.hs new file mode 100644 index 000000000..411f76898 --- /dev/null +++ b/src/compiler/GF/Data/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.Data.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/compiler/GF/Data/MultiMap.hs b/src/compiler/GF/Data/MultiMap.hs new file mode 100644 index 000000000..e565f433b --- /dev/null +++ b/src/compiler/GF/Data/MultiMap.hs @@ -0,0 +1,47 @@ +module GF.Data.MultiMap where + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Prelude hiding (map) +import qualified Prelude + +type MultiMap k a = Map k (Set a) + +empty :: MultiMap k a +empty = Map.empty + +keys :: MultiMap k a -> [k] +keys = Map.keys + +elems :: MultiMap k a -> [a] +elems = concatMap Set.toList . Map.elems + +(!) :: Ord k => MultiMap k a -> k -> [a] +m ! k = Set.toList $ Map.findWithDefault Set.empty k m + +member :: (Ord k, Ord a) => k -> a -> MultiMap k a -> Bool +member k x m = x `Set.member` Map.findWithDefault Set.empty k m + +insert :: (Ord k, Ord a) => k -> a -> MultiMap k a -> MultiMap k a +insert k x m = Map.insertWith Set.union k (Set.singleton x) m + +insert' :: (Ord k, Ord a) => k -> a -> MultiMap k a -> Maybe (MultiMap k a) +insert' k x m | member k x m = Nothing -- FIXME: inefficient + | otherwise = Just (insert k x m) + +union :: (Ord k, Ord a) => MultiMap k a -> MultiMap k a -> MultiMap k a +union = Map.unionWith Set.union + +size :: MultiMap k a -> Int +size = sum . Prelude.map Set.size . Map.elems + +map :: (Ord a, Ord b) => (a -> b) -> MultiMap k a -> MultiMap k b +map f = Map.map (Set.map f) + +fromList :: (Ord k, Ord a) => [(k,a)] -> MultiMap k a +fromList xs = Map.fromListWith Set.union [(k, Set.singleton x) | (k,x) <- xs] + +toList :: MultiMap k a -> [(k,a)] +toList m = [(k,x) | (k,s) <- Map.toList m, x <- Set.toList s] \ No newline at end of file diff --git a/src/compiler/GF/Data/Operations.hs b/src/compiler/GF/Data/Operations.hs new file mode 100644 index 000000000..7b2afc9fe --- /dev/null +++ b/src/compiler/GF/Data/Operations.hs @@ -0,0 +1,374 @@ +---------------------------------------------------------------------- +-- | +-- 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, + lookupErr, + mapPairListM, mapPairsM, pairM, + singleton, mapsErr, mapsErrTree, + + -- ** checking + checkUnique, + + -- * binary search trees; now with FiniteMap + BinTree, emptyBinTree, isInBinTree, justLookupTree, + lookupTree, lookupTreeMany, lookupTreeManyAll, updateTree, + buildTree, filterBinTree, + sorted2tree, mapTree, mapMTree, tree2list, + + + -- * printing + indent, (+++), (++-), (++++), (+++++), + prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly, + prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes, + numberedParagraphs, prConjList, prIfEmpty, wrapLines, + + -- * extra + combinations, + + -- * topological sorting with test of cyclicity + topoTest, + + -- * the generic fix point iterator + iterFix, + + -- * chop into separator-separated parts + chunks, readIntArg, + + -- * 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 qualified Data.Map as Map +import Data.Map (Map) +import Control.Monad (liftM,liftM2, MonadPlus, mzero, mplus) + +import GF.Data.ErrM +import GF.Data.Relation + +infixr 5 +++ +infixr 5 ++- +infixr 5 ++++ +infixr 5 +++++ + +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 + +lookupErr :: (Eq a,Show a) => a -> [(a,b)] -> Err b +lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs) + +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) + +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 + +-- binary search trees + +type BinTree a b = Map a b + +emptyBinTree :: BinTree a b +emptyBinTree = Map.empty + +isInBinTree :: (Ord a) => a -> BinTree a b -> Bool +isInBinTree = Map.member + +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 Map.lookup x tree 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 = [] + +updateTree :: (Ord a) => (a,b) -> BinTree a b -> BinTree a b +updateTree (a,b) = Map.insert a b + +buildTree :: (Ord a) => [(a,b)] -> BinTree a b +buildTree = Map.fromList + +sorted2tree :: Ord a => [(a,b)] -> BinTree a b +sorted2tree = Map.fromAscList + +mapTree :: ((a,b) -> c) -> BinTree a b -> BinTree a c +mapTree f = Map.mapWithKey (\k v -> f (k,v)) + +mapMTree :: (Ord a,Monad m) => ((a,b) -> m c) -> BinTree a b -> m (BinTree a c) +mapMTree f t = liftM Map.fromList $ sequence [liftM ((,) k) (f (k,x)) | (k,x) <- Map.toList t] + +filterBinTree :: Ord a => (a -> b -> Bool) -> BinTree a b -> BinTree a b +filterBinTree = Map.filterWithKey + +tree2list :: BinTree a b -> [(a,b)] -- inorder +tree2list = Map.toList + +-- 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 + +-- | '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] + +-- | topological sorting with test of cyclicity +topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]] +topoTest = topologicalSort . mkRel' + +-- | 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) + +-- | 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)) + +-- error recovery with multiple reporting AR 30/5/2008 +mapsErr :: (a -> Err b) -> [a] -> Err [b] + +mapsErr f = seqs . map f where + seqs es = case es of + Ok v : ms -> case seqs ms of + Ok vs -> return (v : vs) + b -> b + Bad s : ms -> case seqs ms of + Ok vs -> Bad s + Bad ss -> Bad (s +++++ ss) + [] -> return [] + +mapsErrTree :: (Ord a) => ((a,b) -> Err (a,c)) -> BinTree a b -> Err (BinTree a c) +mapsErrTree f t = mapsErr f (tree2list t) >>= return . sorted2tree + + +-- | 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" diff --git a/src/compiler/GF/Data/Relation.hs b/src/compiler/GF/Data/Relation.hs new file mode 100644 index 000000000..7024a482c --- /dev/null +++ b/src/compiler/GF/Data/Relation.hs @@ -0,0 +1,193 @@ +---------------------------------------------------------------------- +-- | +-- 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.Data.Relation (Rel, mkRel, mkRel' + , allRelated , isRelatedTo + , transitiveClosure + , reflexiveClosure, reflexiveClosure_ + , symmetricClosure + , symmetricSubrelation, reflexiveSubrelation + , reflexiveElements + , equivalenceClasses + , isTransitive, isReflexive, isSymmetric + , isEquivalence + , isSubRelationOf + , topologicalSort) where + +import Data.Foldable (toList) +import Data.List +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +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 :: Ord a => 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) + +reverseRel :: Ord a => Rel a -> Rel a +reverseRel r = mkRel [(y,x) | (x,y) <- relToList 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 = fst . purgeEmpty . Map.mapWithKey (Set.filter . p) + +-- | Remove keys that map to no elements. +purgeEmpty :: Ord a => Rel a -> (Rel a, Set a) +purgeEmpty r = let (r',r'') = Map.partition (not . Set.null) r + in (r', Map.keysSet 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) + +-- | Returns 'Left' if there are cycles, and 'Right' if there are cycles. +topologicalSort :: Ord a => Rel a -> Either [a] [[a]] +topologicalSort r = tsort r' noIncoming Seq.empty + where r' = relToRel' r + noIncoming = Seq.fromList [x | (x,(is,_)) <- Map.toList r', Set.null is] + +tsort :: Ord a => Rel' a -> Seq a -> Seq a -> Either [a] [[a]] +tsort r xs l = case Seq.viewl xs of + Seq.EmptyL | isEmpty' r -> Left (toList l) + | otherwise -> Right (findCycles (rel'ToRel r)) + x Seq.:< xs -> tsort r' (xs Seq.>< Seq.fromList new) (l Seq.|> x) + where (r',_,os) = remove x r + new = [o | o <- Set.toList os, Set.null (incoming o r')] + +findCycles :: Ord a => Rel a -> [[a]] +findCycles = map Set.toList . equivalenceClasses . reflexiveSubrelation . symmetricSubrelation . transitiveClosure + +-- +-- * Alternative representation that keeps both incoming and outgoing edges +-- + +-- | Keeps both incoming and outgoing edges. +type Rel' a = Map a (Set a, Set a) + +isEmpty' :: Ord a => Rel' a -> Bool +isEmpty' = Map.null + +relToRel' :: Ord a => Rel a -> Rel' a +relToRel' r = Map.unionWith (\ (i,_) (_,o) -> (i,o)) ir or + where ir = Map.map (\s -> (s,Set.empty)) $ reverseRel r + or = Map.map (\s -> (Set.empty,s)) $ r + +rel'ToRel :: Ord a => Rel' a -> Rel a +rel'ToRel = Map.map snd + +-- | Removes an element from a relation. +-- Returns the new relation, and the set of incoming and outgoing edges +-- of the removed element. +remove :: Ord a => a -> Rel' a -> (Rel' a, Set a, Set a) +remove x r = let (mss,r') = Map.updateLookupWithKey (\_ _ -> Nothing) x r + in case mss of + -- element was not in the relation + Nothing -> (r', Set.empty, Set.empty) + -- remove element from all incoming and outgoing sets + -- of other elements + Just (is,os) -> + let r'' = foldr (\i -> Map.adjust (\ (is',os') -> (is', Set.delete x os')) i) r' $ Set.toList is + r''' = foldr (\o -> Map.adjust (\ (is',os') -> (Set.delete x is', os')) o) r'' $ Set.toList os + in (r''', is, os) + +incoming :: Ord a => a -> Rel' a -> Set a +incoming x r = maybe Set.empty fst $ Map.lookup x r + +outgoing :: Ord a => a -> Rel' a -> Set a +outgoing x r = maybe Set.empty snd $ Map.lookup x r \ No newline at end of file diff --git a/src/compiler/GF/Data/SortedList.hs b/src/compiler/GF/Data/SortedList.hs new file mode 100644 index 000000000..d77ff68d4 --- /dev/null +++ b/src/compiler/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/compiler/GF/Data/Str.hs b/src/compiler/GF/Data/Str.hs new file mode 100644 index 000000000..6f65764c7 --- /dev/null +++ b/src/compiler/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/compiler/GF/Data/TrieMap.hs b/src/compiler/GF/Data/TrieMap.hs new file mode 100644 index 000000000..a6749d641 --- /dev/null +++ b/src/compiler/GF/Data/TrieMap.hs @@ -0,0 +1,66 @@ +module GF.Data.TrieMap + ( TrieMap + + , empty + , singleton + + , lookup + + , null + , decompose + + , insertWith + + , unionWith + , unionsWith + + , elems + ) where + +import Prelude hiding (lookup, null) +import qualified Data.Map as Map + +data TrieMap k v = Tr (Maybe v) (Map.Map k (TrieMap k v)) + +empty = Tr Nothing Map.empty + +singleton :: [k] -> a -> TrieMap k a +singleton [] v = Tr (Just v) Map.empty +singleton (k:ks) v = Tr Nothing (Map.singleton k (singleton ks v)) + +lookup :: Ord k => [k] -> TrieMap k a -> Maybe a +lookup [] (Tr mb_v m) = mb_v +lookup (k:ks) (Tr mb_v m) = Map.lookup k m >>= lookup ks + +null :: TrieMap k v -> Bool +null (Tr Nothing m) = Map.null m +null _ = False + +decompose :: TrieMap k v -> (Maybe v, Map.Map k (TrieMap k v)) +decompose (Tr mb_v m) = (mb_v,m) + +insertWith :: Ord k => (v -> v -> v) -> [k] -> v -> TrieMap k v -> TrieMap k v +insertWith f [] v0 (Tr mb_v m) = case mb_v of + Just v -> Tr (Just (f v0 v)) m + Nothing -> Tr (Just v0 ) m +insertWith f (k:ks) v0 (Tr mb_v m) = case Map.lookup k m of + Nothing -> Tr mb_v (Map.insert k (singleton ks v0) m) + Just tr -> Tr mb_v (Map.insert k (insertWith f ks v0 tr) m) + +unionWith :: Ord k => (v -> v -> v) -> TrieMap k v -> TrieMap k v -> TrieMap k v +unionWith f (Tr mb_v1 m1) (Tr mb_v2 m2) = + let mb_v = case (mb_v1,mb_v2) of + (Nothing,Nothing) -> Nothing + (Just v ,Nothing) -> Just v + (Nothing,Just v ) -> Just v + (Just v1,Just v2) -> Just (f v1 v2) + m = Map.unionWith (unionWith f) m1 m2 + in Tr mb_v m + +unionsWith :: Ord k => (v -> v -> v) -> [TrieMap k v] -> TrieMap k v +unionsWith f = foldl (unionWith f) empty + +elems :: TrieMap k v -> [v] +elems tr = collect tr [] + where + collect (Tr mb_v m) xs = maybe id (:) mb_v (Map.fold collect xs m) diff --git a/src/compiler/GF/Data/Utilities.hs b/src/compiler/GF/Data/Utilities.hs new file mode 100644 index 000000000..74d3ef81e --- /dev/null +++ b/src/compiler/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/compiler/GF/Data/XML.hs b/src/compiler/GF/Data/XML.hs new file mode 100644 index 000000000..bdc6f98a1 --- /dev/null +++ b/src/compiler/GF/Data/XML.hs @@ -0,0 +1,58 @@ +---------------------------------------------------------------------- +-- | +-- Module : XML +-- +-- Utilities for creating XML documents. +---------------------------------------------------------------------- +module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where + +import GF.Data.Utilities +import GF.Text.UTF8 + +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 = encodeUTF8 . showString header . showsXML xml + where header = "" + +showsXML :: XML -> ShowS +showsXML = showsX 0 where + showsX i x = ind i . case x of + (Data s) -> showString s + (CData s) -> showString "" + (ETag t as) -> showChar '<' . showString t . showsAttrs as . showString "/>" + (Tag t as cs) -> + showChar '<' . showString t . showsAttrs as . showChar '>' . + concatS (map (showsX (i+1)) cs) . ind i . + showString "' + (Comment c) -> showString "" + (Empty) -> id + ind i = showString ("\n" ++ replicate (2*i) ' ') + +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/compiler/GF/Data/Zipper.hs b/src/compiler/GF/Data/Zipper.hs new file mode 100644 index 000000000..a4491f76e --- /dev/null +++ b/src/compiler/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/compiler/GF/Grammar.hs b/src/compiler/GF/Grammar.hs new file mode 100644 index 000000000..c540f77b8 --- /dev/null +++ b/src/compiler/GF/Grammar.hs @@ -0,0 +1,29 @@ +---------------------------------------------------------------------- +-- | +-- 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 + ( module GF.Infra.Ident, + module GF.Grammar.Grammar, + module GF.Grammar.Values, + module GF.Grammar.Macros, + module GF.Grammar.MMacros, + module GF.Grammar.Printer + ) where + +import GF.Infra.Ident +import GF.Grammar.Grammar +import GF.Grammar.Values +import GF.Grammar.Macros +import GF.Grammar.MMacros +import GF.Grammar.Printer diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs new file mode 100644 index 000000000..fbad5ac7e --- /dev/null +++ b/src/compiler/GF/Grammar/Binary.hs @@ -0,0 +1,261 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Grammar.Binary +-- Maintainer : Krasimir Angelov +-- Stability : (stable) +-- Portability : (portable) +-- +----------------------------------------------------------------------------- + +module GF.Grammar.Binary where + +import Data.Binary +import qualified Data.Map as Map +import qualified Data.ByteString.Char8 as BS + +import GF.Data.Operations +import GF.Infra.Ident +import GF.Infra.Option +import GF.Infra.Modules +import GF.Grammar.Grammar + +instance Binary Ident where + put id = put (ident2bs id) + get = do bs <- get + if bs == BS.pack "_" + then return identW + else return (identC bs) + +instance (Ord i, Binary i, Binary a) => Binary (MGrammar i a) where + put (MGrammar ms) = put ms + get = fmap MGrammar get + +instance (Ord i, Binary i, Binary a) => Binary (ModInfo i a) where + put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,jments mi,positions mi) + get = do (mtype,mstatus,flags,extend,mwith,opens,med,jments,positions) <- get + return (ModInfo mtype mstatus flags extend mwith opens med jments positions) + +instance (Binary i) => Binary (ModuleType i) where + put MTAbstract = putWord8 0 + put MTResource = putWord8 2 + put (MTConcrete i) = putWord8 3 >> put i + put MTInterface = putWord8 4 + put (MTInstance i) = putWord8 5 >> put i + get = do tag <- getWord8 + case tag of + 0 -> return MTAbstract + 2 -> return MTResource + 3 -> get >>= return . MTConcrete + 4 -> return MTInterface + 5 -> get >>= return . MTInstance + _ -> decodingError + +instance (Binary i) => Binary (MInclude i) where + put MIAll = putWord8 0 + put (MIOnly xs) = putWord8 1 >> put xs + put (MIExcept xs) = putWord8 2 >> put xs + get = do tag <- getWord8 + case tag of + 0 -> return MIAll + 1 -> fmap MIOnly get + 2 -> fmap MIExcept get + _ -> decodingError + +instance Binary i => Binary (OpenSpec i) where + put (OSimple i) = putWord8 0 >> put i + put (OQualif i j) = putWord8 1 >> put (i,j) + get = do tag <- getWord8 + case tag of + 0 -> get >>= return . OSimple + 1 -> get >>= \(i,j) -> return (OQualif i j) + _ -> decodingError + +instance Binary ModuleStatus where + put MSComplete = putWord8 0 + put MSIncomplete = putWord8 1 + get = do tag <- getWord8 + case tag of + 0 -> return MSComplete + 1 -> return MSIncomplete + _ -> decodingError + +instance Binary Options where + put = put . optionsGFO + get = do opts <- get + case parseModuleOptions ["--" ++ flag ++ "=" ++ value | (flag,value) <- opts] of + Ok x -> return x + Bad msg -> fail msg + +instance Binary Info where + put (AbsCat x y) = putWord8 0 >> put (x,y) + put (AbsFun x y z) = putWord8 1 >> put (x,y,z) + put (ResParam x y) = putWord8 2 >> put (x,y) + put (ResValue x) = putWord8 3 >> put x + put (ResOper x y) = putWord8 4 >> put (x,y) + put (ResOverload x y)= putWord8 5 >> put (x,y) + put (CncCat x y z) = putWord8 6 >> put (x,y,z) + put (CncFun x y z) = putWord8 7 >> put (x,y,z) + put (AnyInd x y) = putWord8 8 >> put (x,y) + get = do tag <- getWord8 + case tag of + 0 -> get >>= \(x,y) -> return (AbsCat x y) + 1 -> get >>= \(x,y,z) -> return (AbsFun x y z) + 2 -> get >>= \(x,y) -> return (ResParam x y) + 3 -> get >>= \x -> return (ResValue x) + 4 -> get >>= \(x,y) -> return (ResOper x y) + 5 -> get >>= \(x,y) -> return (ResOverload x y) + 6 -> get >>= \(x,y,z) -> return (CncCat x y z) + 7 -> get >>= \(x,y,z) -> return (CncFun x y z) + 8 -> get >>= \(x,y) -> return (AnyInd x y) + _ -> decodingError + +instance Binary BindType where + put Explicit = putWord8 0 + put Implicit = putWord8 1 + get = do tag <- getWord8 + case tag of + 0 -> return Explicit + 1 -> return Implicit + _ -> decodingError + +instance Binary Term where + put (Vr x) = putWord8 0 >> put x + put (Cn x) = putWord8 1 >> put x + put (Con x) = putWord8 2 >> put x + put (Sort x) = putWord8 3 >> put x + put (EInt x) = putWord8 4 >> put x + put (EFloat x) = putWord8 5 >> put x + put (K x) = putWord8 6 >> put x + put (Empty) = putWord8 7 + put (App x y) = putWord8 8 >> put (x,y) + put (Abs x y z) = putWord8 9 >> put (x,y,z) + put (Meta x) = putWord8 10 >> put x + put (Prod w x y z)= putWord8 11 >> put (w,x,y,z) + put (Typed x y) = putWord8 12 >> put (x,y) + put (Example x y) = putWord8 13 >> put (x,y) + put (RecType x) = putWord8 14 >> put x + put (R x) = putWord8 15 >> put x + put (P x y) = putWord8 16 >> put (x,y) + put (ExtR x y) = putWord8 17 >> put (x,y) + put (Table x y) = putWord8 18 >> put (x,y) + put (T x y) = putWord8 19 >> put (x,y) + put (V x y) = putWord8 20 >> put (x,y) + put (S x y) = putWord8 21 >> put (x,y) + put (Let x y) = putWord8 22 >> put (x,y) + put (Q x y) = putWord8 23 >> put (x,y) + put (QC x y) = putWord8 24 >> put (x,y) + put (C x y) = putWord8 25 >> put (x,y) + put (Glue x y) = putWord8 26 >> put (x,y) + put (EPatt x) = putWord8 27 >> put x + put (EPattType x) = putWord8 28 >> put x + put (FV x) = putWord8 29 >> put x + put (Alts x) = putWord8 30 >> put x + put (Strs x) = putWord8 31 >> put x + put (ELin x y) = putWord8 32 >> put (x,y) + + get = do tag <- getWord8 + case tag of + 0 -> get >>= \x -> return (Vr x) + 1 -> get >>= \x -> return (Cn x) + 2 -> get >>= \x -> return (Con x) + 3 -> get >>= \x -> return (Sort x) + 4 -> get >>= \x -> return (EInt x) + 5 -> get >>= \x -> return (EFloat x) + 6 -> get >>= \x -> return (K x) + 7 -> return (Empty) + 8 -> get >>= \(x,y) -> return (App x y) + 9 -> get >>= \(x,y,z) -> return (Abs x y z) + 10 -> get >>= \x -> return (Meta x) + 11 -> get >>= \(w,x,y,z)->return (Prod w x y z) + 12 -> get >>= \(x,y) -> return (Typed x y) + 13 -> get >>= \(x,y) -> return (Example x y) + 14 -> get >>= \x -> return (RecType x) + 15 -> get >>= \x -> return (R x) + 16 -> get >>= \(x,y) -> return (P x y) + 17 -> get >>= \(x,y) -> return (ExtR x y) + 18 -> get >>= \(x,y) -> return (Table x y) + 19 -> get >>= \(x,y) -> return (T x y) + 20 -> get >>= \(x,y) -> return (V x y) + 21 -> get >>= \(x,y) -> return (S x y) + 22 -> get >>= \(x,y) -> return (Let x y) + 23 -> get >>= \(x,y) -> return (Q x y) + 24 -> get >>= \(x,y) -> return (QC x y) + 25 -> get >>= \(x,y) -> return (C x y) + 26 -> get >>= \(x,y) -> return (Glue x y) + 27 -> get >>= \x -> return (EPatt x) + 28 -> get >>= \x -> return (EPattType x) + 29 -> get >>= \x -> return (FV x) + 30 -> get >>= \x -> return (Alts x) + 31 -> get >>= \x -> return (Strs x) + 32 -> get >>= \(x,y) -> return (ELin x y) + _ -> decodingError + +instance Binary Patt where + put (PC x y) = putWord8 0 >> put (x,y) + put (PP x y z) = putWord8 1 >> put (x,y,z) + put (PV x) = putWord8 2 >> put x + put (PW) = putWord8 3 + put (PR x) = putWord8 4 >> put x + put (PString x) = putWord8 5 >> put x + put (PInt x) = putWord8 6 >> put x + put (PFloat x) = putWord8 7 >> put x + put (PT x y) = putWord8 8 >> put (x,y) + put (PAs x y) = putWord8 10 >> put (x,y) + put (PNeg x) = putWord8 11 >> put x + put (PAlt x y) = putWord8 12 >> put (x,y) + put (PSeq x y) = putWord8 13 >> put (x,y) + put (PRep x) = putWord8 14 >> put x + put (PChar) = putWord8 15 + put (PChars x) = putWord8 16 >> put x + put (PMacro x) = putWord8 17 >> put x + put (PM x y) = putWord8 18 >> put (x,y) + get = do tag <- getWord8 + case tag of + 0 -> get >>= \(x,y) -> return (PC x y) + 1 -> get >>= \(x,y,z) -> return (PP x y z) + 2 -> get >>= \x -> return (PV x) + 3 -> return (PW) + 4 -> get >>= \x -> return (PR x) + 5 -> get >>= \x -> return (PString x) + 6 -> get >>= \x -> return (PInt x) + 7 -> get >>= \x -> return (PFloat x) + 8 -> get >>= \(x,y) -> return (PT x y) + 10 -> get >>= \(x,y) -> return (PAs x y) + 11 -> get >>= \x -> return (PNeg x) + 12 -> get >>= \(x,y) -> return (PAlt x y) + 13 -> get >>= \(x,y) -> return (PSeq x y) + 14 -> get >>= \x -> return (PRep x) + 15 -> return (PChar) + 16 -> get >>= \x -> return (PChars x) + 17 -> get >>= \x -> return (PMacro x) + 18 -> get >>= \(x,y) -> return (PM x y) + _ -> decodingError + +instance Binary TInfo where + put TRaw = putWord8 0 + put (TTyped t) = putWord8 1 >> put t + put (TComp t) = putWord8 2 >> put t + put (TWild t) = putWord8 3 >> put t + get = do tag <- getWord8 + case tag of + 0 -> return TRaw + 1 -> fmap TTyped get + 2 -> fmap TComp get + 3 -> fmap TWild get + _ -> decodingError + +instance Binary Label where + put (LIdent bs) = putWord8 0 >> put bs + put (LVar i) = putWord8 1 >> put i + get = do tag <- getWord8 + case tag of + 0 -> fmap LIdent get + 1 -> fmap LVar get + _ -> decodingError + +decodeModHeader :: FilePath -> IO SourceModule +decodeModHeader fpath = do + (m,mtype,mstatus,flags,extend,mwith,opens,med) <- decodeFile fpath + return (m,ModInfo mtype mstatus flags extend mwith opens med Map.empty Map.empty) + +decodingError = fail "This GFO file was compiled with different version of GF" diff --git a/src/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs new file mode 100644 index 000000000..a1d716994 --- /dev/null +++ b/src/compiler/GF/Grammar/CF.hs @@ -0,0 +1,128 @@ +---------------------------------------------------------------------- +-- | +-- Module : CF +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/15 17:56:13 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.13 $ +-- +-- parsing CF grammars and converting them to GF +----------------------------------------------------------------------------- + +module GF.Grammar.CF (getCF) where + +import GF.Grammar.Grammar +import GF.Grammar.Macros +import GF.Infra.Ident +import GF.Infra.Modules +import GF.Infra.Option + +import GF.Data.Operations + +import Data.Char +import Data.List +import qualified Data.ByteString.Char8 as BS + +getCF :: String -> String -> Err SourceGrammar +getCF name = fmap (cf2gf name) . pCF + +--------------------- +-- the parser ------- +--------------------- + +pCF :: String -> Err CF +pCF s = do + rules <- mapM getCFRule $ filter isRule $ lines s + return $ concat rules + where + isRule line = case dropWhile isSpace line of + '-':'-':_ -> False + _ -> not $ all isSpace line + +-- 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 -> Err [CFRule] +getCFRule s = getcf (wrds s) where + getcf ws = case ws of + fun : cat : a : its | isArrow a -> + Ok [(init fun, (cat, map mkIt its))] + cat : a : its | isArrow a -> + Ok [(mkFun cat it, (cat, map mkIt it)) | it <- chunk its] + _ -> Bad (" invalid rule:" +++ s) + isArrow a = elem a ["->", "::="] + mkIt w = case w of + ('"':w@(_:_)) -> Right (init w) + _ -> Left 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 + +type CF = [CFRule] + +type CFRule = (CFFun, (CFCat, [CFItem])) + +type CFItem = Either CFCat String + +type CFCat = String +type CFFun = String + +-------------------------- +-- the compiler ---------- +-------------------------- + +cf2gf :: String -> CF -> SourceGrammar +cf2gf name cf = MGrammar [ + (aname, addFlag (modifyFlags (\fs -> fs{optStartCat = Just cat})) + (emptyModInfo{mtype = MTAbstract, jments = abs})), + (cname, emptyModInfo{mtype = MTConcrete aname, jments = cnc}) + ] + where + (abs,cnc,cat) = cf2grammar cf + aname = identS $ name ++ "Abs" + cname = identS name + + +cf2grammar :: CF -> (BinTree Ident Info, BinTree Ident Info, String) +cf2grammar rules = (buildTree abs, buildTree conc, cat) where + abs = cats ++ funs + conc = lincats ++ lins + cat = case rules of + (_,(c,_)):_ -> c -- the value category of the first rule + _ -> error "empty CF" + cats = [(cat, AbsCat (Just []) (Just [])) | + cat <- nub (concat (map cf2cat rules))] ----notPredef cat + lincats = [(cat, CncCat (Just defLinType) Nothing Nothing) | (cat,AbsCat _ _) <- cats] + (funs,lins) = unzip (map cf2rule rules) + +cf2cat :: CFRule -> [Ident] +cf2cat (_,(cat, items)) = map identS $ cat : [c | Left c <- items] + +cf2rule :: CFRule -> ((Ident,Info),(Ident,Info)) +cf2rule (fun, (cat, items)) = (def,ldef) where + f = identS fun + def = (f, AbsFun (Just (mkProd args' (Cn (identS cat)) [])) Nothing Nothing) + args0 = zip (map (identS . ("x" ++) . show) [0..]) items + args = [((Explicit,v), Cn (identS c)) | (v, Left c) <- args0] + args' = [(Explicit,identS "_", Cn (identS c)) | (_, Left c) <- args0] + ldef = (f, CncFun + Nothing + (Just (mkAbs (map fst args) + (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)]))) + Nothing) + mkIt (v, Left _) = P (Vr v) theLinLabel + mkIt (_, Right a) = K a + foldconcat [] = K "" + foldconcat tt = foldr1 C tt + +identS = identC . BS.pack + diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs new file mode 100644 index 000000000..8d1468d9d --- /dev/null +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -0,0 +1,230 @@ +---------------------------------------------------------------------- +-- | +-- 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, + emptySourceGrammar, + SourceModInfo, + SourceModule, + mapSourceModule, + Info(..), + Type, + Cat, + Fun, + QIdent, + BindType(..), + Term(..), + Patt(..), + TInfo(..), + Label(..), + MetaId, + Hypo, + Context, + Equation, + Labelling, + Assign, + Case, + LocalDef, + Param, + Altern, + Substitution, + varLabel, tupleLabel, linLabel, theLinLabel, + ident2label, label2ident + ) where + +import GF.Infra.Ident +import GF.Infra.Option --- +import GF.Infra.Modules + +import GF.Data.Operations + +import qualified Data.ByteString.Char8 as BS + +-- | grammar as presented to the compiler +type SourceGrammar = MGrammar Ident Info + +emptySourceGrammar = MGrammar [] + +type SourceModInfo = ModInfo Ident Info + +type SourceModule = (Ident, SourceModInfo) + +mapSourceModule :: (SourceModInfo -> SourceModInfo) -> (SourceModule -> SourceModule) +mapSourceModule f (i,mi) = (i, f mi) + +-- | 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 (Maybe Context) (Maybe [Term]) -- ^ (/ABS/) the second parameter is list of constructors - must be 'Id' or 'QId' + | AbsFun (Maybe Type) (Maybe Int) (Maybe [Equation]) -- ^ (/ABS/) type, arrity and definition of function + +-- judgements in resource + | ResParam (Maybe [Param]) (Maybe [Term]) -- ^ (/RES/) the second parameter is list of all possible values + | ResValue Type -- ^ (/RES/) to mark parameter constructors for lookup + | ResOper (Maybe Type) (Maybe Term) -- ^ (/RES/) + + | ResOverload [Ident] [(Type,Term)] -- ^ (/RES/) idents: modules inherited + +-- judgements in concrete syntax + | CncCat (Maybe Type) (Maybe Term) (Maybe Term) -- ^ (/CNC/) lindef ini'zed, + | CncFun (Maybe (Ident,Context,Type)) (Maybe Term) (Maybe Term) -- ^ (/CNC/) type info added at 'TC' + +-- indirection to module Ident + | AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical + deriving Show + +type Type = Term +type Cat = QIdent +type Fun = QIdent + +type QIdent = (Ident,Ident) + +data BindType = + Explicit + | Implicit + deriving (Eq,Ord,Show) + +data Term = + Vr Ident -- ^ variable + | Cn Ident -- ^ constant + | Con Ident -- ^ constructor + | Sort Ident -- ^ 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 BindType Ident Term -- ^ abstraction: @\x -> b@ + | Meta {-# UNPACK #-} !MetaId -- ^ metavariable: @?i@ (only parsable: ? = ?0) + | ImplArg Term -- ^ placeholder for implicit argument @{t}@ + | Prod BindType Ident Term Term -- ^ function type: @(x : A) -> B@, @A -> B@, @({x} : A) -> B@ + | 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@ + | 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] -- ^ table given as course of values: @table T [c1 ; ... ; cn]@ + | S Term Term -- ^ selection: @t ! p@ + + | Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@ + + | 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 + + | ELincat Ident Term -- ^ boxed linearization type of Ident + | ELin Ident Term -- ^ boxed linearization of type Ident + + | 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 ; ...}@ + + deriving (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 + + | PAs Ident Patt -- ^ as-pattern: x@p + + | PImplArg Patt -- ^ placeholder for pattern for implicit argument @{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 (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 (Show, Eq, Ord) + +-- | record label +data Label = + LIdent BS.ByteString + | LVar Int + deriving (Show, Eq, Ord) + +type MetaId = Int + +type Hypo = (BindType,Ident,Term) -- (x:A) (_:A) A ({x}:A) +type Context = [Hypo] -- (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)] + +varLabel :: Int -> Label +varLabel = LVar + +tupleLabel, linLabel :: Int -> Label +tupleLabel i = LIdent $! BS.pack ('p':show i) +linLabel i = LIdent $! BS.pack ('s':show i) + +theLinLabel :: Label +theLinLabel = LIdent (BS.singleton 's') + +ident2label :: Ident -> Label +ident2label c = LIdent (ident2bs c) + +label2ident :: Label -> Ident +label2ident (LIdent s) = identC s +label2ident (LVar i) = identC (BS.pack ('$':show i)) diff --git a/src/compiler/GF/Grammar/Lexer.hs b/src/compiler/GF/Grammar/Lexer.hs new file mode 100644 index 000000000..7cacb0588 --- /dev/null +++ b/src/compiler/GF/Grammar/Lexer.hs @@ -0,0 +1,478 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LINE 3 "src\GF\Grammar\Lexer.x" #-} + +module GF.Grammar.Lexer + ( Token(..), Posn(..) + , P, runP, lexer, getPosn, failLoc + , isReservedWord + ) where + +import GF.Infra.Ident +import GF.Data.Operations +import qualified Data.ByteString.Char8 as BS +import qualified Data.Map as Map + + +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#elif defined(__GLASGOW_HASKELL__) +#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\xf5\xff\xff\xff\x16\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x2e\x00\x00\x00\x6c\x01\x00\x00\x3c\x02\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\x15\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\x12\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\x14\x00\x0e\x00\x14\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x11\x00\x0e\x00\xff\xff\x13\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\x18\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\x00\x00\x00\x00\xff\xff\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\x1b\x00\xff\xff\x00\x00\x00\x00\x18\x00\x1b\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\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\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\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\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\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\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\x5c\x00\x2b\x00\x27\x00\x3e\x00\x27\x00\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\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# "\x17\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\x16\x00\x16\x00\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_3))],[(AlexAcc (alex_action_4))],[],[],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))],[],[],[],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_8))],[],[],[]] +{-# LINE 42 "src\GF\Grammar\Lexer.x" #-} + + +tok f p s = f s + +data Token + = T_exclmark + | T_patt + | T_int_label + | T_oparen + | T_cparen + | T_star + | T_starstar + | T_plus + | T_plusplus + | T_comma + | T_minus + | T_rarrow + | T_dot + | T_alt + | T_colon + | T_semicolon + | T_less + | T_equal + | T_big_rarrow + | T_great + | T_questmark + | T_obrack + | T_lam + | T_lamlam + | T_cbrack + | T_ocurly + | T_bar + | T_ccurly + | T_underscore + | T_at + | T_PType + | T_Str + | T_Strs + | T_Tok + | T_Type + | T_abstract + | T_case + | T_cat + | T_concrete + | T_data + | T_def + | T_flags + | T_fn + | T_fun + | T_in + | T_incomplete + | T_instance + | T_interface + | T_let + | T_lin + | T_lincat + | T_lindef + | T_of + | T_open + | T_oper + | T_param + | T_pattern + | T_pre + | T_printname + | T_resource + | T_strs + | T_table + | T_transfer + | T_variants + | T_where + | T_with + | T_String String -- string literals + | T_Integer Integer -- integer literals + | T_Double Double -- double precision float literals + | T_LString String + | T_Ident Ident + | T_EOF + +eitherResIdent :: (BS.ByteString -> Token) -> BS.ByteString -> Token +eitherResIdent tv s = + case Map.lookup s resWords of + Just t -> t + Nothing -> tv s + +isReservedWord :: BS.ByteString -> Bool +isReservedWord s = Map.member s resWords + +resWords = Map.fromList + [ b "!" T_exclmark + , b "#" T_patt + , b "$" T_int_label + , b "(" T_oparen + , b ")" T_cparen + , b "*" T_star + , b "**" T_starstar + , b "+" T_plus + , b "++" T_plusplus + , b "," T_comma + , b "-" T_minus + , b "->" T_rarrow + , b "." T_dot + , b "/" T_alt + , b ":" T_colon + , b ";" T_semicolon + , b "<" T_less + , b "=" T_equal + , b "=>" T_big_rarrow + , b ">" T_great + , b "?" T_questmark + , b "[" T_obrack + , b "]" T_cbrack + , b "\\" T_lam + , b "\\\\" T_lamlam + , b "{" T_ocurly + , b "}" T_ccurly + , b "|" T_bar + , b "_" T_underscore + , b "@" T_at + , b "PType" T_PType + , b "Str" T_Str + , b "Strs" T_Strs + , b "Tok" T_Tok + , b "Type" T_Type + , b "abstract" T_abstract + , b "case" T_case + , b "cat" T_cat + , b "concrete" T_concrete + , b "data" T_data + , b "def" T_def + , b "flags" T_flags + , b "fn" T_fn + , b "fun" T_fun + , b "in" T_in + , b "incomplete" T_incomplete + , b "instance" T_instance + , b "interface" T_interface + , b "let" T_let + , b "lin" T_lin + , b "lincat" T_lincat + , b "lindef" T_lindef + , b "of" T_of + , b "open" T_open + , b "oper" T_oper + , b "param" T_param + , b "pattern" T_pattern + , b "pre" T_pre + , b "printname" T_printname + , b "resource" T_resource + , b "strs" T_strs + , b "table" T_table + , b "transfer" T_transfer + , b "variants" T_variants + , b "where" T_where + , b "with" T_with + ] + where b s t = (BS.pack s, t) + +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 {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + +alexMove :: Posn -> Char -> Posn +alexMove (Pn l c) '\n' = Pn (l+1) 1 +alexMove (Pn l c) _ = Pn l (c+1) + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (AI p _ s) = + case BS.uncons s of + Nothing -> Nothing + Just (c,s) -> + let p' = alexMove p c + in p' `seq` Just (c, (AI p' c s)) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (AI p c s) = c + +data AlexInput = AI {-# UNPACK #-} !Posn -- current position, + {-# UNPACK #-} !Char -- previous char + {-# UNPACK #-} !BS.ByteString -- current input string + +data ParseResult a + = POk AlexInput a + | PFailed Posn -- The position of the error + String -- The error message + +newtype P a = P { unP :: AlexInput -> ParseResult a } + +instance Monad P where + return a = a `seq` (P $ \s -> POk s a) + (P m) >>= k = P $ \ s -> case m s of + POk s1 a -> unP (k a) s1 + PFailed posn err -> PFailed posn err + fail msg = P $ \(AI posn _ _) -> PFailed posn msg + +runP :: P a -> BS.ByteString -> Either (Posn,String) a +runP (P f) txt = + case f (AI (Pn 1 0) ' ' txt) of + POk _ x -> Right x + PFailed pos msg -> Left (pos,msg) + +failLoc :: Posn -> String -> P a +failLoc pos msg = P $ \_ -> PFailed pos msg + +lexer :: (Token -> P a) -> P a +lexer cont = P go + where + go inp@(AI pos _ str) = + case alexScan inp 0 of + AlexEOF -> unP (cont T_EOF) inp + AlexError (AI pos _ _) -> PFailed pos "lexical error" + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> unP (cont (act pos (BS.take len str))) inp' + +getPosn :: P Posn +getPosn = P $ \inp@(AI pos _ _) -> POk inp pos + + +alex_action_3 = tok (eitherResIdent (T_Ident . identC)) +alex_action_4 = tok (eitherResIdent (T_LString . BS.unpack)) +alex_action_5 = tok (eitherResIdent (T_Ident . identC)) +alex_action_6 = tok (T_String . unescapeInitTail . BS.unpack) +alex_action_7 = tok (T_Integer . read . BS.unpack) +alex_action_8 = tok (T_Double . read . BS.unpack) +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "templates/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 "templates/GenericTemplate.hs" #-} + +{-# LINE 45 "templates/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/compiler/GF/Grammar/Lexer.x b/src/compiler/GF/Grammar/Lexer.x new file mode 100644 index 000000000..d6f49bbb1 --- /dev/null +++ b/src/compiler/GF/Grammar/Lexer.x @@ -0,0 +1,272 @@ +-- -*- haskell -*- +-- This Alex file was machine-generated by the BNF converter +{ +module GF.Grammar.Lexer + ( Token(..), Posn(..) + , P, runP, lexer, getPosn, failLoc + , isReservedWord + ) where + +import GF.Infra.Ident +import GF.Data.Operations +import qualified Data.ByteString.Char8 as BS +import qualified Data.Map as Map + +} + + +$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 + \; | \= | \{ | \} | \( | \) | \* \* | \: | \- \> | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \# | \! | \* | \+ | \+ \+ | \\ | \\\\ | \= \> | \_ | \$ | \/ + +:- +"--" [.]* ; -- Toss single line comments +"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ; + +$white+ ; +@rsyms { tok (eitherResIdent (T_Ident . identC)) } +\' ($u # \')* \' { tok (eitherResIdent (T_LString . BS.unpack)) } +(\_ | $l)($l | $d | \_ | \')* { tok (eitherResIdent (T_Ident . identC)) } + +\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \" { tok (T_String . unescapeInitTail . BS.unpack) } + +$d+ { tok (T_Integer . read . BS.unpack) } +$d+ \. $d+ (e (\-)? $d+)? { tok (T_Double . read . BS.unpack) } + +{ + +tok f p s = f s + +data Token + = T_exclmark + | T_patt + | T_int_label + | T_oparen + | T_cparen + | T_star + | T_starstar + | T_plus + | T_plusplus + | T_comma + | T_minus + | T_rarrow + | T_dot + | T_alt + | T_colon + | T_semicolon + | T_less + | T_equal + | T_big_rarrow + | T_great + | T_questmark + | T_obrack + | T_lam + | T_lamlam + | T_cbrack + | T_ocurly + | T_bar + | T_ccurly + | T_underscore + | T_at + | T_PType + | T_Str + | T_Strs + | T_Tok + | T_Type + | T_abstract + | T_case + | T_cat + | T_concrete + | T_data + | T_def + | T_flags + | T_fn + | T_fun + | T_in + | T_incomplete + | T_instance + | T_interface + | T_let + | T_lin + | T_lincat + | T_lindef + | T_of + | T_open + | T_oper + | T_param + | T_pattern + | T_pre + | T_printname + | T_resource + | T_strs + | T_table + | T_transfer + | T_variants + | T_where + | T_with + | T_String String -- string literals + | T_Integer Integer -- integer literals + | T_Double Double -- double precision float literals + | T_LString String + | T_Ident Ident + | T_EOF + +eitherResIdent :: (BS.ByteString -> Token) -> BS.ByteString -> Token +eitherResIdent tv s = + case Map.lookup s resWords of + Just t -> t + Nothing -> tv s + +isReservedWord :: BS.ByteString -> Bool +isReservedWord s = Map.member s resWords + +resWords = Map.fromList + [ b "!" T_exclmark + , b "#" T_patt + , b "$" T_int_label + , b "(" T_oparen + , b ")" T_cparen + , b "*" T_star + , b "**" T_starstar + , b "+" T_plus + , b "++" T_plusplus + , b "," T_comma + , b "-" T_minus + , b "->" T_rarrow + , b "." T_dot + , b "/" T_alt + , b ":" T_colon + , b ";" T_semicolon + , b "<" T_less + , b "=" T_equal + , b "=>" T_big_rarrow + , b ">" T_great + , b "?" T_questmark + , b "[" T_obrack + , b "]" T_cbrack + , b "\\" T_lam + , b "\\\\" T_lamlam + , b "{" T_ocurly + , b "}" T_ccurly + , b "|" T_bar + , b "_" T_underscore + , b "@" T_at + , b "PType" T_PType + , b "Str" T_Str + , b "Strs" T_Strs + , b "Tok" T_Tok + , b "Type" T_Type + , b "abstract" T_abstract + , b "case" T_case + , b "cat" T_cat + , b "concrete" T_concrete + , b "data" T_data + , b "def" T_def + , b "flags" T_flags + , b "fn" T_fn + , b "fun" T_fun + , b "in" T_in + , b "incomplete" T_incomplete + , b "instance" T_instance + , b "interface" T_interface + , b "let" T_let + , b "lin" T_lin + , b "lincat" T_lincat + , b "lindef" T_lindef + , b "of" T_of + , b "open" T_open + , b "oper" T_oper + , b "param" T_param + , b "pattern" T_pattern + , b "pre" T_pre + , b "printname" T_printname + , b "resource" T_resource + , b "strs" T_strs + , b "table" T_table + , b "transfer" T_transfer + , b "variants" T_variants + , b "where" T_where + , b "with" T_with + ] + where b s t = (BS.pack s, t) + +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 {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + +alexMove :: Posn -> Char -> Posn +alexMove (Pn l c) '\n' = Pn (l+1) 1 +alexMove (Pn l c) _ = Pn l (c+1) + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (AI p _ s) = + case BS.uncons s of + Nothing -> Nothing + Just (c,s) -> + let p' = alexMove p c + in p' `seq` Just (c, (AI p' c s)) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (AI p c s) = c + +data AlexInput = AI {-# UNPACK #-} !Posn -- current position, + {-# UNPACK #-} !Char -- previous char + {-# UNPACK #-} !BS.ByteString -- current input string + +data ParseResult a + = POk a + | PFailed Posn -- The position of the error + String -- The error message + +newtype P a = P { unP :: AlexInput -> ParseResult a } + +instance Monad P where + return a = a `seq` (P $ \s -> POk a) + (P m) >>= k = P $ \ s -> case m s of + POk a -> unP (k a) s + PFailed posn err -> PFailed posn err + fail msg = P $ \(AI posn _ _) -> PFailed posn msg + +runP :: P a -> BS.ByteString -> Either (Posn,String) a +runP (P f) txt = + case f (AI (Pn 1 0) ' ' txt) of + POk x -> Right x + PFailed pos msg -> Left (pos,msg) + +failLoc :: Posn -> String -> P a +failLoc pos msg = P $ \_ -> PFailed pos msg + +lexer :: (Token -> P a) -> P a +lexer cont = P go + where + go inp@(AI pos _ str) = + case alexScan inp 0 of + AlexEOF -> unP (cont T_EOF) inp + AlexError (AI pos _ _) -> PFailed pos "lexical error" + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> unP (cont (act pos (BS.take len str))) inp' + +getPosn :: P Posn +getPosn = P $ \inp@(AI pos _ _) -> POk pos + +} diff --git a/src/compiler/GF/Grammar/Lockfield.hs b/src/compiler/GF/Grammar/Lockfield.hs new file mode 100644 index 000000000..3e78a48b6 --- /dev/null +++ b/src/compiler/GF/Grammar/Lockfield.hs @@ -0,0 +1,52 @@ +---------------------------------------------------------------------- +-- | +-- 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 qualified Data.ByteString.Char8 as BS + +import GF.Infra.Ident +import GF.Grammar.Grammar +import GF.Grammar.Macros + +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 (showIdent 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 + let lock = R [(lockLabel c, (Just (RecType []),R []))] + case plusRecord t lock of + Ok t' -> return $ mkAbs xs t' + _ -> return $ mkAbs xs (ExtR t lock) + +lockLabel :: Ident -> Label +lockLabel c = LIdent $! BS.append lockPrefix (ident2bs c) + +isLockLabel :: Label -> Bool +isLockLabel l = case l of + LIdent c -> BS.isPrefixOf lockPrefix c + _ -> False + + +lockPrefix = BS.pack "lock_" diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs new file mode 100644 index 000000000..074f0c5ec --- /dev/null +++ b/src/compiler/GF/Grammar/Lookup.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE PatternGuards #-} +---------------------------------------------------------------------- +-- | +-- 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 ( + lookupIdent, + lookupIdentInfo, + lookupOrigInfo, + allOrigInfos, + lookupResDef, + lookupResType, + lookupOverload, + lookupParamValues, + allParamValues, + lookupAbsDef, + lookupLincat, + lookupFunType, + lookupCatContext + ) where + +import GF.Data.Operations +import GF.Infra.Ident +import GF.Infra.Modules +import GF.Grammar.Macros +import GF.Grammar.Grammar +import GF.Grammar.Printer +import GF.Grammar.Predef +import GF.Grammar.Lockfield + +import Data.List (nub,sortBy) +import Control.Monad +import Text.PrettyPrint + +-- whether lock fields are added in reuse +lock c = lockRecType c -- return +unlock c = unlockRecord c -- return + +-- to look up a constant etc in a search tree --- why here? AR 29/5/2008 +lookupIdent :: Ident -> BinTree Ident b -> Err b +lookupIdent c t = + case lookupTree showIdent c t of + Ok v -> return v + Bad _ -> Bad ("unknown identifier" +++ showIdent c) + +lookupIdentInfo :: ModInfo Ident a -> Ident -> Err a +lookupIdentInfo mo i = lookupIdent i (jments mo) + +lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term +lookupResDef gr m c + | isPredefCat c = lock c defLinType + | otherwise = look m c + where + look m c = do + mo <- lookupModule gr m + info <- lookupIdentInfo mo c + case info of + ResOper _ (Just t) -> return t + ResOper _ Nothing -> return (Q m c) + CncCat (Just ty) _ _ -> lock c ty + CncCat _ _ _ -> lock c defLinType + + CncFun (Just (cat,_,_)) (Just tr) _ -> unlock cat tr + CncFun _ (Just tr) _ -> return tr + + AnyInd _ n -> look n c + ResParam _ _ -> return (QC m c) + ResValue _ -> return (QC m c) + _ -> Bad $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m) + +lookupResType :: SourceGrammar -> Ident -> Ident -> Err Type +lookupResType gr m c = do + mo <- lookupModule gr m + info <- lookupIdentInfo mo c + case info of + ResOper (Just t) _ -> return t + + -- used in reused concrete + CncCat _ _ _ -> return typeType + CncFun (Just (cat,cont,val)) _ _ -> do + val' <- lock cat val + return $ mkProd cont val' [] + AnyInd _ n -> lookupResType gr n c + ResParam _ _ -> return typePType + ResValue t -> return t + _ -> Bad $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m) + +lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))] +lookupOverload gr m c = do + mo <- lookupModule gr m + info <- lookupIdentInfo mo c + case info of + ResOverload os tysts -> do + tss <- mapM (\x -> lookupOverload gr x c) os + return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) | + (ty,tr) <- tysts] ++ + concat tss + + AnyInd _ n -> lookupOverload gr n c + _ -> Bad $ render (ppIdent c <+> text "is not an overloaded operation") + +-- | returns the original 'Info' and the module where it was found +lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err (Ident,Info) +lookupOrigInfo gr m c = do + mo <- lookupModule gr m + info <- lookupIdentInfo mo c + case info of + AnyInd _ n -> lookupOrigInfo gr n c + i -> return (m,i) + +allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)] +allOrigInfos gr m = errVal [] $ do + mo <- lookupModule gr m + return [(c,i) | (c,_) <- tree2list (jments mo), Ok (_,i) <- [look c]] + where + look = lookupOrigInfo gr m + +lookupParamValues :: SourceGrammar -> Ident -> Ident -> Err [Term] +lookupParamValues gr m c = do + (_,info) <- lookupOrigInfo gr m c + case info of + ResParam _ (Just pvs) -> return pvs + _ -> Bad $ render (ppIdent c <+> text "has no parameter values defined in resource" <+> ppIdent m) + +allParamValues :: SourceGrammar -> Type -> Err [Term] +allParamValues cnc ptyp = case ptyp of + _ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]] + QC p c -> lookupParamValues cnc p c + Q p c -> lookupResDef cnc p c >>= allParamValues cnc + RecType r -> do + let (ls,tys) = unzip $ sortByFst r + tss <- mapM (allParamValues cnc) tys + return [R (zipAssign ls ts) | ts <- combinations tss] + _ -> Bad (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp)) + where + -- to normalize records and record types + sortByFst = sortBy (\ x y -> compare (fst x) (fst y)) + +lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Int,Maybe [Equation]) +lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) $ do + mo <- lookupModule gr m + info <- lookupIdentInfo mo c + case info of + AbsFun _ a d -> return (a,d) + AnyInd _ n -> lookupAbsDef gr n c + _ -> return (Nothing,Nothing) + +lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type +lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed? +lookupLincat gr m c = do + mo <- lookupModule gr m + info <- lookupIdentInfo mo c + case info of + CncCat (Just t) _ _ -> return t + AnyInd _ n -> lookupLincat gr n c + _ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m)) + +-- | this is needed at compile time +lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type +lookupFunType gr m c = do + mo <- lookupModule gr m + info <- lookupIdentInfo mo c + case info of + AbsFun (Just t) _ _ -> return t + AnyInd _ n -> lookupFunType gr n c + _ -> Bad (render (text "cannot find type of" <+> ppIdent c)) + +-- | this is needed at compile time +lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context +lookupCatContext gr m c = do + mo <- lookupModule gr m + info <- lookupIdentInfo mo c + case info of + AbsCat (Just co) _ -> return co + AnyInd _ n -> lookupCatContext gr n c + _ -> Bad (render (text "unknown category" <+> ppIdent c)) diff --git a/src/compiler/GF/Grammar/MMacros.hs b/src/compiler/GF/Grammar/MMacros.hs new file mode 100644 index 000000000..a7f746b66 --- /dev/null +++ b/src/compiler/GF/Grammar/MMacros.hs @@ -0,0 +1,279 @@ +---------------------------------------------------------------------- +-- | +-- 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.Printer +import GF.Infra.Ident +import GF.Compile.Refresh +import GF.Grammar.Values +----import GrammarST +import GF.Grammar.Macros + +import Control.Monad +import qualified Data.ByteString.Char8 as BS +import Text.PrettyPrint + +{- +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) + +metasTree :: Tree -> [MetaId] +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 +-} + +type Var = Ident + +uVal :: Val +uVal = vClos uExp + +vClos :: Exp -> Val +vClos = VClos [] + +uExp :: Exp +uExp = Meta meta0 + +mExp, mExp0 :: Exp +mExp = Meta meta0 +mExp0 = mExp + +meta2exp :: MetaId -> 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 + +atomIsMeta :: Atom -> Bool +atomIsMeta atom = case atom of + AtM _ -> True + _ -> False + +getMetaAtom :: Atom -> Err MetaId +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 (uncurry Q cat) [Meta i | i <- [1..length cont]] + +val2cat :: Val -> Err Cat +val2cat v = liftM valCat (val2exp v) + +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 b x t -> let y = mkFreshVarX ss x in + Abs b y (substTerm (y:ss) ((x, Vr y):g) t) + Prod b x a t -> let y = mkFreshVarX ss x in + Prod b y (substTerm ss g a) (substTerm (y:ss) ((x,Vr y):g) t) + _ -> c + +metaSubstExp :: MetaSubst -> [(MetaId,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 Bad (render (text "unsafe value substitution" <+> ppValue Unqualified 0 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 $ uncurry Q c + VGen i x -> if safe + then Bad (render (text "unsafe val2exp" <+> ppValue Unqualified 0 v)) + else return $ Vr $ x --- in editing, no alpha conversions presentv + VRecType xs->do xs <- mapM (\(l,v) -> val2expP safe v >>= \e -> return (l,e)) xs + return (RecType xs) + VType -> return typeType + 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 Explicit)) 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 + +int2var :: Int -> Ident +int2var = identC . BS.pack . ('$':) . show + +meta0 :: MetaId +meta0 = 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 b x t -> let x' = chV x in Abs b x' $ qualif (x':xs) t + Prod b x a t -> Prod b x (qualif xs a) $ qualif (x:xs) t + 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 $ ident2bs x + +string2var :: BS.ByteString -> Ident +string2var s = case BS.unpack s of + c:'_':i -> identV (BS.singleton c) (readIntArg i) --- + _ -> identC 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 b x t -> let x' = ind x d in Abs b x' $ qualif (d+1, (x,x'):g) t + Prod b x a t -> let x' = ind x d in Prod b x' (qualif dg a) $ qualif (d+1, (x,x'):g) t + 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 $ ident2bs x `BS.append` BS.singleton '_' `BS.append` BS.pack (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/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs new file mode 100644 index 000000000..799cd9ec5 --- /dev/null +++ b/src/compiler/GF/Grammar/Macros.hs @@ -0,0 +1,627 @@ +---------------------------------------------------------------------- +-- | +-- 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.Infra.Ident +import GF.Infra.Modules +import GF.Grammar.Grammar +import GF.Grammar.Values +import GF.Grammar.Predef +import GF.Grammar.Printer + +import Control.Monad (liftM, liftM2) +import Data.Char (isDigit) +import Data.List (sortBy,nub) +import Text.PrettyPrint + +typeForm :: Type -> (Context, Cat, [Term]) +typeForm t = + case t of + Prod b x a t -> + let (x', cat, args) = typeForm t + in ((b,x,a):x', cat, args) + App c a -> + let (_, cat, args) = typeForm c + in ([],cat,args ++ [a]) + Q m c -> ([],(m,c),[]) + QC m c -> ([],(m,c),[]) + Sort c -> ([],(identW, c),[]) + _ -> error (render (text "no normal form of type" <+> ppTerm Unqualified 0 t)) + +typeFormCnc :: Type -> (Context, Type) +typeFormCnc t = + case t of + Prod b x a t -> let (x', v) = typeFormCnc t + in ((b,x,a):x',v) + _ -> ([],t) + +valCat :: Type -> Cat +valCat typ = + let (_,cat,_) = typeForm typ + in cat + +valType :: Type -> Type +valType typ = + let (_,cat,xx) = typeForm typ --- not optimal to do in this way + in mkApp (uncurry Q cat) xx + +valTypeCnc :: Type -> Type +valTypeCnc typ = snd (typeFormCnc typ) + +typeSkeleton :: Type -> ([(Int,Cat)],Cat) +typeSkeleton typ = + let (cont,cat,_) = typeForm typ + args = map (\(b,x,t) -> typeSkeleton t) cont + in ([(length c, v) | (c,v) <- args], cat) + +catSkeleton :: Type -> ([Cat],Cat) +catSkeleton typ = + let (args,val) = typeSkeleton typ + in (map snd args, val) + +funsToAndFrom :: Type -> (Cat, [(Cat,[Int])]) +funsToAndFrom t = + let (cs,v) = catSkeleton t + cis = zip cs [0..] + in (v, [(c,[i | (c',i) <- cis, c' == c]) | c <- cs]) + +isRecursiveType :: Type -> Bool +isRecursiveType t = + let (cc,c) = catSkeleton t -- thus recursivity on Cat level + in 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 b x a t -> liftM ((b,x,a):) $ contextOfType t + _ -> return [] + +termForm :: Term -> Err ([(BindType,Ident)], Term, [Term]) +termForm t = case t of + Abs b x t -> + do (x', fun, args) <- termForm t + return ((b,x):x', fun, args) + App c a -> + do (_,fun, args) <- termForm c + return ([],fun,args ++ [a]) + _ -> + return ([],t,[]) + +termFormCnc :: Term -> ([(BindType,Ident)], Term) +termFormCnc t = case t of + Abs b x t -> ((b,x):xs, t') where (xs,t') = termFormCnc t + _ -> ([],t) + +appForm :: Term -> (Term, [Term]) +appForm t = case t of + App c a -> (fun, args ++ [a]) where (fun, args) = appForm c + _ -> (t,[]) + +mkProdSimple :: Context -> Term -> Term +mkProdSimple c t = mkProd c t [] + +mkProd :: Context -> Term -> [Term] -> Term +mkProd [] typ args = mkApp typ args +mkProd ((b,x,a):dd) typ args = Prod b x a (mkProd dd typ args) + +mkTerm :: ([(BindType,Ident)], Term, [Term]) -> Term +mkTerm (xx,t,aa) = mkAbs xx (mkApp t aa) + +mkApp :: Term -> [Term] -> Term +mkApp = foldl App + +mkAbs :: [(BindType,Ident)] -> Term -> Term +mkAbs xx t = foldr (uncurry Abs) t xx + +appCons :: Ident -> [Term] -> Term +appCons = mkApp . Cn + +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 = (==) + +uType :: Type +uType = Cn cUndefinedType + +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] + +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 [(identC x, t) | (LIdent x,(_,t)) <- fs] + _ -> Bad (render (text "record expected, found" <+> ppTerm Unqualified 0 t)) + +typeType, typePType, typeStr, typeTok, typeStrs :: Term + +typeType = Sort cType +typePType = Sort cPType +typeStr = Sort cStr +typeTok = Sort cTok +typeStrs = Sort cStrs + +typeString, typeFloat, typeInt :: Term +typeInts :: Integer -> Term +typePBool :: Term +typeError :: Term + +typeString = cnPredef cString +typeInt = cnPredef cInt +typeFloat = cnPredef cFloat +typeInts i = App (cnPredef cInts) (EInt i) +typePBool = cnPredef cPBool +typeError = cnPredef cErrorType + +isTypeInts :: Term -> Maybe Integer +isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i +isTypeInts _ = Nothing + +isPredefConstant :: Term -> Bool +isPredefConstant t = case t of + Q mod _ | mod == cPredef || mod == cPredefAbs -> True + _ -> False + +cnPredef :: Ident -> Term +cnPredef f = Q cPredef f + +mkSelects :: Term -> [Term] -> Term +mkSelects t tt = foldl S t tt + +mkTable :: [Term] -> Term -> Term +mkTable tt t = foldr Table t tt + +mkCTable :: [(BindType,Ident)] -> Term -> Term +mkCTable ids v = foldr ccase v ids where + ccase (_,x) t = T TRaw [(PV x,t)] + +mkHypo :: Term -> Hypo +mkHypo typ = (Explicit,identW, typ) + +eqStrIdent :: Ident -> Ident -> Bool +eqStrIdent = (==) + +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 identW + +mkFunType :: [Type] -> Type -> Type +mkFunType tt t = mkProd [(Explicit,identW, ty) | ty <- tt] t [] -- nondep prod + +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 $ render (text "clashing labels" <+> hsep (map ppLabel ls)) + _ -> Bad $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 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 $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2) + +-- | default linearization type +defLinType :: Type +defLinType = RecType [(theLinLabel, typeStr)] + +-- | 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 . showIdent + +symbolOfIdent :: Ident -> String +symbolOfIdent = showIdent + +symid :: Ident -> String +symid = symbolOfIdent + +justIdentOf :: Term -> Maybe Ident +justIdentOf (Vr x) = Just x +justIdentOf (Cn x) = Just x +justIdentOf _ = Nothing + +linTypeStr :: Type +linTypeStr = mkRecType linLabel [typeStr] -- default lintype {s :: Str} + +linAsStr :: String -> Term +linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s} + +term2patt :: Term -> Err Patt +term2patt trm = case termForm trm of + Ok ([], Vr x, []) | x == identW -> return PW + | otherwise -> return (PV 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 id, [Vr a,b]) | id == cAs -> do + b' <- term2patt b + return (PAs a b') + Ok ([], Cn id, [a]) | id == cNeg -> do + a' <- term2patt a + return (PNeg a') + Ok ([], Cn id, [a]) | id == cRep -> do + a' <- term2patt a + return (PRep a') + Ok ([], Cn id, []) | id == cRep -> do + return PChar + Ok ([], Cn id,[K s]) | id == cChars -> do + return $ PChars s + Ok ([], Cn id, [a,b]) | id == cSeq -> do + a' <- term2patt a + b' <- term2patt b + return (PSeq a' b') + Ok ([], Cn id, [a,b]) | id == cAlt -> do + a' <- term2patt a + b' <- term2patt b + return (PAlt a' b') + + Ok ([], Cn c, []) -> do + return (PMacro c) + + _ -> Bad $ render (text "no pattern corresponds to term" <+> ppTerm Unqualified 0 trm) + +patt2term :: Patt -> Term +patt2term pt = case pt of + PV x -> Vr x + PW -> Vr identW --- not parsable, should not occur + 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 -> appCons cAs [Vr x, patt2term p] --- an encoding + PChar -> appCons cChar [] --- an encoding + PChars s -> appCons cChars [K s] --- an encoding + PSeq a b -> appCons cSeq [(patt2term a), (patt2term b)] --- an encoding + PAlt a b -> appCons cAlt [(patt2term a), (patt2term b)] --- an encoding + PRep a -> appCons cRep [(patt2term a)] --- an encoding + PNeg a -> appCons cNeg [(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 ultimate cases in a table; preserves pattern list +allCaseValues :: Term -> [([Patt],Term)] +allCaseValues trm = case trm of + T _ cs -> [(p:ps, t) | (p,t0) <- cs, (ps,t) <- allCaseValues t0] + _ -> [([],trm)] + +-- | 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 + Strs ts -> mapM strsFromTerm ts >>= return . concat + _ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 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 b x t -> + do t' <- co t + return (Abs b x t') + Prod b x a t -> + do a' <- co a + t' <- co t + return (Prod b x a' t') + 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) + 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') + + 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 + Strs tt -> mapM co tt >>= return . Strs + + EPattType ty -> + do ty' <- co ty + return (EPattType ty') + + ELincat c ty -> + do ty' <- co ty + return (ELincat c ty') + + ELin c ty -> + do ty' <- co ty + return (ELin c 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 + 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 + +-- | 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 + _ -> collectOp wo trm + where wo = wordsInTerm + +noExist :: Term +noExist = FV [] + +defaultLinType :: Type +defaultLinType = mkRecType linLabel [typeStr] + +-- normalize records and record types; put s first + +sortRec :: [(Label,a)] -> [(Label,a)] +sortRec = sortBy ordLabel where + ordLabel (r1,_) (r2,_) = + case (showIdent (label2ident r1), showIdent (label2ident r2)) of + ("s",_) -> LT + (_,"s") -> GT + (s1,s2) -> compare s1 s2 + +-- | dependency check, detecting circularities and returning topo-sorted list + +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 (Just ty) = opersIn ty + opty _ = [] + pts i = case i of + ResOper pty pt -> [pty,pt] + ResParam (Just ps) _ -> [Just 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 (Just co) _ -> [Just ty | (_,_,ty) <- co] + _ -> [] + +topoSortJments :: SourceModule -> Err [(Ident,Info)] +topoSortJments (m,mi) = do + is <- either + return + (\cyc -> Bad (render (text "circular definitions:" <+> fsep (map ppIdent (head cyc))))) + (topoTest (allDependencies (==m) (jments mi))) + return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]]) diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y new file mode 100644 index 000000000..320053674 --- /dev/null +++ b/src/compiler/GF/Grammar/Parser.y @@ -0,0 +1,739 @@ +{ +{-# OPTIONS -fno-warn-overlapping-patterns #-} +module GF.Grammar.Parser + ( P, runP + , pModDef + , pModHeader + , pExp + ) where + +import GF.Infra.Ident +import GF.Infra.Modules +import GF.Infra.Option +import GF.Data.Operations +import GF.Grammar.Predef +import GF.Grammar.Grammar +import GF.Grammar.Macros +import GF.Grammar.Lexer +import qualified Data.ByteString.Char8 as BS +import GF.Compile.Update (buildAnyTree) +} + +%name pModDef ModDef +%partial pModHeader ModHeader +%name pExp Exp + +-- no lexer declaration +%monad { P } { >>= } { return } +%lexer { lexer } { T_EOF } +%tokentype { Token } + + +%token + '!' { T_exclmark } + '#' { T_patt } + '$' { T_int_label } + '(' { T_oparen } + ')' { T_cparen } + '*' { T_star } + '**' { T_starstar } + '+' { T_plus } + '++' { T_plusplus } + ',' { T_comma } + '-' { T_minus } + '->' { T_rarrow } + '.' { T_dot } + '/' { T_alt } + ':' { T_colon } + ';' { T_semicolon } + '<' { T_less } + '=' { T_equal } + '=>' { T_big_rarrow} + '>' { T_great } + '?' { T_questmark } + '@' { T_at } + '[' { T_obrack } + ']' { T_cbrack } + '{' { T_ocurly } + '}' { T_ccurly } + '\\' { T_lam } + '\\\\' { T_lamlam } + '_' { T_underscore} + '|' { T_bar } + 'PType' { T_PType } + 'Str' { T_Str } + 'Strs' { T_Strs } + 'Tok' { T_Tok } + 'Type' { T_Type } + 'abstract' { T_abstract } + 'case' { T_case } + 'cat' { T_cat } + 'concrete' { T_concrete } + 'data' { T_data } + 'def' { T_def } + 'flags' { T_flags } + 'fun' { T_fun } + 'in' { T_in } + 'incomplete' { T_incomplete} + 'instance' { T_instance } + 'interface' { T_interface } + 'let' { T_let } + 'lin' { T_lin } + 'lincat' { T_lincat } + 'lindef' { T_lindef } + 'of' { T_of } + 'open' { T_open } + 'oper' { T_oper } + 'param' { T_param } + 'pattern' { T_pattern } + 'pre' { T_pre } + 'printname' { T_printname } + 'resource' { T_resource } + 'strs' { T_strs } + 'table' { T_table } + 'variants' { T_variants } + 'where' { T_where } + 'with' { T_with } + +Integer { (T_Integer $$) } +Double { (T_Double $$) } +String { (T_String $$) } +LString { (T_LString $$) } +Ident { (T_Ident $$) } + + +%% + +ModDef :: { SourceModule } +ModDef + : ComplMod ModType '=' ModBody {% + do let mstat = $1 + (mtype,id) = $2 + (extends,with,content) = $4 + (opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) } + mapM_ (checkInfoType mtype) jments + defs <- case buildAnyTree id [(i,d) | (i,_,d) <- jments] of + Ok x -> return x + Bad msg -> fail msg + let poss = buildTree [(i,(fname,mkSrcSpan p)) | (i,p,_) <- jments] + fname = showIdent id ++ ".gf" + + mkSrcSpan :: (Posn, Posn) -> (Int,Int) + mkSrcSpan (Pn l1 _, Pn l2 _) = (l1,l2) + + return (id, ModInfo mtype mstat opts extends with opens [] defs poss) } + +ModHeader :: { SourceModule } +ModHeader + : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ; + (mtype,id) = $2 ; + (extends,with,opens) = $4 } + in (id, ModInfo mtype mstat noOptions extends with opens [] emptyBinTree emptyBinTree) } + +ComplMod :: { ModuleStatus } +ComplMod + : {- empty -} { MSComplete } + | 'incomplete' { MSIncomplete } + +ModType :: { (ModuleType Ident,Ident) } +ModType + : 'abstract' Ident { (MTAbstract, $2) } + | 'resource' Ident { (MTResource, $2) } + | 'interface' Ident { (MTInterface, $2) } + | 'concrete' Ident 'of' Ident { (MTConcrete $4, $2) } + | 'instance' Ident 'of' Ident { (MTInstance $4, $2) } + +ModHeaderBody :: { ( [(Ident,MInclude Ident)] + , Maybe (Ident,MInclude Ident,[(Ident,Ident)]) + , [OpenSpec Ident] + ) } +ModHeaderBody + : ListIncluded '**' Included 'with' ListInst '**' ModOpen { ($1, Just (fst $3,snd $3,$5), $7) } + | ListIncluded '**' Included 'with' ListInst { ($1, Just (fst $3,snd $3,$5), []) } + | ListIncluded '**' ModOpen { ($1, Nothing, $3) } + | ListIncluded { ($1, Nothing, []) } + | Included 'with' ListInst '**' ModOpen { ([], Just (fst $1,snd $1,$3), $5) } + | Included 'with' ListInst { ([], Just (fst $1,snd $1,$3), []) } + | ModOpen { ([], Nothing, $1) } + +ModOpen :: { [OpenSpec Ident] } +ModOpen + : { [] } + | 'open' ListOpen { $2 } + +ModBody :: { ( [(Ident,MInclude Ident)] + , Maybe (Ident,MInclude Ident,[(Ident,Ident)]) + , Maybe ([OpenSpec Ident],[(Ident,SrcSpan,Info)],Options) + ) } +ModBody + : ListIncluded '**' Included 'with' ListInst '**' ModContent { ($1, Just (fst $3,snd $3,$5), Just $7) } + | ListIncluded '**' Included 'with' ListInst { ($1, Just (fst $3,snd $3,$5), Nothing) } + | ListIncluded '**' ModContent { ($1, Nothing, Just $3) } + | ListIncluded { ($1, Nothing, Nothing) } + | Included 'with' ListInst '**' ModContent { ([], Just (fst $1,snd $1,$3), Just $5) } + | Included 'with' ListInst { ([], Just (fst $1,snd $1,$3), Nothing) } + | ModContent { ([], Nothing, Just $1) } + | ModBody ';' { $1 } + +ModContent :: { ([OpenSpec Ident],[(Ident,SrcSpan,Info)],Options) } +ModContent + : '{' ListTopDef '}' { ([],[d | Left ds <- $2, d <- ds],concatOptions [o | Right o <- $2]) } + | 'open' ListOpen 'in' '{' ListTopDef '}' { ($2,[d | Left ds <- $5, d <- ds],concatOptions [o | Right o <- $5]) } + +ListTopDef :: { [Either [(Ident,SrcSpan,Info)] Options] } +ListTopDef + : {- empty -} { [] } + | TopDef ListTopDef { $1 : $2 } + +ListOpen :: { [OpenSpec Ident] } +ListOpen + : Open { [$1] } + | Open ',' ListOpen { $1 : $3 } + +Open :: { OpenSpec Ident } +Open + : Ident { OSimple $1 } + | '(' Ident '=' Ident ')' { OQualif $2 $4 } + +ListInst :: { [(Ident,Ident)] } +ListInst + : Inst { [$1] } + | Inst ',' ListInst { $1 : $3 } + +Inst :: { (Ident,Ident) } +Inst + : '(' Ident '=' Ident ')' { ($2,$4) } + +ListIncluded :: { [(Ident,MInclude Ident)] } +ListIncluded + : Included { [$1] } + | Included ',' ListIncluded { $1 : $3 } + +Included :: { (Ident,MInclude Ident) } +Included + : Ident { ($1,MIAll ) } + | Ident '[' ListIdent ']' { ($1,MIOnly $3) } + | Ident '-' '[' ListIdent ']' { ($1,MIExcept $4) } + +TopDef :: { Either [(Ident,SrcSpan,Info)] Options } +TopDef + : 'cat' ListCatDef { Left $2 } + | 'fun' ListFunDef { Left $2 } + | 'def' ListDefDef { Left $2 } + | 'data' ListDataDef { Left $2 } + | 'param' ListParamDef { Left $2 } + | 'oper' ListOperDef { Left $2 } + | 'lincat' ListTermDef { Left [(f, pos, CncCat (Just e) Nothing Nothing ) | (f,pos,e) <- $2] } + | 'lindef' ListTermDef { Left [(f, pos, CncCat Nothing (Just e) Nothing ) | (f,pos,e) <- $2] } + | 'lin' ListLinDef { Left $2 } + | 'printname' 'cat' ListTermDef { Left [(f, pos, CncCat Nothing Nothing (Just e)) | (f,pos,e) <- $3] } + | 'printname' 'fun' ListTermDef { Left [(f, pos, CncFun Nothing Nothing (Just e)) | (f,pos,e) <- $3] } + | 'flags' ListFlagDef { Right $2 } + +CatDef :: { [(Ident,SrcSpan,Info)] } +CatDef + : Posn Ident ListDDecl Posn { [($2, ($1,$4), AbsCat (Just $3) Nothing)] } + | Posn '[' Ident ListDDecl ']' Posn { listCatDef $3 ($1,$6) $4 0 } + | Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef $3 ($1,$9) $4 (fromIntegral $7) } + +FunDef :: { [(Ident,SrcSpan,Info)] } +FunDef + : Posn ListIdent ':' Exp Posn { [(fun, ($1,$5), AbsFun (Just $4) Nothing (Just [])) | fun <- $2] } + +DefDef :: { [(Ident,SrcSpan,Info)] } +DefDef + : Posn ListName '=' Exp Posn { [(f, ($1,$5),AbsFun Nothing (Just 0) (Just [([],$4)])) | f <- $2] } + | Posn Name ListPatt '=' Exp Posn { [($2,($1,$6),AbsFun Nothing (Just (length $3)) (Just [($3,$5)]))] } + +DataDef :: { [(Ident,SrcSpan,Info)] } +DataDef + : Posn Ident '=' ListDataConstr Posn { ($2, ($1,$5), AbsCat Nothing (Just (map Cn $4))) : + [(fun, ($1,$5), AbsFun Nothing Nothing Nothing) | fun <- $4] } + | Posn ListIdent ':' Exp Posn { -- (snd (valCat $4), ($1,$5), AbsCat Nothing (Just (map Cn $2))) : + [(fun, ($1,$5), AbsFun (Just $4) Nothing Nothing) | fun <- $2] } + +ParamDef :: { [(Ident,SrcSpan,Info)] } +ParamDef + : Posn Ident '=' ListParConstr Posn { ($2, ($1,$5), ResParam (Just $4) Nothing) : + [(f, ($1,$5), ResValue (mkProdSimple co (Cn $2))) | (f,co) <- $4] } + | Posn Ident Posn { [($2, ($1,$3), ResParam Nothing Nothing)] } + +OperDef :: { [(Ident,SrcSpan,Info)] } +OperDef + : Posn ListName ':' Exp Posn { [(i, ($1,$5), info) | i <- $2, info <- mkOverload (Just $4) Nothing ] } + | Posn ListName '=' Exp Posn { [(i, ($1,$5), info) | i <- $2, info <- mkOverload Nothing (Just $4)] } + | Posn Name ListArg '=' Exp Posn { [(i, ($1,$6), info) | i <- [$2], info <- mkOverload Nothing (Just (mkAbs $3 $5))] } + | Posn ListName ':' Exp '=' Exp Posn { [(i, ($1,$7), info) | i <- $2, info <- mkOverload (Just $4) (Just $6)] } + +LinDef :: { [(Ident,SrcSpan,Info)] } +LinDef + : Posn ListName '=' Exp Posn { [(f, ($1,$5), CncFun Nothing (Just $4) Nothing) | f <- $2] } + | Posn Name ListArg '=' Exp Posn { [($2, ($1,$6), CncFun Nothing (Just (mkAbs $3 $5)) Nothing)] } + +TermDef :: { [(Ident,SrcSpan,Term)] } +TermDef + : Posn ListName '=' Exp Posn { [(i,($1,$5),$4) | i <- $2] } + +FlagDef :: { Options } +FlagDef + : Posn Ident '=' Ident Posn {% case parseModuleOptions ["--" ++ showIdent $2 ++ "=" ++ showIdent $4] of + Ok x -> return x + Bad msg -> failLoc $1 msg } + +ListDataConstr :: { [Ident] } +ListDataConstr + : Ident { [$1] } + | Ident '|' ListDataConstr { $1 : $3 } + +ParConstr :: { Param } +ParConstr + : Ident ListDDecl { ($1,$2) } + +ListLinDef :: { [(Ident,SrcSpan,Info)] } +ListLinDef + : LinDef ';' { $1 } + | LinDef ';' ListLinDef { $1 ++ $3 } + +ListDefDef :: { [(Ident,SrcSpan,Info)] } +ListDefDef + : DefDef ';' { $1 } + | DefDef ';' ListDefDef { $1 ++ $3 } + +ListOperDef :: { [(Ident,SrcSpan,Info)] } +ListOperDef + : OperDef ';' { $1 } + | OperDef ';' ListOperDef { $1 ++ $3 } + +ListCatDef :: { [(Ident,SrcSpan,Info)] } +ListCatDef + : CatDef ';' { $1 } + | CatDef ';' ListCatDef { $1 ++ $3 } + +ListFunDef :: { [(Ident,SrcSpan,Info)] } +ListFunDef + : FunDef ';' { $1 } + | FunDef ';' ListFunDef { $1 ++ $3 } + +ListDataDef :: { [(Ident,SrcSpan,Info)] } +ListDataDef + : DataDef ';' { $1 } + | DataDef ';' ListDataDef { $1 ++ $3 } + +ListParamDef :: { [(Ident,SrcSpan,Info)] } +ListParamDef + : ParamDef ';' { $1 } + | ParamDef ';' ListParamDef { $1 ++ $3 } + +ListTermDef :: { [(Ident,SrcSpan,Term)] } +ListTermDef + : TermDef ';' { $1 } + | TermDef ';' ListTermDef { $1 ++ $3 } + +ListFlagDef :: { Options } +ListFlagDef + : FlagDef ';' { $1 } + | FlagDef ';' ListFlagDef { addOptions $1 $3 } + +ListParConstr :: { [Param] } +ListParConstr + : ParConstr { [$1] } + | ParConstr '|' ListParConstr { $1 : $3 } + +ListIdent :: { [Ident] } +ListIdent + : Ident { [$1] } + | Ident ',' ListIdent { $1 : $3 } + +ListIdent2 :: { [Ident] } +ListIdent2 + : Ident { [$1] } + | Ident ListIdent2 { $1 : $2 } + +Name :: { Ident } +Name + : Ident { $1 } + | '[' Ident ']' { mkListId $2 } + +ListName :: { [Ident] } +ListName + : Name { [$1] } + | Name ',' ListName { $1 : $3 } + +LocDef :: { [(Ident, Maybe Type, Maybe Term)] } +LocDef + : ListIdent ':' Exp { [(lab,Just $3,Nothing) | lab <- $1] } + | ListIdent '=' Exp { [(lab,Nothing,Just $3) | lab <- $1] } + | ListIdent ':' Exp '=' Exp { [(lab,Just $3,Just $5) | lab <- $1] } + +ListLocDef :: { [(Ident, Maybe Type, Maybe Term)] } +ListLocDef + : {- empty -} { [] } + | LocDef { $1 } + | LocDef ';' ListLocDef { $1 ++ $3 } + +Exp :: { Term } +Exp + : Exp1 '|' Exp { FV [$1,$3] } + | '\\' ListBind '->' Exp { mkAbs $2 $4 } + | '\\\\' ListBind '=>' Exp { mkCTable $2 $4 } + | Decl '->' Exp { mkProdSimple $1 $3 } + | Exp3 '=>' Exp { Table $1 $3 } + | 'let' '{' ListLocDef '}' 'in' Exp {% + do defs <- mapM tryLoc $3 + return $ mkLet defs $6 } + | 'let' ListLocDef 'in' Exp {% + do defs <- mapM tryLoc $2 + return $ mkLet defs $4 } + | Exp3 'where' '{' ListLocDef '}' {% + do defs <- mapM tryLoc $4 + return $ mkLet defs $1 } + | 'in' Exp5 String { Example $2 $3 } + | Exp1 { $1 } + +Exp1 :: { Term } +Exp1 + : Exp2 '++' Exp1 { C $1 $3 } + | Exp2 { $1 } + +Exp2 :: { Term } +Exp2 + : Exp3 '+' Exp2 { Glue $1 $3 } + | Exp3 { $1 } + +Exp3 :: { Term } +Exp3 + : Exp3 '!' Exp4 { S $1 $3 } + | 'table' '{' ListCase '}' { T TRaw $3 } + | 'table' Exp6 '{' ListCase '}' { T (TTyped $2) $4 } + | 'table' Exp6 '[' ListExp ']' { V $2 $4 } + | Exp3 '*' Exp4 { case $1 of + RecType xs -> RecType (xs ++ [(tupleLabel (length xs+1),$3)]) + t -> RecType [(tupleLabel 1,$1), (tupleLabel 2,$3)] } + | Exp3 '**' Exp4 { ExtR $1 $3 } + | Exp4 { $1 } + +Exp4 :: { Term } +Exp4 + : Exp4 Exp5 { App $1 $2 } + | Exp4 '{' Exp '}' { App $1 (ImplArg $3) } + | 'case' Exp 'of' '{' ListCase '}' { let annot = case $2 of + Typed _ t -> TTyped t + _ -> TRaw + in S (T annot $5) $2 } + | 'variants' '{' ListExp '}' { FV $3 } + | 'pre' '{' ListCase '}' {% mkAlts $3 } + | 'pre' '{' String ';' ListAltern '}' { Alts (K $3, $5) } + | 'pre' '{' Ident ';' ListAltern '}' { Alts (Vr $3, $5) } + | 'strs' '{' ListExp '}' { Strs $3 } + | '#' Patt2 { EPatt $2 } + | 'pattern' Exp5 { EPattType $2 } + | 'lincat' Ident Exp5 { ELincat $2 $3 } + | 'lin' Ident Exp5 { ELin $2 $3 } + | Exp5 { $1 } + +Exp5 :: { Term } +Exp5 + : Exp5 '.' Label { P $1 $3 } + | Exp6 { $1 } + +Exp6 :: { Term } +Exp6 + : Ident { Vr $1 } + | Sort { Sort $1 } + | String { K $1 } + | Integer { EInt $1 } + | Double { EFloat $1 } + | '?' { Meta 0 } + | '[' ']' { Empty } + | '[' Ident Exps ']' { foldl App (Vr (mkListId $2)) $3 } + | '[' String ']' { case $2 of + [] -> Empty + str -> foldr1 C (map K (words str)) } + | '{' ListLocDef '}' {% mkR $2 } + | '<' ListTupleComp '>' { R (tuple2record $2) } + | '<' Exp ':' Exp '>' { Typed $2 $4 } + | LString { K $1 } + | '(' Exp ')' { $2 } + +ListExp :: { [Term] } +ListExp + : {- empty -} { [] } + | Exp { [$1] } + | Exp ';' ListExp { $1 : $3 } + +Exps :: { [Term] } +Exps + : {- empty -} { [] } + | Exp6 Exps { $1 : $2 } + +Patt :: { Patt } +Patt + : Patt '|' Patt1 { PAlt $1 $3 } + | Patt '+' Patt1 { PSeq $1 $3 } + | Patt1 { $1 } + +Patt1 :: { Patt } +Patt1 + : Ident ListPatt { PC $1 $2 } + | Ident '.' Ident ListPatt { PP $1 $3 $4 } + | Patt2 '*' { PRep $1 } + | Ident '@' Patt2 { PAs $1 $3 } + | '-' Patt2 { PNeg $2 } + | Patt2 { $1 } + +Patt2 :: { Patt } +Patt2 + : '?' { PChar } + | '[' String ']' { PChars $2 } + | '#' Ident { PMacro $2 } + | '#' Ident '.' Ident { PM $2 $4 } + | '_' { PW } + | Ident { PV $1 } + | Ident '.' Ident { PP $1 $3 [] } + | Integer { PInt $1 } + | Double { PFloat $1 } + | String { PString $1 } + | '{' ListPattAss '}' { PR $2 } + | '<' ListPattTupleComp '>' { (PR . tuple2recordPatt) $2 } + | '(' Patt ')' { $2 } + +PattAss :: { [(Label,Patt)] } +PattAss + : ListIdent '=' Patt { [(LIdent (ident2bs i),$3) | i <- $1] } + +Label :: { Label } +Label + : Ident { LIdent (ident2bs $1) } + | '$' Integer { LVar (fromIntegral $2) } + +Sort :: { Ident } +Sort + : 'Type' { cType } + | 'PType' { cPType } + | 'Tok' { cTok } + | 'Str' { cStr } + | 'Strs' { cStrs } + +ListPattAss :: { [(Label,Patt)] } +ListPattAss + : {- empty -} { [] } + | PattAss { $1 } + | PattAss ';' ListPattAss { $1 ++ $3 } + +ListPatt :: { [Patt] } +ListPatt + : PattArg { [$1] } + | PattArg ListPatt { $1 : $2 } + +PattArg :: { Patt } + : Patt2 { $1 } + | '{' Patt2 '}' { PImplArg $2 } + +Arg :: { [(BindType,Ident)] } +Arg + : Ident { [(Explicit,$1 )] } + | '_' { [(Explicit,identW)] } + | '{' ListIdent2 '}' { [(Implicit,v) | v <- $2] } + +ListArg :: { [(BindType,Ident)] } +ListArg + : Arg { $1 } + | Arg ListArg { $1 ++ $2 } + +Bind :: { [(BindType,Ident)] } +Bind + : Ident { [(Explicit,$1 )] } + | '_' { [(Explicit,identW)] } + | '{' ListIdent '}' { [(Implicit,v) | v <- $2] } + +ListBind :: { [(BindType,Ident)] } +ListBind + : Bind { $1 } + | Bind ',' ListBind { $1 ++ $3 } + +Decl :: { [Hypo] } +Decl + : '(' ListBind ':' Exp ')' { [(b,x,$4) | (b,x) <- $2] } + | Exp4 { [mkHypo $1] } + +ListTupleComp :: { [Term] } +ListTupleComp + : {- empty -} { [] } + | Exp { [$1] } + | Exp ',' ListTupleComp { $1 : $3 } + +ListPattTupleComp :: { [Patt] } +ListPattTupleComp + : {- empty -} { [] } + | Patt { [$1] } + | Patt ',' ListPattTupleComp { $1 : $3 } + +Case :: { Case } +Case + : Patt '=>' Exp { ($1,$3) } + +ListCase :: { [Case] } +ListCase + : Case { [$1] } + | Case ';' ListCase { $1 : $3 } + +Altern :: { (Term,Term) } +Altern + : Exp '/' Exp { ($1,$3) } + +ListAltern :: { [(Term,Term)] } +ListAltern + : Altern { [$1] } + | Altern ';' ListAltern { $1 : $3 } + +DDecl :: { [Hypo] } +DDecl + : '(' ListBind ':' Exp ')' { [(b,x,$4) | (b,x) <- $2] } + | Exp6 { [mkHypo $1] } + +ListDDecl :: { [Hypo] } +ListDDecl + : {- empty -} { [] } + | DDecl ListDDecl { $1 ++ $2 } + +Posn :: { Posn } +Posn + : {- empty -} {% getPosn } + + +{ + +happyError :: P a +happyError = fail "parse error" + +mkListId,mkConsId,mkBaseId :: Ident -> Ident +mkListId = prefixId (BS.pack "List") +mkConsId = prefixId (BS.pack "Cons") +mkBaseId = prefixId (BS.pack "Base") + +prefixId :: BS.ByteString -> Ident -> Ident +prefixId pref id = identC (BS.append pref (ident2bs id)) + +listCatDef :: Ident -> SrcSpan -> Context -> Int -> [(Ident,SrcSpan,Info)] +listCatDef id pos cont size = [catd,nilfund,consfund] + where + listId = mkListId id + baseId = mkBaseId id + consId = mkConsId id + + catd = (listId, pos, AbsCat (Just cont') (Just [Cn baseId,Cn consId])) + nilfund = (baseId, pos, AbsFun (Just niltyp) Nothing Nothing) + consfund = (consId, pos, AbsFun (Just constyp) Nothing Nothing) + + cont' = [(b,mkId x i,ty) | (i,(b,x,ty)) <- zip [0..] cont] + xs = map (\(b,x,t) -> Vr x) cont' + cd = mkHypo (mkApp (Vr id) xs) + lc = mkApp (Vr listId) xs + + niltyp = mkProdSimple (cont' ++ replicate size cd) lc + constyp = mkProdSimple (cont' ++ [cd, mkHypo lc]) lc + + mkId x i = if isWildIdent x then (varX i) else x + +tryLoc (c,mty,Just e) = return (c,(mty,e)) +tryLoc (c,_ ,_ ) = fail ("local definition of" +++ showIdent c +++ "without value") + +mkR [] = return $ RecType [] --- empty record always interpreted as record type +mkR fs@(f:_) = + case f of + (lab,Just ty,Nothing) -> mapM tryRT fs >>= return . RecType + _ -> mapM tryR fs >>= return . R + where + tryRT (lab,Just ty,Nothing) = return (ident2label lab,ty) + tryRT (lab,_ ,_ ) = fail $ "illegal record type field" +++ showIdent lab --- manifest fields ?! + + tryR (lab,mty,Just t) = return (ident2label lab,(mty,t)) + tryR (lab,_ ,_ ) = fail $ "illegal record field" +++ showIdent lab + +mkOverload pdt pdf@(Just df) = + case appForm df of + (keyw, ts@(_:_)) | isOverloading keyw -> + case last ts of + R fs -> [ResOverload [m | Vr m <- ts] [(ty,fu) | (_,(Just ty,fu)) <- fs]] + _ -> [ResOper pdt pdf] + _ -> [ResOper pdt pdf] + + -- to enable separare type signature --- not type-checked +mkOverload pdt@(Just df) pdf = + case appForm df of + (keyw, ts@(_:_)) | isOverloading keyw -> + case last ts of + RecType _ -> [] + _ -> [ResOper pdt pdf] + _ -> [ResOper pdt pdf] +mkOverload pdt pdf = [ResOper pdt pdf] + +isOverloading t = + case t of + Vr keyw | showIdent keyw == "overload" -> True -- overload is a "soft keyword" + _ -> False + + +type SrcSpan = (Posn,Posn) + + +checkInfoType MTAbstract (id,pos,info) = + case info of + AbsCat _ _ -> return () + AbsFun _ _ _ -> return () + _ -> failLoc (fst pos) "illegal definition in abstract module" +checkInfoType MTResource (id,pos,info) = + case info of + ResParam _ _ -> return () + ResValue _ -> return () + ResOper _ _ -> return () + ResOverload _ _ -> return () + _ -> failLoc (fst pos) "illegal definition in resource module" +checkInfoType MTInterface (id,pos,info) = + case info of + ResParam _ _ -> return () + ResValue _ -> return () + ResOper _ _ -> return () + ResOverload _ _ -> return () + _ -> failLoc (fst pos) "illegal definition in interface module" +checkInfoType (MTConcrete _) (id,pos,info) = + case info of + CncCat _ _ _ -> return () + CncFun _ _ _ -> return () + ResParam _ _ -> return () + ResValue _ -> return () + ResOper _ _ -> return () + ResOverload _ _ -> return () + _ -> failLoc (fst pos) "illegal definition in concrete module" +checkInfoType (MTInstance _) (id,pos,info) = + case info of + ResParam _ _ -> return () + ResValue _ -> return () + ResOper _ _ -> return () + _ -> failLoc (fst pos) "illegal definition in instance module" + + +mkAlts cs = case cs of + _:_ -> do + def <- mkDef (last cs) + alts <- mapM mkAlt (init cs) + return (Alts (def,alts)) + _ -> fail "empty alts" + where + mkDef (_,t) = return t + mkAlt (p,t) = do + ss <- mkStrs p + return (t,ss) + mkStrs p = case p of + PAlt a b -> do + Strs as <- mkStrs a + Strs bs <- mkStrs b + return $ Strs $ as ++ bs + PString s -> return $ Strs [K s] + PV x -> return (Vr x) --- for macros; not yet complete + PMacro x -> return (Vr x) --- for macros; not yet complete + PM m c -> return (Q m c) --- for macros; not yet complete + _ -> fail "no strs from pattern" + +} + diff --git a/src/compiler/GF/Grammar/PatternMatch.hs b/src/compiler/GF/Grammar/PatternMatch.hs new file mode 100644 index 000000000..b8f7eff7d --- /dev/null +++ b/src/compiler/GF/Grammar/PatternMatch.hs @@ -0,0 +1,165 @@ +---------------------------------------------------------------------- +-- | +-- 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.Printer + +import Data.List +import Control.Monad +import Text.PrettyPrint +import Debug.Trace + +matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution) +matchPattern pts term = + if not (isInConstantForm term) + then Bad (render (text "variables occur in" <+> ppTerm Unqualified 0 term)) + else do + term' <- mkK term + errIn (render (text "trying patterns" <+> hsep (punctuate comma (map (ppPatt Unqualified 0 . fst) pts)))) $ + findMatch [([p],t) | (p,t) <- pts] [term'] + where + -- to capture all Str with string pattern matching + mkK s = case s of + C _ _ -> do + s' <- getS s + return (K (unwords s')) + _ -> return s + + getS s = case s of + K w -> return [w] + C v w -> liftM2 (++) (getS v) (getS w) + Empty -> return [] + _ -> Bad (render (text "cannot get string from" <+> ppTerm Unqualified 0 s)) + +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 (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms)))) + (patts,_):_ | length patts /= length terms -> + Bad (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+> + text "cannot take" <+> hsep (map (ppTerm Unqualified 0) 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 in matchPattern + trym p t' = + case (p,t') of + (_,(x,Empty,y)) -> trym p (x,K [],y) -- because "" = [""] = [] + (PW, _) | 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' + + (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 [] + _ -> Bad (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 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 [] + + _ -> Bad (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t)) + +isInConstantForm :: Term -> Bool +isInConstantForm trm = case trm of + Cn _ -> True + Con _ -> True + Q _ _ -> True + QC _ _ -> True + Abs _ _ _ -> True + C c a -> isInConstantForm c && isInConstantForm a + 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] + 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/compiler/GF/Grammar/Predef.hs b/src/compiler/GF/Grammar/Predef.hs new file mode 100644 index 000000000..045df06ca --- /dev/null +++ b/src/compiler/GF/Grammar/Predef.hs @@ -0,0 +1,180 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Grammar.Predef +-- Maintainer : kr.angelov +-- Stability : (stable) +-- Portability : (portable) +-- +-- Predefined identifiers and labels which the compiler knows +---------------------------------------------------------------------- + + +module GF.Grammar.Predef + ( cType + , cPType + , cTok + , cStr + , cStrs + , cPredefAbs, cPredefCnc, cPredef + , cInt + , cFloat + , cString + , cInts + , cPBool + , cErrorType + , cOverload + , cUndefinedType + , isPredefCat + + , cPTrue, cPFalse + + , cLength, cDrop, cTake, cTk, cDp, cEqStr, cOccur + , cOccurs, cEqInt, cLessInt, cPlus, cShow, cRead + , cToStr, cMapStr, cError + + -- hacks + , cMeta, cAs, cChar, cChars, cSeq, cAlt, cRep + , cNeg, cCNC, cConflict + ) where + +import GF.Infra.Ident +import qualified Data.ByteString.Char8 as BS + +cType :: Ident +cType = identC (BS.pack "Type") + +cPType :: Ident +cPType = identC (BS.pack "PType") + +cTok :: Ident +cTok = identC (BS.pack "Tok") + +cStr :: Ident +cStr = identC (BS.pack "Str") + +cStrs :: Ident +cStrs = identC (BS.pack "Strs") + +cPredefAbs :: Ident +cPredefAbs = identC (BS.pack "PredefAbs") + +cPredefCnc :: Ident +cPredefCnc = identC (BS.pack "PredefCnc") + +cPredef :: Ident +cPredef = identC (BS.pack "Predef") + +cInt :: Ident +cInt = identC (BS.pack "Int") + +cFloat :: Ident +cFloat = identC (BS.pack "Float") + +cString :: Ident +cString = identC (BS.pack "String") + +cInts :: Ident +cInts = identC (BS.pack "Ints") + +cPBool :: Ident +cPBool = identC (BS.pack "PBool") + +cErrorType :: Ident +cErrorType = identC (BS.pack "Error") + +cOverload :: Ident +cOverload = identC (BS.pack "overload") + +cUndefinedType :: Ident +cUndefinedType = identC (BS.pack "UndefinedType") + +isPredefCat :: Ident -> Bool +isPredefCat c = elem c [cInt,cString,cFloat] + +cPTrue :: Ident +cPTrue = identC (BS.pack "PTrue") + +cPFalse :: Ident +cPFalse = identC (BS.pack "PFalse") + +cLength :: Ident +cLength = identC (BS.pack "length") + +cDrop :: Ident +cDrop = identC (BS.pack "drop") + +cTake :: Ident +cTake = identC (BS.pack "take") + +cTk :: Ident +cTk = identC (BS.pack "tk") + +cDp :: Ident +cDp = identC (BS.pack "dp") + +cEqStr :: Ident +cEqStr = identC (BS.pack "eqStr") + +cOccur :: Ident +cOccur = identC (BS.pack "occur") + +cOccurs :: Ident +cOccurs = identC (BS.pack "occurs") + +cEqInt :: Ident +cEqInt = identC (BS.pack "eqInt") + +cLessInt :: Ident +cLessInt = identC (BS.pack "lessInt") + +cPlus :: Ident +cPlus = identC (BS.pack "plus") + +cShow :: Ident +cShow = identC (BS.pack "show") + +cRead :: Ident +cRead = identC (BS.pack "read") + +cToStr :: Ident +cToStr = identC (BS.pack "toStr") + +cMapStr :: Ident +cMapStr = identC (BS.pack "mapStr") + +cError :: Ident +cError = identC (BS.pack "error") + + +--- hacks: dummy identifiers used in various places +--- Not very nice! + +cMeta :: Ident +cMeta = identC (BS.singleton '?') + +cAs :: Ident +cAs = identC (BS.singleton '@') + +cChar :: Ident +cChar = identC (BS.singleton '?') + +cChars :: Ident +cChars = identC (BS.pack "[]") + +cSeq :: Ident +cSeq = identC (BS.pack "+") + +cAlt :: Ident +cAlt = identC (BS.pack "|") + +cRep :: Ident +cRep = identC (BS.pack "*") + +cNeg :: Ident +cNeg = identC (BS.pack "-") + +cCNC :: Ident +cCNC = identC (BS.pack "CNC") + +cConflict :: Ident +cConflict = IC (BS.pack "#conflict") diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs new file mode 100644 index 000000000..06cac9705 --- /dev/null +++ b/src/compiler/GF/Grammar/Printer.hs @@ -0,0 +1,317 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Grammar.Printer +-- Maintainer : Krasimir Angelov +-- Stability : (stable) +-- Portability : (portable) +-- +----------------------------------------------------------------------------- + +module GF.Grammar.Printer + ( TermPrintQual(..) + , ppIdent + , ppLabel + , ppModule + , ppJudgement + , ppTerm + , ppTermTabular + , ppPatt + , ppValue + , ppConstrs + + , showTerm, TermPrintStyle(..) + ) where + +import GF.Infra.Ident +import GF.Infra.Modules +import GF.Infra.Option +import GF.Grammar.Values +import GF.Grammar.Grammar +import GF.Data.Operations +import Text.PrettyPrint + +import Data.Maybe (maybe) +import Data.List (intersperse) + +data TermPrintQual = Qualified | Unqualified + +ppModule :: TermPrintQual -> SourceModule -> Doc +ppModule q (mn, ModInfo mtype mstat opts exts with opens _ jments _) = + hdr $$ nest 2 (ppOptions opts $$ vcat (map (ppJudgement q) defs)) $$ ftr + where + defs = tree2list jments + + hdr = complModDoc <+> modTypeDoc <+> equals <+> + hsep (intersperse (text "**") $ + filter (not . isEmpty) $ [ commaPunct ppExtends exts + , maybe empty ppWith with + , if null opens + then lbrace + else text "open" <+> commaPunct ppOpenSpec opens <+> text "in" <+> lbrace + ]) + + ftr = rbrace + + complModDoc = + case mstat of + MSComplete -> empty + MSIncomplete -> text "incomplete" + + modTypeDoc = + case mtype of + MTAbstract -> text "abstract" <+> ppIdent mn + MTResource -> text "resource" <+> ppIdent mn + MTConcrete abs -> text "concrete" <+> ppIdent mn <+> text "of" <+> ppIdent abs + MTInterface -> text "interface" <+> ppIdent mn + MTInstance int -> text "instance" <+> ppIdent mn <+> text "of" <+> ppIdent int + + ppExtends (id,MIAll ) = ppIdent id + ppExtends (id,MIOnly incs) = ppIdent id <+> brackets (commaPunct ppIdent incs) + ppExtends (id,MIExcept incs) = ppIdent id <+> char '-' <+> brackets (commaPunct ppIdent incs) + + ppWith (id,ext,opens) = ppExtends (id,ext) <+> text "with" <+> commaPunct ppInstSpec opens + +ppOptions opts = + text "flags" $$ + nest 2 (vcat [text option <+> equals <+> str value <+> semi | (option,value) <- optionsGFO opts]) + +ppJudgement q (id, AbsCat pcont pconstrs) = + text "cat" <+> ppIdent id <+> + (case pcont of + Just cont -> hsep (map (ppDecl q) cont) + Nothing -> empty) <+> semi $$ + case pconstrs of + Just costrs -> text "data" <+> ppIdent id <+> equals <+> fsep (intersperse (char '|') (map (ppTerm q 0) costrs)) <+> semi + Nothing -> empty +ppJudgement q (id, AbsFun ptype _ pexp) = + (case ptype of + Just typ -> text "fun" <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi + Nothing -> empty) $$ + (case pexp of + Just [] -> empty + Just eqs -> text "def" <+> vcat [ppIdent id <+> hsep (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi | (ps,e) <- eqs] + Nothing -> empty) +ppJudgement q (id, ResParam pparams _) = + text "param" <+> ppIdent id <+> + (case pparams of + Just ps -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps)) + _ -> empty) <+> semi +ppJudgement q (id, ResValue pvalue) = empty +ppJudgement q (id, ResOper ptype pexp) = + text "oper" <+> ppIdent id <+> + (case ptype of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty} $$ + case pexp of {Just e -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi +ppJudgement q (id, ResOverload ids defs) = + text "oper" <+> ppIdent id <+> equals <+> + (text "overload" <+> lbrace $$ + nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e) | (ty,e) <- defs]) $$ + rbrace) <+> semi +ppJudgement q (id, CncCat ptype pexp pprn) = + (case ptype of + Just typ -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi + Nothing -> empty) $$ + (case pexp of + Just exp -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi + Nothing -> empty) $$ + (case pprn of + Just prn -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi + Nothing -> empty) +ppJudgement q (id, CncFun ptype pdef pprn) = + (case pdef of + Just e -> let (xs,e') = getAbs e + in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi + Nothing -> empty) $$ + (case pprn of + Just prn -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi + Nothing -> empty) +ppJudgement q (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi + +ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e) + in prec d 0 (char '\\' <> commaPunct ppBind xs <+> text "->" <+> ppTerm q 0 e') +ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of + ([],_) -> text "table" <+> lbrace $$ + nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ + rbrace + (vs,e) -> prec d 0 (text "\\\\" <> commaPunct ppIdent vs <+> text "=>" <+> ppTerm q 0 e) +ppTerm q d (T (TTyped t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$ + nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ + rbrace +ppTerm q d (T (TComp t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$ + nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ + rbrace +ppTerm q d (T (TWild t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$ + nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ + rbrace +ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit + then prec d 0 (ppTerm q 4 a <+> text "->" <+> ppTerm q 0 b) + else prec d 0 (parens (ppBind (bt,x) <+> colon <+> ppTerm q 0 a) <+> text "->" <+> ppTerm q 0 b) +ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> text "=>" <+> ppTerm q 0 vt) +ppTerm q d (Let l e) = let (ls,e') = getLet e + in prec d 0 (text "let" <+> vcat (map (ppLocDef q) (l:ls)) $$ text "in" <+> ppTerm q 0 e') +ppTerm q d (Example e s)=prec d 0 (text "in" <+> ppTerm q 5 e <+> str s) +ppTerm q d (C e1 e2) =prec d 1 (ppTerm q 2 e1 <+> text "++" <+> ppTerm q 1 e2) +ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> char '+' <+> ppTerm q 2 e2) +ppTerm q d (S x y) = case x of + T annot xs -> let e = case annot of + TRaw -> y + TTyped t -> Typed y t + TComp t -> Typed y t + TWild t -> Typed y t + in text "case" <+> ppTerm q 0 e <+> text "of" <+> lbrace $$ + nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$ + rbrace + _ -> prec d 3 (ppTerm q 3 x <+> text "!" <+> ppTerm q 4 y) +ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> text "**" <+> ppTerm q 4 y) +ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y) +ppTerm q d (V e es) = text "table" <+> ppTerm q 6 e <+> lbrace $$ + nest 2 (fsep (punctuate semi (map (ppTerm q 0) es))) $$ + rbrace +ppTerm q d (FV es) = text "variants" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es))) +ppTerm q d (Alts (e,xs))=text "pre" <+> braces (ppTerm q 0 e <> semi <+> fsep (punctuate semi (map (ppAltern q) xs))) +ppTerm q d (Strs es) = text "strs" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es))) +ppTerm q d (EPatt p) = prec d 4 (char '#' <+> ppPatt q 2 p) +ppTerm q d (EPattType t)=prec d 4 (text "pattern" <+> ppTerm q 0 t) +ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> char '.' <> ppLabel l) +ppTerm q d (Cn id) = ppIdent id +ppTerm q d (Vr id) = ppIdent id +ppTerm q d (Q m id) = ppQIdent q m id +ppTerm q d (QC m id) = ppQIdent q m id +ppTerm q d (Sort id) = ppIdent id +ppTerm q d (K s) = str s +ppTerm q d (EInt n) = integer n +ppTerm q d (EFloat f) = double f +ppTerm q d (Meta _) = char '?' +ppTerm q d (Empty) = text "[]" +ppTerm q d (R xs) = braces (fsep (punctuate semi [ppLabel l <+> + fsep [case mb_t of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty}, + equals <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs])) +ppTerm q d (RecType xs)= braces (fsep (punctuate semi [ppLabel l <+> colon <+> ppTerm q 0 t | (l,t) <- xs])) +ppTerm q d (Typed e t) = char '<' <> ppTerm q 0 e <+> colon <+> ppTerm q 0 t <> char '>' + +ppTermTabular :: TermPrintQual -> Term -> [(Doc,Doc)] +ppTermTabular q = pr where + pr t = case t of + R rs -> + [(ppLabel lab <+> char '.' <+> path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val] + T _ cs -> + [(ppPatt q 0 patt <+> text "=>" <+> path, str) | (patt, val ) <- cs, (path,str) <- pr val] + V _ cs -> + [(char '#' <> int i <+> text "=>" <+> path, str) | (i, val ) <- zip [0..] cs, (path,str) <- pr val] + _ -> [(empty,ps t)] + ps t = case t of + K s -> text s + C s u -> ps s <+> ps u + FV ts -> hsep (intersperse (char '/') (map ps ts)) + _ -> ppTerm q 0 t + +ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> text "->" <+> ppTerm q 0 e + +ppCase q (p,e) = ppPatt q 0 p <+> text "=>" <+> ppTerm q 0 e + +ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '|' <+> ppPatt q 1 p2) +ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '+' <+> ppPatt q 1 p2) +ppPatt q d (PC f ps) = if null ps + then ppIdent f + else prec d 1 (ppIdent f <+> hsep (map (ppPatt q 2) ps)) +ppPatt q d (PP f g ps) = if null ps + then ppQIdent q f g + else prec d 1 (ppQIdent q f g <+> hsep (map (ppPatt q 2) ps)) +ppPatt q d (PRep p) = prec d 1 (ppPatt q 2 p <> char '*') +ppPatt q d (PAs f p) = prec d 1 (ppIdent f <> char '@' <> ppPatt q 2 p) +ppPatt q d (PNeg p) = prec d 1 (char '-' <> ppPatt q 2 p) +ppPatt q d (PChar) = char '?' +ppPatt q d (PChars s) = brackets (str s) +ppPatt q d (PMacro id) = char '#' <> ppIdent id +ppPatt q d (PM m id) = char '#' <> ppIdent m <> char '.' <> ppIdent id +ppPatt q d PW = char '_' +ppPatt q d (PV id) = ppIdent id +ppPatt q d (PInt n) = integer n +ppPatt q d (PFloat f) = double f +ppPatt q d (PString s) = str s +ppPatt q d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs])) + +ppValue :: TermPrintQual -> Int -> Val -> Doc +ppValue q d (VGen i x) = ppIdent x <> text "{-" <> int i <> text "-}" ---- latter part for debugging +ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v) +ppValue q d (VCn (_,c)) = ppIdent c +ppValue q d (VClos env e) = case e of + Meta _ -> ppTerm q d e <> ppEnv env + _ -> ppTerm q d e ---- ++ prEnv env ---- for debugging +ppValue q d (VRecType xs) = braces (hsep (punctuate comma [ppLabel l <> char '=' <> ppValue q 0 v | (l,v) <- xs])) +ppValue q d VType = text "Type" + +ppConstrs :: Constraints -> [Doc] +ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> text "<>" <+> ppValue Unqualified 0 w)) + +ppEnv :: Env -> Doc +ppEnv e = hcat (map (\(x,t) -> braces (ppIdent x <> text ":=" <> ppValue Unqualified 0 t)) e) + +str s = doubleQuotes (text s) + +ppDecl q (_,id,typ) + | id == identW = ppTerm q 4 typ + | otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ) + +ppDDecl q (_,id,typ) + | id == identW = ppTerm q 6 typ + | otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ) + +ppIdent = text . showIdent + +ppQIdent q m id = + case q of + Qualified -> ppIdent m <> char '.' <> ppIdent id + Unqualified -> ppIdent id + +ppLabel = ppIdent . label2ident + +ppOpenSpec (OSimple id) = ppIdent id +ppOpenSpec (OQualif id n) = parens (ppIdent id <+> equals <+> ppIdent n) + +ppInstSpec (id,n) = parens (ppIdent id <+> equals <+> ppIdent n) + +ppLocDef q (id, (mbt, e)) = + ppIdent id <+> + (case mbt of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty} <+> equals <+> ppTerm q 0 e) <+> semi + +ppBind (Explicit,v) = ppIdent v +ppBind (Implicit,v) = braces (ppIdent v) + +ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y + +ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt) + +commaPunct f ds = (hcat (punctuate comma (map f ds))) + +prec d1 d2 doc + | d1 > d2 = parens doc + | otherwise = doc + +getAbs :: Term -> ([(BindType,Ident)], Term) +getAbs (Abs bt v e) = let (xs,e') = getAbs e + in ((bt,v):xs,e') +getAbs e = ([],e) + +getCTable :: Term -> ([Ident], Term) +getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e + in (v:vs,e') +getCTable (T TRaw [(PW, e)]) = let (vs,e') = getCTable e + in (identW:vs,e') +getCTable e = ([],e) + +getLet :: Term -> ([LocalDef], Term) +getLet (Let l e) = let (ls,e') = getLet e + in (l:ls,e') +getLet e = ([],e) + +showTerm :: TermPrintStyle -> TermPrintQual -> Term -> String +showTerm style q t = render $ + case style of + TermPrintTable -> vcat [p <+> s | (p,s) <- ppTermTabular q t] + TermPrintAll -> vcat [ s | (p,s) <- ppTermTabular q t] + TermPrintDefault -> ppTerm q 0 t + +data TermPrintStyle + = TermPrintTable + | TermPrintAll + | TermPrintDefault diff --git a/src/compiler/GF/Grammar/Unify.hs b/src/compiler/GF/Grammar/Unify.hs new file mode 100644 index 000000000..9bb49cfe2 --- /dev/null +++ b/src/compiler/GF/Grammar/Unify.hs @@ -0,0 +1,97 @@ +---------------------------------------------------------------------- +-- | +-- 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 +import GF.Data.Operations + +import Text.PrettyPrint +import Data.List (partition) + +unifyVal :: Constraints -> Err (Constraints,MetaSubst) +unifyVal cs0 = do + let (cs1,cs2) = partition notSolvable cs0 + let (us,vs) = unzip cs2 + 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 = [(MetaId, Term)] +type Constrs = [(Term, Term)] + +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 :: Term -> Term -> 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 + _ -> Bad (render (text "fail unify" <+> ppTerm Unqualified 0 e1)) + (RecType xs,RecType ys) | xs == ys -> return g + _ -> Bad (render (text "fail unify" <+> ppTerm Unqualified 0 e1)) + +extend :: Unifier -> MetaId -> Term -> Err Unifier +extend g s t | (t == Meta s) = return g + | occCheck s t = Bad (render (text "occurs check" <+> ppTerm Unqualified 0 t)) + | True = return ((s, t) : g) + +subst_all :: Unifier -> Term -> Err Term +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 :: [(MetaId,Term)] -> Term -> Term +substMetas subst trm = case trm of + Meta x -> case lookup x subst of + Just t -> t + _ -> trm + _ -> composSafeOp (substMetas subst) trm + +occCheck :: MetaId -> Term -> 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/compiler/GF/Grammar/Values.hs b/src/compiler/GF/Grammar/Values.hs new file mode 100644 index 000000000..1a68ddc89 --- /dev/null +++ b/src/compiler/GF/Grammar/Values.hs @@ -0,0 +1,96 @@ +---------------------------------------------------------------------- +-- | +-- 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 +--Z Tree, TrNode(..), Atom(..), + Binds, Constraints, MetaSubst, + -- * for TC + valAbsInt, valAbsFloat, valAbsString, vType, + isPredefCat, + eType, +--Z tree2exp, loc2treeFocus + ) where + +import GF.Data.Operations +---Z import GF.Data.Zipper + +import GF.Infra.Ident +import GF.Grammar.Grammar +import GF.Grammar.Predef + +-- values used in TC type checking + +type Exp = Term + +data Val = VGen Int Ident | VApp Val Val | VCn QIdent | VRecType [(Label,Val)] | 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 MetaId | AtV Ident | AtL String | AtI Integer | AtF Double + deriving (Eq,Show) +-} +type Binds = [(Ident,Val)] +type Constraints = [(Val,Val)] +type MetaSubst = [(MetaId,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 + +eType :: Exp +eType = Sort cType + +{- +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/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs new file mode 100644 index 000000000..8a1b42cdf --- /dev/null +++ b/src/compiler/GF/Infra/CheckM.hs @@ -0,0 +1,77 @@ +---------------------------------------------------------------------- +-- | +-- 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, Message, runCheck, + checkError, checkCond, checkWarn, + checkErr, checkIn, checkMap + ) where + +import GF.Data.Operations +import GF.Infra.Ident +import GF.Grammar.Grammar +import GF.Grammar.Printer + +import qualified Data.Map as Map +import Text.PrettyPrint + +type Message = Doc +data CheckResult a + = Fail [Message] + | Success a [Message] +newtype Check a = Check {unCheck :: Context -> [Message] -> CheckResult a} + +instance Monad Check where + return x = Check (\ctxt msgs -> Success x msgs) + f >>= g = Check (\ctxt msgs -> case unCheck f ctxt msgs of + Success x msgs -> unCheck (g x) ctxt msgs + Fail msgs -> Fail msgs) + +instance ErrorMonad Check where + raise s = checkError (text s) + handle f h = Check (\ctxt msgs -> case unCheck f ctxt msgs of + Success x msgs -> Success x msgs + Fail (msg:msgs) -> unCheck (h (render msg)) ctxt msgs) + +checkError :: Message -> Check a +checkError msg = Check (\ctxt msgs -> Fail (msg : msgs)) + +checkCond :: Message -> Bool -> Check () +checkCond s b = if b then return () else checkError s + +-- | warnings should be reversed in the end +checkWarn :: Message -> Check () +checkWarn msg = Check (\ctxt msgs -> Success () ((text "Warning:" <+> msg) : msgs)) + +runCheck :: Check a -> Err (a,String) +runCheck c = + case unCheck c [] [] of + Fail msgs -> Bad ( render (vcat (reverse msgs))) + Success v msgs -> Ok (v, render (vcat (reverse msgs))) + +checkMap :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b) +checkMap f map = do xs <- mapM (\(k,v) -> do v <- f k v + return (k,v)) (Map.toList map) + return (Map.fromAscList xs) + +checkErr :: Err a -> Check a +checkErr (Ok x) = return x +checkErr (Bad err) = checkError (text err) + +checkIn :: Doc -> Check a -> Check a +checkIn msg c = Check $ \ctxt msgs -> + case unCheck c ctxt [] of + Fail msgs' -> Fail ((msg $$ nest 3 (vcat (reverse msgs'))) : msgs) + Success v msgs' | null msgs' -> Success v msgs + | otherwise -> Success v ((msg $$ nest 3 (vcat (reverse msgs'))) : msgs) diff --git a/src/compiler/GF/Infra/CompactPrint.hs b/src/compiler/GF/Infra/CompactPrint.hs new file mode 100644 index 000000000..486c9e183 --- /dev/null +++ b/src/compiler/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/compiler/GF/Infra/Dependencies.hs b/src/compiler/GF/Infra/Dependencies.hs new file mode 100644 index 000000000..af2088711 --- /dev/null +++ b/src/compiler/GF/Infra/Dependencies.hs @@ -0,0 +1,61 @@ +module GF.Infra.Dependencies ( + depGraph + ) where + +import GF.Grammar.Grammar +import GF.Infra.Modules +import GF.Infra.Ident + +depGraph :: SourceGrammar -> String +depGraph = prDepGraph . grammar2moddeps + +prDepGraph :: [(Ident,ModDeps)] -> String +prDepGraph deps = unlines $ [ + "digraph {" + ] ++ + map mkNode deps ++ + concatMap mkArrows deps ++ [ + "}" + ] + where + mkNode (i,dep) = unwords [showIdent i, "[",nodeAttr (modtype dep),"]"] + nodeAttr ty = case ty of + MTAbstract -> "style = \"solid\", shape = \"box\"" + MTConcrete _ -> "style = \"solid\", shape = \"ellipse\"" + _ -> "style = \"dashed\", shape = \"ellipse\"" + mkArrows (i,dep) = + [unwords [showIdent i,"->",showIdent j,"[",arrowAttr "of","]"] | j <- ofs dep] ++ + [unwords [showIdent i,"->",showIdent j,"[",arrowAttr "ex","]"] | j <- extendeds dep] ++ + [unwords [showIdent i,"->",showIdent j,"[",arrowAttr "op","]"] | j <- openeds dep] ++ + [unwords [showIdent i,"->",showIdent j,"[",arrowAttr "ed","]"] | j <- extrads dep] + arrowAttr s = case s of + "of" -> "style = \"solid\", arrowhead = \"empty\"" + "ex" -> "style = \"solid\"" + "op" -> "style = \"dashed\"" + "ed" -> "style = \"dotted\"" + +data ModDeps = ModDeps { + modtype :: ModuleType Ident, + ofs :: [Ident], + extendeds :: [Ident], + openeds :: [Ident], + extrads :: [Ident], + functors :: [Ident], + interfaces :: [Ident], + instances :: [Ident] + } + +noModDeps = ModDeps MTAbstract [] [] [] [] [] [] [] + +grammar2moddeps :: SourceGrammar -> [(Ident,ModDeps)] +grammar2moddeps gr = [(i,depMod m) | (i,m) <- modules gr] where + depMod m = noModDeps{ + modtype = mtype m, + ofs = case mtype m of + MTConcrete i -> [i] + MTInstance i -> [i] + _ -> [], + extendeds = map fst (extend m), + openeds = map openedModule (opens m), + extrads = mexdeps m + } diff --git a/src/compiler/GF/Infra/GetOpt.hs b/src/compiler/GF/Infra/GetOpt.hs new file mode 100644 index 000000000..ede561c90 --- /dev/null +++ b/src/compiler/GF/Infra/GetOpt.hs @@ -0,0 +1,381 @@ +-- This is a version of System.Console.GetOpt which has been hacked to +-- support long options with a single dash. Since we don't want the annoying +-- clash with short options that start with the same character as a long +-- one, we don't allow short options to be given together (e.g. -zxf), +-- nor do we allow options to be given as any unique prefix. + +----------------------------------------------------------------------------- +-- | +-- Module : System.Console.GetOpt +-- Copyright : (c) Sven Panne 2002-2005 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- This library provides facilities for parsing the command-line options +-- in a standalone program. It is essentially a Haskell port of the GNU +-- @getopt@ library. +-- +----------------------------------------------------------------------------- + +{- +Sven Panne Oct. 1996 (small +changes Dec. 1997) + +Two rather obscure features are missing: The Bash 2.0 non-option hack +(if you don't already know it, you probably don't want to hear about +it...) and the recognition of long options with a single dash +(e.g. '-help' is recognised as '--help', as long as there is no short +option 'h'). + +Other differences between GNU's getopt and this implementation: + +* To enforce a coherent description of options and arguments, there + are explanation fields in the option/argument descriptor. + +* Error messages are now more informative, but no longer POSIX + compliant... :-( + +And a final Haskell advertisement: The GNU C implementation uses well +over 1100 lines, we need only 195 here, including a 46 line example! +:-) +-} + +--module System.Console.GetOpt ( +module GF.Infra.GetOpt ( + -- * GetOpt + getOpt, getOpt', + usageInfo, + ArgOrder(..), + OptDescr(..), + ArgDescr(..), + + -- * Examples + + -- |To hopefully illuminate the role of the different data structures, + -- here are the command-line options for a (very simple) compiler, + -- done in two different ways. + -- The difference arises because the type of 'getOpt' is + -- parameterized by the type of values derived from flags. + + -- ** Interpreting flags as concrete values + -- $example1 + + -- ** Interpreting flags as transformations of an options record + -- $example2 +) where + +import Prelude -- necessary to get dependencies right + +import Data.List ( isPrefixOf, find ) + +-- |What to do with options following non-options +data ArgOrder a + = RequireOrder -- ^ no option processing after first non-option + | Permute -- ^ freely intersperse options and non-options + | ReturnInOrder (String -> a) -- ^ wrap non-options into options + +{-| +Each 'OptDescr' describes a single option. + +The arguments to 'Option' are: + +* list of short option characters + +* list of long option strings (without \"--\") + +* argument descriptor + +* explanation of option for user +-} +data OptDescr a = -- description of a single options: + Option [Char] -- list of short option characters + [String] -- list of long option strings (without "--") + (ArgDescr a) -- argument descriptor + String -- explanation of option for user + +-- |Describes whether an option takes an argument or not, and if so +-- how the argument is injected into a value of type @a@. +data ArgDescr a + = NoArg a -- ^ no argument expected + | ReqArg (String -> a) String -- ^ option requires argument + | OptArg (Maybe String -> a) String -- ^ optional argument + +data OptKind a -- kind of cmd line arg (internal use only): + = Opt a -- an option + | UnreqOpt String -- an un-recognized option + | NonOpt String -- a non-option + | EndOfOpts -- end-of-options marker (i.e. "--") + | OptErr String -- something went wrong... + +-- | Return a string describing the usage of a command, derived from +-- the header (first argument) and the options described by the +-- second argument. +usageInfo :: String -- header + -> [OptDescr a] -- option descriptors + -> String -- nicely formatted decription of options +usageInfo header optDescr = unlines (header:table) + where (ss,ls,ds) = (unzip3 . concatMap fmtOpt) optDescr + table = zipWith3 paste (sameLen ss) (sameLen ls) ds + paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z + sameLen xs = flushLeft ((maximum . map length) xs) xs + flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ] + +fmtOpt :: OptDescr a -> [(String,String,String)] +fmtOpt (Option sos los ad descr) = + case lines descr of + [] -> [(sosFmt,losFmt,"")] + (d:ds) -> (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ] + where sepBy _ [] = "" + sepBy _ [x] = x + sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs + sosFmt = sepBy ',' (map (fmtShort ad) sos) + losFmt = sepBy ',' (map (fmtLong ad) los) + +fmtShort :: ArgDescr a -> Char -> String +fmtShort (NoArg _ ) so = "-" ++ [so] +fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad +fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]" + +fmtLong :: ArgDescr a -> String -> String +fmtLong (NoArg _ ) lo = "--" ++ lo +fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad +fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" + +{-| +Process the command-line, and return the list of values that matched +(and those that didn\'t). The arguments are: + +* The order requirements (see 'ArgOrder') + +* The option descriptions (see 'OptDescr') + +* The actual command line arguments (presumably got from + 'System.Environment.getArgs'). + +'getOpt' returns a triple consisting of the option arguments, a list +of non-options, and a list of error messages. +-} +getOpt :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a],[String],[String]) -- (options,non-options,error messages) +getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) + where (os,xs,us,es) = getOpt' ordering optDescr args + +{-| +This is almost the same as 'getOpt', but returns a quadruple +consisting of the option arguments, a list of non-options, a list of +unrecognized options, and a list of error messages. +-} +getOpt' :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) +getOpt' _ _ [] = ([],[],[],[]) +getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering + where procNextOpt (Opt o) _ = (o:os,xs,us,es) + procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) + procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) + procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) + procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) + procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) + procNextOpt EndOfOpts Permute = ([],rest,[],[]) + procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) + procNextOpt (OptErr e) _ = (os,xs,us,e:es) + + (opt,rest) = getNext arg args optDescr + (os,xs,us,es) = getOpt' ordering optDescr rest + +-- take a look at the next cmd line arg and decide what to do with it +getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) +getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr +getNext ('-' :xs) rest optDescr = longOpt xs rest optDescr +getNext a rest _ = (NonOpt a,rest) + +-- handle long option +longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +longOpt ls rs optDescr = long ads arg rs + where (opt,arg) = break (=='=') ls + options = [ o | o@(Option ss xs _ _) <- optDescr + , opt `elem` map (:[]) ss || opt `elem` xs ] + ads = [ ad | Option _ _ ad _ <- options ] + optStr = ("--"++opt) + + long (_:_:_) _ rest = (errAmbig options optStr,rest) + long [NoArg a ] [] rest = (Opt a,rest) + long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) + long [ReqArg _ d] [] [] = (errReq d optStr,[]) + long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) + long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) + long [OptArg f _] [] rest = (Opt (f Nothing),rest) + long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) + long _ _ rest = (UnreqOpt ("--"++ls),rest) + + +-- miscellaneous error formatting + +errAmbig :: [OptDescr a] -> String -> OptKind a +errAmbig ods optStr = OptErr (usageInfo header ods) + where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" + +errReq :: String -> String -> OptKind a +errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") + +errUnrec :: String -> String +errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" + +errNoArg :: String -> OptKind a +errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") + +{- +----------------------------------------------------------------------------------------- +-- and here a small and hopefully enlightening example: + +data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show + +options :: [OptDescr Flag] +options = + [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files", + Option ['V','?'] ["version","release"] (NoArg Version) "show version info", + Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump", + Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"] + +out :: Maybe String -> Flag +out Nothing = Output "stdout" +out (Just o) = Output o + +test :: ArgOrder Flag -> [String] -> String +test order cmdline = case getOpt order options cmdline of + (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n" + (_,_,errs) -> concat errs ++ usageInfo header options + where header = "Usage: foobar [OPTION...] files..." + +-- example runs: +-- putStr (test RequireOrder ["foo","-v"]) +-- ==> options=[] args=["foo", "-v"] +-- putStr (test Permute ["foo","-v"]) +-- ==> options=[Verbose] args=["foo"] +-- putStr (test (ReturnInOrder Arg) ["foo","-v"]) +-- ==> options=[Arg "foo", Verbose] args=[] +-- putStr (test Permute ["foo","--","-v"]) +-- ==> options=[] args=["foo", "-v"] +-- putStr (test Permute ["-?o","--name","bar","--na=baz"]) +-- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[] +-- putStr (test Permute ["--ver","foo"]) +-- ==> option `--ver' is ambiguous; could be one of: +-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- Usage: foobar [OPTION...] files... +-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- -o[FILE] --output[=FILE] use FILE for dump +-- -n USER --name=USER only dump USER's files +----------------------------------------------------------------------------------------- +-} + +{- $example1 + +A simple choice for the type associated with flags is to define a type +@Flag@ as an algebraic type representing the possible flags and their +arguments: + +> module Opts1 where +> +> import System.Console.GetOpt +> import Data.Maybe ( fromMaybe ) +> +> data Flag +> = Verbose | Version +> | Input String | Output String | LibDir String +> deriving Show +> +> options :: [OptDescr Flag] +> options = +> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr" +> , Option ['V','?'] ["version"] (NoArg Version) "show version number" +> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE" +> , Option ['c'] [] (OptArg inp "FILE") "input FILE" +> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory" +> ] +> +> inp,outp :: Maybe String -> Flag +> outp = Output . fromMaybe "stdout" +> inp = Input . fromMaybe "stdin" +> +> compilerOpts :: [String] -> IO ([Flag], [String]) +> compilerOpts argv = +> case getOpt Permute options argv of +> (o,n,[] ) -> return (o,n) +> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) +> where header = "Usage: ic [OPTION...] files..." + +Then the rest of the program will use the constructed list of flags +to determine it\'s behaviour. + +-} + +{- $example2 + +A different approach is to group the option values in a record of type +@Options@, and have each flag yield a function of type +@Options -> Options@ transforming this record. + +> module Opts2 where +> +> import System.Console.GetOpt +> import Data.Maybe ( fromMaybe ) +> +> data Options = Options +> { optVerbose :: Bool +> , optShowVersion :: Bool +> , optOutput :: Maybe FilePath +> , optInput :: Maybe FilePath +> , optLibDirs :: [FilePath] +> } deriving Show +> +> defaultOptions = Options +> { optVerbose = False +> , optShowVersion = False +> , optOutput = Nothing +> , optInput = Nothing +> , optLibDirs = [] +> } +> +> options :: [OptDescr (Options -> Options)] +> options = +> [ Option ['v'] ["verbose"] +> (NoArg (\ opts -> opts { optVerbose = True })) +> "chatty output on stderr" +> , Option ['V','?'] ["version"] +> (NoArg (\ opts -> opts { optShowVersion = True })) +> "show version number" +> , Option ['o'] ["output"] +> (OptArg ((\ f opts -> opts { optOutput = Just f }) . fromMaybe "output") +> "FILE") +> "output FILE" +> , Option ['c'] [] +> (OptArg ((\ f opts -> opts { optInput = Just f }) . fromMaybe "input") +> "FILE") +> "input FILE" +> , Option ['L'] ["libdir"] +> (ReqArg (\ d opts -> opts { optLibDirs = optLibDirs opts ++ [d] }) "DIR") +> "library directory" +> ] +> +> compilerOpts :: [String] -> IO (Options, [String]) +> compilerOpts argv = +> case getOpt Permute options argv of +> (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n) +> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) +> where header = "Usage: ic [OPTION...] files..." + +Similarly, each flag could yield a monadic function transforming a record, +of type @Options -> IO Options@ (or any other monad), allowing option +processing to perform actions of the chosen monad, e.g. printing help or +version messages, checking that file arguments exist, etc. + +-} diff --git a/src/compiler/GF/Infra/Ident.hs b/src/compiler/GF/Infra/Ident.hs new file mode 100644 index 000000000..efe6f9261 --- /dev/null +++ b/src/compiler/GF/Infra/Ident.hs @@ -0,0 +1,152 @@ +---------------------------------------------------------------------- +-- | +-- 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(..), ident2bs, showIdent, + identC, identV, identA, identAV, identW, + argIdent, varStr, varX, isWildIdent, varIndex, + -- * refreshing identifiers + IdState, initIdStateN, initIdState, + lookVar, refVar, refVarPlus + ) where + +import GF.Data.Operations +import qualified Data.ByteString.Char8 as BS +-- import Monad + + +-- | the constructors labelled /INTERNAL/ are +-- internal representation never returned by the parser +data Ident = + IC {-# UNPACK #-} !BS.ByteString -- ^ raw identifier after parsing, resolved in Rename + | IW -- ^ wildcard +-- +-- below this constructor: internal representation never returned by the parser + | IV {-# UNPACK #-} !BS.ByteString {-# UNPACK #-} !Int -- ^ /INTERNAL/ variable + | IA {-# UNPACK #-} !BS.ByteString {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat at position + | IAV {-# UNPACK #-} !BS.ByteString {-# UNPACK #-} !Int {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat with bindings at position +-- + + deriving (Eq, Ord, Show, Read) + +ident2bs :: Ident -> BS.ByteString +ident2bs i = case i of + IC s -> s + IV s n -> BS.append s (BS.pack ('_':show n)) + IA s j -> BS.append s (BS.pack ('_':show j)) + IAV s b j -> BS.append s (BS.pack ('_':show b ++ '_':show j)) + IW -> BS.pack "_" + +showIdent :: Ident -> String +showIdent i = BS.unpack $! ident2bs i + +identC :: BS.ByteString -> Ident +identV :: BS.ByteString -> Int -> Ident +identA :: BS.ByteString -> Int -> Ident +identAV:: BS.ByteString -> 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 +varStr :: Ident +varStr = identA (BS.pack "str") 0 + +-- | refreshing variables +varX :: Int -> Ident +varX = identV (BS.pack "x") + +isWildIdent :: Ident -> Bool +isWildIdent x = case x of + IW -> True + IC s | s == BS.pack "_" -> True + _ -> False + +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 (ident2bs x) m + 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/compiler/GF/Infra/Modules.hs b/src/compiler/GF/Infra/Modules.hs new file mode 100644 index 000000000..0710b8f40 --- /dev/null +++ b/src/compiler/GF/Infra/Modules.hs @@ -0,0 +1,349 @@ +---------------------------------------------------------------------- +-- | +-- 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(..), ModuleType(..), + MInclude (..), + extends, isInherited,inheritAll, + updateMGrammar, updateModule, replaceJudgements, addFlag, + addOpenQualif, flagsModule, allFlags, mapModules, + OpenSpec(..), + ModuleStatus(..), + openedModule, depPathModule, allDepsModule, partOfGrammar, + allExtends, allExtendSpecs, allExtendsPlus, allExtensions, + searchPathModule, addModule, + emptyMGrammar, emptyModInfo, + IdentM(..), + abstractOfConcrete, abstractModOfConcrete, + lookupModule, lookupModuleType, lookupInfo, + lookupPosition, ppPosition, + isModAbs, isModRes, isModCnc, + 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 +import Text.PrettyPrint + +-- 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 + +newtype MGrammar i a = MGrammar {modules :: [(i,ModInfo i a)]} + deriving Show + +data ModInfo i a = ModInfo { + mtype :: ModuleType i , + mstatus :: ModuleStatus , + flags :: Options, + extend :: [(i,MInclude i)], + mwith :: Maybe (i,MInclude i,[(i,i)]), + opens :: [OpenSpec i] , + mexdeps :: [i] , + jments :: BinTree i a , + positions :: BinTree i (String,(Int,Int)) -- file, first line, last line + } + deriving Show + +-- | encoding the type of the module +data ModuleType i = + MTAbstract + | MTResource + | MTConcrete i + -- ^ up to this, also used in GFC. Below, source only. + | MTInterface + | MTInstance i + deriving (Eq,Ord,Show) + +data MInclude i = MIAll | MIOnly [i] | MIExcept [i] + deriving (Eq,Ord,Show) + +extends :: ModInfo i 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 a -> MGrammar i a -> MGrammar i 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 => ModInfo i t -> i -> t -> ModInfo i t +updateModule (ModInfo mt ms fs me mw ops med js ps) i t = ModInfo mt ms fs me mw ops med (updateTree (i,t) js) ps + +replaceJudgements :: ModInfo i t -> BinTree i t -> ModInfo i t +replaceJudgements (ModInfo mt ms fs me mw ops med _ ps) js = ModInfo mt ms fs me mw ops med js ps + +addOpenQualif :: i -> i -> ModInfo i t -> ModInfo i t +addOpenQualif i j (ModInfo mt ms fs me mw ops med js ps) = ModInfo mt ms fs me mw (OQualif i j : ops) med js ps + +addFlag :: Options -> ModInfo i t -> ModInfo i t +addFlag f mo = mo {flags = flags mo `addOptions` f} + +flagsModule :: (i,ModInfo i a) -> Options +flagsModule (_,mi) = flags mi + +allFlags :: MGrammar i a -> Options +allFlags gr = concatOptions [flags m | (_,m) <- modules gr] + +mapModules :: (ModInfo i a -> ModInfo i a) -> MGrammar i a -> MGrammar i a +mapModules f (MGrammar ms) = MGrammar (map (onSnd f) ms) + +data OpenSpec i = + OSimple i + | OQualif i i + deriving (Eq,Ord,Show) + +data ModuleStatus = + MSComplete + | MSIncomplete + deriving (Eq,Ord,Show) + +openedModule :: OpenSpec i -> i +openedModule o = case o of + OSimple m -> m + OQualif _ m -> m + +-- | initial dependency list +depPathModule :: Ord i => ModInfo i a -> [OpenSpec i] +depPathModule m = fors m ++ exts m ++ opens m + where + fors m = + case mtype m of + MTConcrete i -> [OSimple i] + MTInstance i -> [OSimple i] + _ -> [] + exts m = map OSimple (extends m) + +-- | all dependencies +allDepsModule :: Ord i => MGrammar i a -> ModInfo i a -> [OpenSpec i] +allDepsModule gr m = iterFix add os0 where + os0 = depPathModule m + add os = [m | o <- os, Just 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 a -> (i,ModInfo i a) -> MGrammar i a +partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor] + where + mods = modules gr + modsFor = (i:) $ map openedModule $ allDepsModule gr m + +-- | all modules that a module extends, directly or indirectly, without restricts +allExtends :: (Show i,Ord i) => MGrammar i a -> i -> [i] +allExtends gr i = + case lookupModule gr i of + Ok 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 a -> i -> [(i,MInclude i)] +allExtendSpecs gr i = + case lookupModule gr i of + Ok 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 a -> i -> [i] +allExtendsPlus gr i = + case lookupModule gr i of + Ok 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 a -> i -> [i] +allExtensions gr i = + case lookupModule gr i of + Ok 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 = modules gr + +-- | initial search path: the nonqualified dependencies +searchPathModule :: Ord i => ModInfo i 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 a -> i -> ModInfo i a -> MGrammar i a +addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)]) + +emptyMGrammar :: MGrammar i a +emptyMGrammar = MGrammar [] + +emptyModInfo :: ModInfo i a +emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] emptyBinTree emptyBinTree + +-- | we store the module type with the identifier +data IdentM i = IdentM { + identM :: i , + typeM :: ModuleType i + } + deriving (Eq,Ord,Show) + +abstractOfConcrete :: (Show i, Eq i) => MGrammar i a -> i -> Err i +abstractOfConcrete gr c = do + n <- lookupModule gr c + case mtype n of + MTConcrete a -> return a + _ -> Bad $ "expected concrete" +++ show c + +abstractModOfConcrete :: (Show i, Eq i) => + MGrammar i a -> i -> Err (ModInfo i a) +abstractModOfConcrete gr c = do + a <- abstractOfConcrete gr c + lookupModule gr a + + +-- the canonical file name + +--- canonFileName s = prt s ++ ".gfc" + +lookupModule :: (Show i,Eq i) => MGrammar i a -> i -> Err (ModInfo i 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 a -> i -> Err (ModuleType i) +lookupModuleType gr m = do + mi <- lookupModule gr m + return $ mtype mi + +lookupInfo :: (Show i, Ord i) => ModInfo i a -> i -> Err a +lookupInfo mo i = lookupTree show i (jments mo) + +lookupPosition :: (Show i, Ord i) => ModInfo i a -> i -> Err (String,(Int,Int)) +lookupPosition mo i = lookupTree show i (positions mo) + +ppPosition :: (Show i, Ord i) => ModInfo i a -> i -> Doc +ppPosition mo i = case lookupPosition mo i of + Ok (f,(b,e)) | b == e -> text "in" <+> text f <> text ", line" <+> int b + | otherwise -> text "in" <+> text f <> text ", lines" <+> int b <> text "-" <> int e + _ -> empty + +isModAbs :: ModInfo i a -> Bool +isModAbs m = case mtype m of + MTAbstract -> True +---- MTUnion t -> isModAbs t + _ -> False + +isModRes :: ModInfo i a -> Bool +isModRes m = case mtype m of + MTResource -> True + MTInterface -> True --- + MTInstance _ -> True + _ -> False + +isModCnc :: ModInfo i a -> Bool +isModCnc m = case mtype m of + MTConcrete _ -> True + _ -> 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 + (MTInterface, MTConcrete _) -> 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 a -> Bool +isCompilableModule m = + case mtype m of + MTInterface -> False + _ -> mstatus m == MSComplete + +-- | interface and "incomplete M" are not complete +isCompleteModule :: (Eq i) => ModInfo i a -> Bool +isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface + + +-- | all abstract modules sorted from least to most dependent +allAbstracts :: (Ord i, Show i) => MGrammar i a -> [i] +allAbstracts gr = + case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of + Left is -> is + Right cycles -> error $ "Cyclic abstract modules: " ++ show cycles + +-- | the last abstract in dependency order (head of list) +greatestAbstract :: (Ord i, Show i) => MGrammar i a -> Maybe i +greatestAbstract gr = case allAbstracts gr of + [] -> Nothing + as -> return $ last as + +-- | all resource modules +allResources :: MGrammar i a -> [i] +allResources gr = [i | (i,m) <- modules gr, isModRes m || isModCnc m] + +-- | the greatest resource in dependency order +greatestResource :: MGrammar i a -> Maybe i +greatestResource gr = case allResources gr of + [] -> Nothing + a -> return $ head a ---- why not last as in Abstract? works though AR 24/5/2008 + +-- | all concretes for a given abstract +allConcretes :: Eq i => MGrammar i a -> i -> [i] +allConcretes gr a = + [i | (i, m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m] + +-- | all concrete modules for any abstract +allConcreteModules :: Eq i => MGrammar i a -> [i] +allConcreteModules gr = + [i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m] diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs new file mode 100644 index 000000000..dc15d1929 --- /dev/null +++ b/src/compiler/GF/Infra/Option.hs @@ -0,0 +1,609 @@ +module GF.Infra.Option + ( + -- * Option types + Options, + Flags(..), + Mode(..), Phase(..), Verbosity(..), Encoding(..), OutputFormat(..), + SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..), + Dump(..), Printer(..), Recomp(..), BuildParser(..), + -- * Option parsing + parseOptions, parseModuleOptions, fixRelativeLibPaths, + -- * Option pretty-printing + optionsGFO, + optionsPGF, + -- * Option manipulation + addOptions, concatOptions, noOptions, + modifyFlags, + helpMessage, + -- * Checking specific options + flag, cfgTransform, haskellOption, readOutputFormat, + isLexicalCat, encodings, + -- * Setting specific options + setOptimization, setCFGTransform, + -- * Convenience methods for checking options + verbAtLeast, dump + ) where + +import Control.Monad +import Data.Char (toLower) +import Data.List +import Data.Maybe +import GF.Infra.GetOpt +--import System.Console.GetOpt +import System.FilePath + +import GF.Data.ErrM + +import Data.Set (Set) +import qualified Data.Set as Set + + + + +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.", + ".gfo 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, .gfo or .gfe files.", + "For the other input formats, only one file can be given.", + "", + "Command-line options:"] + + +helpMessage :: String +helpMessage = usageInfo usageHeader optDescr + + +-- FIXME: do we really want multi-line errors? +errors :: [String] -> Err a +errors = fail . unlines + +-- Types + +data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeRun | ModeCompiler + deriving (Show,Eq,Ord) + +data Verbosity = Quiet | Normal | Verbose | Debug + deriving (Show,Eq,Ord,Enum,Bounded) + +data Phase = Preproc | Convert | Compile | Link + deriving (Show,Eq,Ord) + +data Encoding = UTF_8 | ISO_8859_1 | CP_1250 | CP_1251 | CP_1252 + deriving (Eq,Ord) + +data OutputFormat = FmtPGFPretty + | FmtPMCFGPretty + | FmtJavaScript + | FmtHaskell + | FmtProlog + | FmtProlog_Abs + | FmtBNF + | FmtEBNF + | FmtRegular + | FmtNoLR + | FmtSRGS_XML + | FmtSRGS_XML_NonRec + | FmtSRGS_ABNF + | FmtSRGS_ABNF_NonRec + | FmtJSGF + | FmtGSL + | FmtVoiceXML + | FmtSLF + | FmtRegExp + | FmtFA + deriving (Eq,Ord) + +data SISRFormat = + -- | SISR Working draft 1 April 2003 + -- + SISR_WD20030401 + | SISR_1_0 + deriving (Show,Eq,Ord) + +data Optimization = OptStem | OptCSE | OptExpand | OptParametrize + deriving (Show,Eq,Ord) + +data CFGTransform = CFGNoLR + | CFGRegular + | CFGTopDownFilter + | CFGBottomUpFilter + | CFGStartCatOnly + | CFGMergeIdentical + | CFGRemoveCycles + deriving (Show,Eq,Ord) + +data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical + deriving (Show,Eq,Ord) + +data Warning = WarnMissingLincat + deriving (Show,Eq,Ord) + +data Dump = DumpSource | DumpRebuild | DumpExtend | DumpRename | DumpTypeCheck | DumpRefresh | DumpOptimize | DumpCanon + deriving (Show,Eq,Ord) + +-- | Pretty-printing options +data Printer = PrinterStrip -- ^ Remove name qualifiers. + deriving (Show,Eq,Ord) + +data Recomp = AlwaysRecomp | RecompIfNewer | NeverRecomp + deriving (Show,Eq,Ord) + +data BuildParser = BuildParser | DontBuildParser | BuildParserOnDemand + deriving (Show,Eq,Ord) + +data Flags = Flags { + optMode :: Mode, + optStopAfterPhase :: Phase, + optVerbosity :: Verbosity, + optProf :: Bool, + optShowCPUTime :: Bool, + optEmitGFO :: Bool, + optOutputFormats :: [OutputFormat], + optSISR :: Maybe SISRFormat, + optHaskellOptions :: Set HaskellOption, + optLexicalCats :: Set String, + optGFODir :: Maybe FilePath, + optOutputFile :: Maybe FilePath, + optOutputDir :: Maybe FilePath, + optGFLibPath :: Maybe FilePath, + optRecomp :: Recomp, + optPrinter :: [Printer], + optProb :: Bool, + optRetainResource :: Bool, + optName :: Maybe String, + optAbsName :: Maybe String, + optCncName :: Maybe String, + optResName :: Maybe String, + optPreprocessors :: [String], + optEncoding :: Encoding, + optOptimizations :: Set Optimization, + optCFGTransforms :: Set CFGTransform, + optLibraryPath :: [FilePath], + optStartCat :: Maybe String, + optSpeechLanguage :: Maybe String, + optLexer :: Maybe String, + optUnlexer :: Maybe String, + optErasing :: Bool, + optBuildParser :: BuildParser, + optWarnings :: [Warning], + optDump :: [Dump] + } + deriving (Show) + +newtype Options = Options (Flags -> Flags) + +instance Show Options where + show (Options o) = show (o defaultFlags) + +-- Option parsing + +parseOptions :: [String] -- ^ list of string arguments + -> Err (Options, [FilePath]) +parseOptions args + | not (null errs) = errors errs + | otherwise = do opts <- liftM concatOptions $ sequence optss + return (opts, files) + where + (optss, files, errs) = getOpt RequireOrder optDescr args + +parseModuleOptions :: [String] -- ^ list of string arguments + -> Err Options +parseModuleOptions args = do + (opts,nonopts) <- parseOptions args + if null nonopts + then return opts + else errors $ map ("Non-option among module options: " ++) nonopts + +fixRelativeLibPaths curr_dir lib_dir (Options o) = Options (fixPathFlags . o) + where + fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [curr_dir dir, lib_dir dir]) path} + +-- Showing options + +-- | Pretty-print the options that are preserved in .gfo files. +optionsGFO :: Options -> [(String,String)] +optionsGFO opts = optionsPGF opts + ++ [("coding", show (flag optEncoding opts))] + +-- | Pretty-print the options that are preserved in .pgf files. +optionsPGF :: Options -> [(String,String)] +optionsPGF opts = + maybe [] (\x -> [("language",x)]) (flag optSpeechLanguage opts) + ++ maybe [] (\x -> [("startcat",x)]) (flag optStartCat opts) + ++ (if flag optErasing opts then [("erasing","on")] else []) + ++ (if flag optBuildParser opts == BuildParserOnDemand then [("parser","ondemand")] else []) + +-- Option manipulation + +flag :: (Flags -> a) -> Options -> a +flag f (Options o) = f (o defaultFlags) + +addOptions :: Options -> Options -> Options +addOptions (Options o1) (Options o2) = Options (o2 . o1) + +noOptions :: Options +noOptions = Options id + +concatOptions :: [Options] -> Options +concatOptions = foldr addOptions noOptions + +modifyFlags :: (Flags -> Flags) -> Options +modifyFlags = Options + +-- Default options + +defaultFlags :: Flags +defaultFlags = Flags { + optMode = ModeInteractive, + optStopAfterPhase = Compile, + optVerbosity = Normal, + optProf = False, + optShowCPUTime = False, + optEmitGFO = True, + optOutputFormats = [], + optSISR = Nothing, + optHaskellOptions = Set.empty, + optLexicalCats = Set.empty, + optGFODir = Nothing, + optOutputFile = Nothing, + optOutputDir = Nothing, + optGFLibPath = Nothing, + optRecomp = RecompIfNewer, + optPrinter = [], + optProb = False, + optRetainResource = False, + + optName = Nothing, + optAbsName = Nothing, + optCncName = Nothing, + optResName = Nothing, + optPreprocessors = [], + optEncoding = ISO_8859_1, + optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize], + optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter, + CFGTopDownFilter, CFGMergeIdentical], + optLibraryPath = [], + optStartCat = Nothing, + optSpeechLanguage = Nothing, + optLexer = Nothing, + optUnlexer = Nothing, + optErasing = True, + optBuildParser = BuildParser, + optWarnings = [], + optDump = [] + } + +-- Option descriptions + +optDescr :: [OptDescr (Err Options)] +optDescr = + [ + Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.", + Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.", + Option ['v'] ["verbose"] (OptArg verbosity "N") "Set verbosity (default 1). -v alone is the same as -v 2.", + Option ['q','s'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.", + Option [] ["batch"] (NoArg (mode ModeCompiler)) "Run in batch compiler mode.", + Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).", + Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).", + 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 (default) .", + Option [] ["make"] (NoArg (liftM2 addOptions (mode ModeCompiler) (phase Link))) "Build .pgf file and other output files and exit.", + Option [] ["prof"] (NoArg (prof True)) "Dump profiling information when compiling to PMCFG", + 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: pgf (default), gar, js, prolog, ...", + "Single concrete only: cf, bnf, lbnf, gsl, srgs_xml, srgs_abnf, ...", + "Abstract only: haskell, prolog_abs, ..."]), + Option [] ["sisr"] (ReqArg sisrFmt "FMT") + (unlines ["Include SISR tags in generated speech recognition grammars.", + "FMT can be one of: old, 1.0"]), + Option [] ["haskell"] (ReqArg hsOption "OPTION") + ("Turn on an optional feature when generating Haskell data types. OPTION = " + ++ concat (intersperse " | " (map fst haskellOptionNames))), + Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]") + "Treat CAT as a lexical category.", + 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 .gfo files) in DIR.", + Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR") + "Overides the value of GF_LIB_PATH.", + Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp)) + "Always recompile from source.", + Option [] ["gfo","recomp-if-newer"] (NoArg (recomp RecompIfNewer)) + "(default) Recompile from source if the source is newer than the .gfo file.", + Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp)) + "Never recompile from source, if there is already .gfo file.", + Option [] ["strip"] (NoArg (printer PrinterStrip)) + "Remove name qualifiers when pretty-printing.", + Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.", + Option [] ["prob"] (NoArg (prob True)) "Read probabilities from '--# prob' pragmas.", + Option ['n'] ["name"] (ReqArg name "NAME") + (unlines ["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 [] ["abs"] (ReqArg absName "NAME") + ("Use NAME as the name of the abstract syntax module generated from " + ++ "a grammar in GF 1 format."), + Option [] ["cnc"] (ReqArg cncName "NAME") + ("Use NAME as the name of the concrete syntax module generated from " + ++ "a grammar in GF 1 format."), + Option [] ["res"] (ReqArg resName "NAME") + ("Use NAME as the name of the resource module generated from " + ++ "a grammar in GF 1 format."), + 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 [] ["coding"] (ReqArg coding "ENCODING") + ("Character encoding of the source grammar, ENCODING = " + ++ concat (intersperse " | " (map fst encodings)) ++ "."), + Option [] ["erasing"] (onOff erasing False) "Generate erasing grammar (default off).", + Option [] ["parser"] (ReqArg buildParser "VALUE") "Build parser (default on). VALUE = on | off | ondemand", + Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.", + Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.", + Option [] ["lexer"] (ReqArg lexer "LEXER") "Use lexer LEXER.", + Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.", + Option [] ["optimize"] (ReqArg optimize "OPT") + "Select an optimization package. OPT = all | values | parametrize | none", + Option [] ["stem"] (onOff (toggleOptimize OptStem) True) "Perform stem-suffix analysis (default on).", + Option [] ["cse"] (onOff (toggleOptimize OptCSE) True) "Perform common sub-expression elimination (default on).", + Option [] ["cfg"] (ReqArg cfgTransform "TRANS") "Enable or disable specific CFG transformations. TRANS = merge, no-merge, bottomup, no-bottomup, ...", + dumpOption "source" DumpSource, + dumpOption "rebuild" DumpRebuild, + dumpOption "extend" DumpExtend, + dumpOption "rename" DumpRename, + dumpOption "tc" DumpTypeCheck, + dumpOption "refresh" DumpRefresh, + dumpOption "opt" DumpOptimize, + dumpOption "canon" DumpCanon + + ] + where phase x = set $ \o -> o { optStopAfterPhase = x } + mode x = set $ \o -> o { optMode = x } + verbosity mv = case mv of + Nothing -> set $ \o -> o { optVerbosity = Verbose } + Just v -> case readMaybe v >>= toEnumBounded of + Just i -> set $ \o -> o { optVerbosity = i } + Nothing -> fail $ "Bad verbosity: " ++ show v + prof x = set $ \o -> o { optProf = x } + cpu x = set $ \o -> o { optShowCPUTime = x } + emitGFO x = set $ \o -> o { optEmitGFO = x } + gfoDir x = set $ \o -> o { optGFODir = Just x } + outFmt x = readOutputFormat x >>= \f -> + set $ \o -> o { optOutputFormats = optOutputFormats o ++ [f] } + sisrFmt x = case x of + "old" -> set $ \o -> o { optSISR = Just SISR_WD20030401 } + "1.0" -> set $ \o -> o { optSISR = Just SISR_1_0 } + _ -> fail $ "Unknown SISR format: " ++ show x + hsOption x = case lookup x haskellOptionNames of + Just p -> set $ \o -> o { optHaskellOptions = Set.insert p (optHaskellOptions o) } + Nothing -> fail $ "Unknown Haskell option: " ++ x + ++ " Known: " ++ show (map fst haskellOptionNames) + lexicalCat x = set $ \o -> o { optLexicalCats = foldr Set.insert (optLexicalCats o) (splitBy (==',') x) } + outFile x = set $ \o -> o { optOutputFile = Just x } + outDir x = set $ \o -> o { optOutputDir = Just x } + gfLibPath x = set $ \o -> o { optGFLibPath = Just x } + recomp x = set $ \o -> o { optRecomp = x } + printer x = set $ \o -> o { optPrinter = x : optPrinter o } + prob x = set $ \o -> o { optProb = x } + + name x = set $ \o -> o { optName = Just x } + absName x = set $ \o -> o { optAbsName = Just x } + cncName x = set $ \o -> o { optCncName = Just x } + resName x = set $ \o -> o { optResName = Just x } + addLibDir x = set $ \o -> o { optLibraryPath = x:optLibraryPath o } + setLibPath x = set $ \o -> o { optLibraryPath = splitInModuleSearchPath x } + preproc x = set $ \o -> o { optPreprocessors = optPreprocessors o ++ [x] } + coding x = case lookup x encodings of + Just c -> set $ \o -> o { optEncoding = c } + Nothing -> fail $ "Unknown character encoding: " ++ x + erasing x = set $ \o -> o { optErasing = x } + buildParser x = do v <- case x of + "on" -> return BuildParser + "off" -> return DontBuildParser + "ondemand" -> return BuildParserOnDemand + set $ \o -> o { optBuildParser = v } + startcat x = set $ \o -> o { optStartCat = Just x } + language x = set $ \o -> o { optSpeechLanguage = Just x } + lexer x = set $ \o -> o { optLexer = Just x } + unlexer x = set $ \o -> o { optUnlexer = Just x } + + optimize x = case lookup x optimizationPackages of + Just p -> set $ \o -> o { optOptimizations = p } + Nothing -> fail $ "Unknown optimization package: " ++ x + + toggleOptimize x b = set $ setOptimization' x b + + cfgTransform x = let (x', b) = case x of + 'n':'o':'-':rest -> (rest, False) + _ -> (x, True) + in case lookup x' cfgTransformNames of + Just t -> set $ setCFGTransform' t b + Nothing -> fail $ "Unknown CFG transformation: " ++ x' + ++ " Known: " ++ show (map fst cfgTransformNames) + + dumpOption s d = Option [] ["dump-"++s] (NoArg (set $ \o -> o { optDump = d:optDump o})) ("Dump output of the " ++ s ++ " phase.") + + set = return . Options + +outputFormats :: [(String,OutputFormat)] +outputFormats = + [("pgf_pretty", FmtPGFPretty), + ("pmcfg_pretty", FmtPMCFGPretty), + ("js", FmtJavaScript), + ("haskell", FmtHaskell), + ("prolog", FmtProlog), + ("prolog_abs", FmtProlog_Abs), + ("bnf", FmtBNF), + ("ebnf", FmtEBNF), + ("regular", FmtRegular), + ("nolr", FmtNoLR), + ("srgs_xml", FmtSRGS_XML), + ("srgs_xml_nonrec", FmtSRGS_XML_NonRec), + ("srgs_abnf", FmtSRGS_ABNF), + ("srgs_abnf_nonrec", FmtSRGS_ABNF_NonRec), + ("jsgf", FmtJSGF), + ("gsl", FmtGSL), + ("vxml", FmtVoiceXML), + ("slf", FmtSLF), + ("regexp", FmtRegExp), + ("fa", FmtFA)] + +instance Show OutputFormat where + show = lookupShow outputFormats + +instance Read OutputFormat where + readsPrec = lookupReadsPrec outputFormats + +optimizationPackages :: [(String, Set Optimization)] +optimizationPackages = + [("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), + ("values", Set.fromList [OptStem,OptCSE,OptExpand]), + ("noexpand", Set.fromList [OptStem,OptCSE]), + + -- deprecated + ("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), + ("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), + ("none", Set.fromList [OptStem,OptCSE,OptExpand]) + ] + +cfgTransformNames :: [(String, CFGTransform)] +cfgTransformNames = + [("nolr", CFGNoLR), + ("regular", CFGRegular), + ("topdown", CFGTopDownFilter), + ("bottomup", CFGBottomUpFilter), + ("startcatonly", CFGStartCatOnly), + ("merge", CFGMergeIdentical), + ("removecycles", CFGRemoveCycles)] + +haskellOptionNames :: [(String, HaskellOption)] +haskellOptionNames = + [("noprefix", HaskellNoPrefix), + ("gadt", HaskellGADT), + ("lexical", HaskellLexical)] + +encodings :: [(String,Encoding)] +encodings = + [("utf8", UTF_8), + ("cp1250", CP_1250), + ("cp1251", CP_1251), + ("cp1252", CP_1252), + ("latin1", ISO_8859_1) + ] + +instance Show Encoding where + show = lookupShow encodings + +lookupShow :: Eq a => [(String,a)] -> a -> String +lookupShow xs z = fromMaybe "lookupShow" $ lookup z [(y,x) | (x,y) <- xs] + +lookupReadsPrec :: [(String,a)] -> Int -> ReadS a +lookupReadsPrec xs _ s = [(z,rest) | (x,rest) <- lex s, (y,z) <- xs, y == x] + +onOff :: Monad m => (Bool -> m a) -> Bool -> ArgDescr (m a) +onOff f def = OptArg g "[on,off]" + where g ma = maybe (return def) readOnOff ma >>= f + 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 + +-- FIXME: this is a copy of the function in GF.Devel.UseIO. +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 == ';' + +-- +-- * Convenience functions for checking options +-- + +verbAtLeast :: Options -> Verbosity -> Bool +verbAtLeast opts v = flag optVerbosity opts >= v + +dump :: Options -> Dump -> Bool +dump opts d = flag ((d `elem`) . optDump) opts + +cfgTransform :: Options -> CFGTransform -> Bool +cfgTransform opts t = Set.member t (flag optCFGTransforms opts) + +haskellOption :: Options -> HaskellOption -> Bool +haskellOption opts o = Set.member o (flag optHaskellOptions opts) + +isLexicalCat :: Options -> String -> Bool +isLexicalCat opts c = Set.member c (flag optLexicalCats opts) + +-- +-- * Convenience functions for setting options +-- + +setOptimization :: Optimization -> Bool -> Options +setOptimization o b = modifyFlags (setOptimization' o b) + +setOptimization' :: Optimization -> Bool -> Flags -> Flags +setOptimization' o b f = f { optOptimizations = toggle o b (optOptimizations f)} + +setCFGTransform :: CFGTransform -> Bool -> Options +setCFGTransform t b = modifyFlags (setCFGTransform' t b) + +setCFGTransform' :: CFGTransform -> Bool -> Flags -> Flags +setCFGTransform' t b f = f { optCFGTransforms = toggle t b (optCFGTransforms f) } + +toggle :: Ord a => a -> Bool -> Set a -> Set a +toggle o True = Set.insert o +toggle o False = Set.delete o + +-- +-- * General utilities +-- + +readMaybe :: Read a => String -> Maybe a +readMaybe s = case reads s of + [(x,"")] -> Just x + _ -> Nothing + +toEnumBounded :: (Bounded a, Enum a, Ord a) => Int -> Maybe a +toEnumBounded i = let mi = minBound + ma = maxBound `asTypeOf` mi + in if i >= fromEnum mi && i <= fromEnum ma + then Just (toEnum i `asTypeOf` mi) + else Nothing + +splitBy :: (a -> Bool) -> [a] -> [[a]] +splitBy _ [] = [] +splitBy p s = case break p s of + (l, _ : t@(_ : _)) -> l : splitBy p t + (l, _) -> [l] + +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 diff --git a/src/compiler/GF/Infra/UseIO.hs b/src/compiler/GF/Infra/UseIO.hs new file mode 100644 index 000000000..bb1a75b6e --- /dev/null +++ b/src/compiler/GF/Infra/UseIO.hs @@ -0,0 +1,186 @@ +{-# 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.Infra.Option +import Paths_gf(getDataDir) + +import System.Directory +import System.FilePath +import System.IO +import System.IO.Error +import System.Environment +import System.Exit +import System.CPUTime +import Text.Printf +import Control.Monad +import Control.Exception(evaluate) +import qualified Data.ByteString.Char8 as BS +import Data.List(nub) + +putShow' :: Show a => (c -> a) -> c -> IO () +putShow' f = putStrLn . show . length . show . f + +putIfVerb :: Options -> String -> IO () +putIfVerb opts msg = + when (verbAtLeast opts Verbose) $ putStrLn msg + +putIfVerbW :: Options -> String -> IO () +putIfVerbW opts msg = + when (verbAtLeast opts Verbose) $ putStr (' ' : msg) + +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 + +type FileName = String +type InitPath = String +type FullPath = String + +gfLibraryPath = "GF_LIB_PATH" +gfGrammarPathVar = "GF_GRAMMAR_PATH" + +getLibraryDirectory :: Options -> IO FilePath +getLibraryDirectory opts = + case flag optGFLibPath opts of + Just path -> return path + Nothing -> catch + (getEnv gfLibraryPath) + (\ex -> getDataDir >>= \path -> return (path "lib")) + +getGrammarPath :: FilePath -> IO [FilePath] +getGrammarPath lib_dir = do + catch (fmap splitSearchPath $ getEnv gfGrammarPathVar) (\_ -> return [lib_dir "prelude"]) -- e.g. GF_GRAMMAR_PATH + +-- | extends the search path with the +-- 'gfLibraryPath' and 'gfGrammarPathVar' +-- environment variables. Returns only existing paths. +extendPathEnv :: Options -> IO [FilePath] +extendPathEnv opts = do + opt_path <- return $ flag optLibraryPath opts -- e.g. paths given as options + lib_dir <- getLibraryDirectory opts -- e.g. GF_LIB_PATH + grm_path <- getGrammarPath lib_dir -- e.g. GF_GRAMMAR_PATH + let paths = opt_path ++ [lib_dir] ++ grm_path + ps <- liftM concat $ mapM allSubdirs paths + mapM canonicalizePath ps + 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 == ';' + +-- + +putStrFlush :: String -> IO () +putStrFlush s = putStr s >> hFlush stdout + +putStrLnFlush :: String -> IO () +putStrLnFlush s = putStrLn s >> hFlush stdout + +-- * 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) + +dieIOE :: IOE a -> IO a +dieIOE x = appIOE x >>= err die return + +die :: String -> IO a +die s = do hPutStrLn stderr s + exitFailure + +putStrLnE :: String -> IOE () +putStrLnE = ioeIO . putStrLnFlush + +putStrE :: String -> IOE () +putStrE = ioeIO . putStrFlush + +putPointE :: Verbosity -> Options -> String -> IOE a -> IOE a +putPointE v opts msg act = do + when (verbAtLeast opts v) $ ioeIO $ putStrFlush msg + + t1 <- ioeIO $ getCPUTime + a <- act >>= ioeIO . evaluate + t2 <- ioeIO $ getCPUTime + + if flag optShowCPUTime opts + then do let msec = (t2 - t1) `div` 1000000000 + putStrLnE (printf " %5d msec" msec) + else when (verbAtLeast opts v) $ putStrLnE "" + + return a diff --git a/src/compiler/GF/JavaScript/AbsJS.hs b/src/compiler/GF/JavaScript/AbsJS.hs new file mode 100644 index 000000000..2632ade48 --- /dev/null +++ b/src/compiler/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/compiler/GF/JavaScript/JS.cf b/src/compiler/GF/JavaScript/JS.cf new file mode 100644 index 000000000..fe31a2074 --- /dev/null +++ b/src/compiler/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/compiler/GF/JavaScript/LexJS.x b/src/compiler/GF/JavaScript/LexJS.x new file mode 100644 index 000000000..10ba66d69 --- /dev/null +++ b/src/compiler/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/compiler/GF/JavaScript/Makefile b/src/compiler/GF/JavaScript/Makefile new file mode 100644 index 000000000..10f867b06 --- /dev/null +++ b/src/compiler/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/compiler/GF/JavaScript/ParJS.y b/src/compiler/GF/JavaScript/ParJS.y new file mode 100644 index 000000000..bf0614757 --- /dev/null +++ b/src/compiler/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/compiler/GF/JavaScript/PrintJS.hs b/src/compiler/GF/JavaScript/PrintJS.hs new file mode 100644 index 000000000..4e04e3cbf --- /dev/null +++ b/src/compiler/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 Data.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/compiler/GF/Quiz.hs b/src/compiler/GF/Quiz.hs new file mode 100644 index 000000000..52d9dee6b --- /dev/null +++ b/src/compiler/GF/Quiz.hs @@ -0,0 +1,98 @@ +---------------------------------------------------------------------- +-- | +-- 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 -- 14\/6\/2008 +-------------------------------------------------------------------------------- + +module GF.Quiz ( + mkQuiz, + translationList, + morphologyList + ) where + +import PGF +import PGF.ShowLinearize +import GF.Data.Operations +import GF.Infra.UseIO +import GF.Infra.Option +import GF.Text.Coding + +import System.Random + +import Data.List (nub) + +-- translation and morphology quiz. AR 10/5/2000 -- 12/4/2002 + +-- generic quiz function + +mkQuiz :: Encoding -> String -> [(String,[String])] -> IO () +mkQuiz cod msg tts = do + let qas = [ (encodeUnicode cod q, mkAnswer cod as) | (q,as) <- tts] + teachDialogue qas msg + +translationList :: + PGF -> Language -> Language -> Type -> Int -> IO [(String,[String])] +translationList pgf ig og typ number = do + ts <- generateRandom pgf typ >>= return . take number + return $ map mkOne $ ts + where + mkOne t = (norml (linearize pgf ig t), map (norml . linearize pgf og) (homonyms t)) + homonyms = nub . parse pgf ig typ . linearize pgf ig + +morphologyList :: PGF -> Language -> Type -> Int -> IO [(String,[String])] +morphologyList pgf ig typ number = do + ts <- generateRandom pgf typ >>= return . take (max 1 number) + gen <- newStdGen + let ss = map (tabularLinearize pgf ig) ts + let size = length (head ss) + let forms = take number $ randomRs (0,size-1) gen + return [(head (snd (head pws)) +++ par, ws) | + (pws,i) <- zip ss forms, let (par,ws) = pws !! i] + +-- | compare answer to the list of right answers, increase score and give feedback +mkAnswer :: Encoding -> [String] -> String -> (Integer, String) +mkAnswer cod as s = + if (elem (norm s) as) + then (1,"Yes.") + else (0,"No, not" +++ s ++ ", but" ++++ enc (unlines as)) + where + norm = unwords . words . decodeUnicode cod + enc = encodeUnicode cod + +norml = unwords . words + + +-- * 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" diff --git a/src/compiler/GF/Speech/CFG.hs b/src/compiler/GF/Speech/CFG.hs new file mode 100644 index 000000000..9ec8416c5 --- /dev/null +++ b/src/compiler/GF/Speech/CFG.hs @@ -0,0 +1,372 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Speech.CFG +-- +-- Context-free grammar representation and manipulation. +---------------------------------------------------------------------- +module GF.Speech.CFG where + +import GF.Data.Utilities +import PGF.CId +import GF.Infra.Option +import GF.Data.Relation + +import Control.Monad +import Control.Monad.State (State, get, put, evalState) +import qualified Data.ByteString.Char8 as BS +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 + +-- +-- * Types +-- + +type Cat = String +type Token = String + +data Symbol c t = NonTerminal c | Terminal t + deriving (Eq, Ord, Show) + +type CFSymbol = Symbol Cat Token + +data CFRule = CFRule { + lhsCat :: Cat, + ruleRhs :: [CFSymbol], + ruleName :: CFTerm + } + deriving (Eq, Ord, Show) + +data CFTerm + = CFObj CId [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 CId -- ^ A metavariable + deriving (Eq, Ord, Show) + +data CFG = CFG { cfgStartCat :: Cat, + cfgExternalCats :: Set Cat, + cfgRules :: Map Cat (Set CFRule) } + deriving (Eq, Ord, Show) + +-- +-- * 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 :: CFG -> CFG +removeCycles = onRules f + where f rs = filter (not . isCycle) rs + where alias = transitiveClosure $ mkRel [(c,c') | CFRule c [NonTerminal c'] _ <- rs] + isCycle (CFRule c [NonTerminal c'] _) = isRelatedTo alias c' c + isCycle _ = False + +-- | Better bottom-up filter that also removes categories which contain no finite +-- strings. +bottomUpFilter :: CFG -> CFG +bottomUpFilter gr = fix grow (gr { cfgRules = Map.empty }) + where grow g = g `unionCFG` filterCFG (all (okSym g) . ruleRhs) gr + okSym g = symbol (`elem` allCats g) (const True) + +-- | Removes categories which are not reachable from any external category. +topDownFilter :: CFG -> CFG +topDownFilter cfg = filterCFGCats (`Set.member` keep) cfg + where + rhsCats = [ (lhsCat r, c') | r <- allRules cfg, c' <- filterCats (ruleRhs r) ] + uses = reflexiveClosure_ (allCats cfg) $ transitiveClosure $ mkRel rhsCats + keep = Set.unions $ map (allRelated uses) $ Set.toList $ cfgExternalCats cfg + +-- | Merges categories with identical right-hand-sides. +-- FIXME: handle probabilities +mergeIdentical :: CFG -> CFG +mergeIdentical g = onRules (map subst) g + where + -- maps categories to their replacement + m = Map.fromList [(y,concat (intersperse "+" xs)) + | (_,xs) <- buildMultiMap [(rulesKey rs,c) | (c,rs) <- Map.toList (cfgRules 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 + +-- | Keeps only the start category as an external category. +purgeExternalCats :: CFG -> CFG +purgeExternalCats cfg = cfg { cfgExternalCats = Set.singleton (cfgStartCat cfg) } + +-- +-- * Removing left recursion +-- + +-- The LC_LR algorithm from +-- http://research.microsoft.com/users/bobmoore/naacl2k-proc-rev.pdf +removeLeftRecursion :: CFG -> CFG +removeLeftRecursion gr + = gr { cfgRules = groupProds $ concat [scheme1, scheme2, scheme3, scheme4] } + where + scheme1 = [CFRule a [x,NonTerminal a_x] n' | + a <- retainedLeftRecursive, + x <- properLeftCornersOf a, + not (isLeftRecursive x), + let a_x = mkCat (NonTerminal 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++[NonTerminal a_b]) n' | + a <- retainedLeftRecursive, + b@(NonTerminal b') <- properLeftCornersOf a, + isLeftRecursive b, + CFRule _ (x:beta) n <- catRules gr b', + let a_x = mkCat (NonTerminal a) x, + let a_b = mkCat (NonTerminal 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 (NonTerminal a) x, + let n' = symbol (\_ -> CFAbs 1 (shiftTerm n)) + (\_ -> n) x] + scheme4 = catSetRules gr $ Set.fromList $ filter (not . isLeftRecursive . NonTerminal) 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 [(NonTerminal c,t) | CFRule c (t:_) _ <- allRules gr] + leftCorner = reflexiveClosure_ (map NonTerminal cats) $ transitiveClosure directLeftCorner + properLeftCorner = transitiveClosure directLeftCorner + properLeftCornersOf = Set.toList . allRelated properLeftCorner . NonTerminal + isProperLeftCornerOf = flip (isRelatedTo properLeftCorner) + + leftRecursive = reflexiveElements properLeftCorner + isLeftRecursive = (`Set.member` leftRecursive) + + retained = cfgStartCat gr `Set.insert` + Set.fromList [a | r <- allRules (filterCFGCats (not . isLeftRecursive . NonTerminal) gr), + NonTerminal a <- ruleRhs r] + isRetained = (`Set.member` retained) + + retainedLeftRecursive = filter (isLeftRecursive . NonTerminal) $ Set.toList retained + + mkCat :: CFSymbol -> CFSymbol -> Cat + mkCat x y = showSymbol x ++ "-" ++ showSymbol y + where showSymbol = symbol id show + +-- | 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. + -> CFG -> [Set Cat] +mutRecCats incAll g = equivalenceClasses $ refl $ symmetricSubrelation $ transitiveClosure r + where r = mkRel [(c,c') | CFRule c ss _ <- allRules g, NonTerminal c' <- ss] + refl = if incAll then reflexiveClosure_ (allCats g) else reflexiveSubrelation + +-- +-- * Approximate context-free grammars with regular grammars. +-- + +makeSimpleRegular :: CFG -> CFG +makeSimpleRegular = makeRegular . topDownFilter . bottomUpFilter . removeCycles + +-- Use the transformation algorithm from \"Regular Approximation of Context-free +-- Grammars through Approximation\", Mohri and Nederhof, 2000 +-- to create an over-generating regular grammar for a context-free +-- grammar +makeRegular :: CFG -> CFG +makeRegular g = g { cfgRules = groupProds $ concatMap trSet (mutRecCats True g) } + where trSet cs | allXLinear cs rs = rs + | otherwise = concatMap handleCat (Set.toList cs) + where 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 ++ [NonTerminal (newCat c)]) n -- no non-terminals left + (NonTerminal b:zs) -> newRule b' (xs ++ [NonTerminal 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 == [NonTerminal c] = [] + | otherwise = [CFRule c rhs n] + newCat c = c ++ "$" + +-- +-- * CFG Utilities +-- + +mkCFG :: Cat -> Set Cat -> [CFRule] -> CFG +mkCFG start ext rs = CFG { cfgStartCat = start, cfgExternalCats = ext, cfgRules = groupProds rs } + +groupProds :: [CFRule] -> Map Cat (Set CFRule) +groupProds = Map.fromListWith Set.union . map (\r -> (lhsCat r,Set.singleton r)) + +-- | Gets all rules in a CFG. +allRules :: CFG -> [CFRule] +allRules = concat . map Set.toList . Map.elems . cfgRules + +-- | Gets all rules in a CFG, grouped by their LHS categories. +allRulesGrouped :: CFG -> [(Cat,[CFRule])] +allRulesGrouped = Map.toList . Map.map Set.toList . cfgRules + +-- | Gets all categories which have rules. +allCats :: CFG -> [Cat] +allCats = Map.keys . cfgRules + +-- | Gets all categories which have rules or occur in a RHS. +allCats' :: CFG -> [Cat] +allCats' cfg = Set.toList (Map.keysSet (cfgRules cfg) `Set.union` + Set.fromList [c | rs <- Map.elems (cfgRules cfg), + r <- Set.toList rs, + NonTerminal c <- ruleRhs r]) + +-- | Gets all rules for the given category. +catRules :: CFG -> Cat -> [CFRule] +catRules gr c = Set.toList $ Map.findWithDefault Set.empty c (cfgRules gr) + +-- | Gets all rules for categories in the given set. +catSetRules :: CFG -> Set Cat -> [CFRule] +catSetRules gr cs = allRules $ filterCFGCats (`Set.member` cs) gr + +mapCFGCats :: (Cat -> Cat) -> CFG -> CFG +mapCFGCats f cfg = mkCFG (f (cfgStartCat cfg)) + (Set.map f (cfgExternalCats cfg)) + [CFRule (f lhs) (map (mapSymbol f id) rhs) t | CFRule lhs rhs t <- allRules cfg] + +onCFG :: (Map Cat (Set CFRule) -> Map Cat (Set CFRule)) -> CFG -> CFG +onCFG f cfg = cfg { cfgRules = f (cfgRules cfg) } + +onRules :: ([CFRule] -> [CFRule]) -> CFG -> CFG +onRules f cfg = cfg { cfgRules = groupProds $ f $ allRules cfg } + +-- | Clean up CFG after rules have been removed. +cleanCFG :: CFG -> CFG +cleanCFG = onCFG (Map.filter (not . Set.null)) + +-- | Combine two CFGs. +unionCFG :: CFG -> CFG -> CFG +unionCFG x y = onCFG (\rs -> Map.unionWith Set.union rs (cfgRules y)) x + +filterCFG :: (CFRule -> Bool) -> CFG -> CFG +filterCFG p = cleanCFG . onCFG (Map.map (Set.filter p)) + +filterCFGCats :: (Cat -> Bool) -> CFG -> CFG +filterCFGCats p = onCFG (Map.filterWithKey (\c _ -> p c)) + +countCats :: CFG -> Int +countCats = Map.size . cfgRules . cleanCFG + +countRules :: CFG -> Int +countRules = length . allRules + +prCFG :: CFG -> String +prCFG = prProductions . map prRule . allRules + where + prRule r = (lhsCat r, unwords (map prSym (ruleRhs r))) + prSym = symbol id (\t -> "\""++ t ++"\"") + +prProductions :: [(Cat,String)] -> String +prProductions prods = + unlines [rpad maxLHSWidth lhs ++ " ::= " ++ rhs | (lhs,rhs) <- prods] + where + maxLHSWidth = maximum $ 0:(map (length . fst) prods) + rpad n s = s ++ replicate (n - length s) ' ' + +prCFTerm :: CFTerm -> String +prCFTerm = pr 0 + where + pr p (CFObj f args) = paren p (showCId f ++ " (" ++ concat (intersperse "," (map (pr 0) args)) ++ ")") + pr p (CFAbs i t) = paren p ("\\x" ++ show i ++ ". " ++ pr 0 t) + pr p (CFApp t1 t2) = paren p (pr 1 t1 ++ "(" ++ pr 0 t2 ++ ")") + pr _ (CFRes i) = "$" ++ show i + pr _ (CFVar i) = "x" ++ show i + pr _ (CFMeta c) = "?" ++ showCId c + paren 0 x = x + paren 1 x = "(" ++ x ++ ")" + +-- +-- * CFRule Utilities +-- + +ruleFun :: CFRule -> CId +ruleFun (CFRule _ _ t) = f t + where f (CFObj n _) = n + f (CFApp _ x) = f x + f (CFAbs _ x) = f x + f _ = mkCId "" + +-- | Check if any of the categories used on the right-hand side +-- are in the given list of categories. +anyUsedBy :: [Cat] -> CFRule -> Bool +anyUsedBy cs (CFRule _ ss _) = any (`elem` cs) (filterCats ss) + +mkCFTerm :: String -> CFTerm +mkCFTerm n = CFObj (mkCId n) [] + +ruleIsNonRecursive :: Set Cat -> CFRule -> Bool +ruleIsNonRecursive cs = noCatsInSet cs . ruleRhs + +-- | Check if all the rules are right-linear, or all the rules are +-- left-linear, with respect to given categories. +allXLinear :: Set Cat -> [CFRule] -> Bool +allXLinear cs rs = all (isRightLinear cs) rs || all (isLeftLinear cs) rs + +-- | Checks if a context-free rule is right-linear. +isRightLinear :: Set Cat -- ^ The categories to consider + -> CFRule -- ^ The rule to check for right-linearity + -> Bool +isRightLinear cs = noCatsInSet cs . safeInit . ruleRhs + +-- | Checks if a context-free rule is left-linear. +isLeftLinear :: Set Cat -- ^ The categories to consider + -> CFRule -- ^ The rule to check for left-linearity + -> Bool +isLeftLinear cs = noCatsInSet cs . drop 1 . ruleRhs + + +-- +-- * Symbol utilities +-- + +symbol :: (c -> a) -> (t -> a) -> Symbol c t -> a +symbol fc ft (NonTerminal cat) = fc cat +symbol fc ft (Terminal tok) = ft tok + +mapSymbol :: (c -> c') -> (t -> t') -> Symbol c t -> Symbol c' t' +mapSymbol fc ft = symbol (NonTerminal . fc) (Terminal . ft) + +filterCats :: [Symbol c t] -> [c] +filterCats syms = [ cat | NonTerminal cat <- syms ] + +filterToks :: [Symbol c t] -> [t] +filterToks syms = [ tok | Terminal tok <- syms ] + +-- | 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 + +noCatsInSet :: Ord c => Set c -> [Symbol c t] -> Bool +noCatsInSet cs = not . any (`catElem` cs) diff --git a/src/compiler/GF/Speech/CFGToFA.hs b/src/compiler/GF/Speech/CFGToFA.hs new file mode 100644 index 000000000..3045ac842 --- /dev/null +++ b/src/compiler/GF/Speech/CFGToFA.hs @@ -0,0 +1,244 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Speech.CFGToFA +-- +-- Approximates CFGs with finite state networks. +---------------------------------------------------------------------- +module GF.Speech.CFGToFA (cfgToFA, makeSimpleRegular, + MFA(..), 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 PGF.CId +import PGF.Data +import GF.Data.Utilities +import GF.Speech.CFG +import GF.Speech.PGFToCFG +import GF.Infra.Ident (Ident) + +import GF.Data.Graph +import GF.Data.Relation +import GF.Speech.FiniteState +import GF.Speech.CFG + +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 +-- + +data MFA = MFA Cat [(Cat,DFA CFSymbol)] + + + +cfgToFA :: CFG -> DFA Token +cfgToFA = minimize . compileAutomaton . makeSimpleRegular + + +-- +-- * Compile strongly regular grammars to NFAs +-- + +-- Convert a strongly regular grammar to a finite automaton. +compileAutomaton :: CFG -> NFA Token +compileAutomaton g = make_fa (g,ns) s [NonTerminal (cfgStartCat g)] 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 :: (CFG,MutRecSets) -> State -> [CFSymbol] -> State + -> NFA Token -> NFA Token +make_fa c@(g,ns) q0 alpha q1 fa = + case alpha of + [] -> newTransition q0 q1 Nothing fa + [Terminal t] -> newTransition q0 q1 (Just t) fa + [NonTerminal a] -> + case Map.lookup a ns of + -- a is recursive + Just n@(MutRecSet { mrCats = ni, mrNonRecRules = nrs, mrRecRules = rs} ) -> + case mrRec n of + -- the set Ni is right-recursive or cyclic + RightR -> + let new = [(getState c, xs, q1) | CFRule c xs _ <- nrs] + ++ [(getState c, xs, getState d) | CFRule c ss _ <- rs, + let (xs,NonTerminal d) = (init ss,last ss)] + in make_fas new $ newTransition q0 (getState a) Nothing fa' + -- the set Ni is left-recursive + LeftR -> + let new = [(q0, xs, getState c) | CFRule c xs _ <- nrs] + ++ [(getState d, xs, getState c) | CFRule c (NonTerminal 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 :: CFG -> MFA +cfgToMFA = buildMFA . makeSimpleRegular + +-- | Build a DFA by building and expanding an MFA +cfgToFA' :: CFG -> DFA Token +cfgToFA' = mfaToDFA . cfgToMFA + +buildMFA :: CFG -> MFA +buildMFA g = sortSubLats $ removeUnusedSubLats mfa + where fas = compileAutomata g + mfa = MFA (cfgStartCat g) [(c, minimize fa) | (c,fa) <- fas] + +mfaStartDFA :: MFA -> DFA CFSymbol +mfaStartDFA (MFA start subs) = + fromMaybe (error $ "Bad start MFA: " ++ start) $ lookup start subs + +mfaToDFA :: MFA -> DFA Token +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 (Terminal s) -> newTransition f t (Just s) fa + Just (NonTerminal l) -> insertNFA fa (f,t) (expand $ getSub l) + +removeUnusedSubLats :: MFA -> MFA +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 -> Map Cat (Set Cat) +subLatUseMap (MFA _ subs) = Map.fromList [(c,usedSubLats n) | (c,n) <- subs] + +usedSubLats :: DFA CFSymbol -> Set Cat +usedSubLats fa = Set.fromList [s | (_,_,NonTerminal s) <- transitions fa] + +-- | Sort sub-networks topologically. +sortSubLats :: MFA -> MFA +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 :: CFG + -> [(Cat,NFA CFSymbol)] + -- ^ 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 [NonTerminal 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 + -> [CFSymbol] -- ^ Symbols to accept + -> State -- ^ State to end up in + -> NFA CFSymbol -- ^ FA to add to. + -> NFA CFSymbol +make_fa1 mr q0 alpha q1 fa = + case alpha of + [] -> newTransition q0 q1 Nothing fa + [t@(Terminal _)] -> newTransition q0 q1 (Just t) fa + [c@(NonTerminal a)] | not (a `Set.member` mrCats mr) -> newTransition q0 q1 (Just c) fa + [NonTerminal 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,NonTerminal 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 (NonTerminal 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 :: CFG -> [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)) + +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] diff --git a/src/compiler/GF/Speech/FiniteState.hs b/src/compiler/GF/Speech/FiniteState.hs new file mode 100644 index 000000000..136d773a2 --- /dev/null +++ b/src/compiler/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.Data.Graph +import qualified GF.Data.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/compiler/GF/Speech/GSL.hs b/src/compiler/GF/Speech/GSL.hs new file mode 100644 index 000000000..8f26ea64c --- /dev/null +++ b/src/compiler/GF/Speech/GSL.hs @@ -0,0 +1,95 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Speech.GSL +-- +-- This module prints a CFG as a Nuance GSL 2.0 grammar. +-- +----------------------------------------------------------------------------- + +module GF.Speech.GSL (gslPrinter) where + +import GF.Data.Utilities +import GF.Speech.CFG +import GF.Speech.SRG +import GF.Speech.RegExp +import GF.Infra.Option +import GF.Infra.Ident +import PGF.CId +import PGF.Data + +import Data.Char (toUpper,toLower) +import Data.List (partition) +import Text.PrettyPrint.HughesPJ + +width :: Int +width = 75 + +gslPrinter :: Options -> PGF -> CId -> String +gslPrinter opts pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG opts pgf cnc + where st = style { lineLength = width } + +prGSL :: SRG -> Doc +prGSL srg = header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules srg)) + where + header = text ";GSL2.0" $$ + comment ("Nuance speech recognition grammar for " ++ srgName srg) $$ + comment ("Generated by GF") + mainCat = text ".MAIN" <+> prCat (srgStartCat srg) + prRule (SRGRule cat rhs) = 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 = symbol (prCat . fst) (doubleQuotes . showToken) + +-- GSL requires an upper case letter in category names +prCat :: Cat -> Doc +prCat = text . firstToUpper + + +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 = text . map toLower + +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/compiler/GF/Speech/JSGF.hs b/src/compiler/GF/Speech/JSGF.hs new file mode 100644 index 000000000..2cfeea5f5 --- /dev/null +++ b/src/compiler/GF/Speech/JSGF.hs @@ -0,0 +1,113 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Speech.JSGF +-- +-- 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.JSGF (jsgfPrinter) where + +import GF.Data.Utilities +import GF.Infra.Option +import GF.Speech.CFG +import GF.Speech.RegExp +import GF.Speech.SISR +import GF.Speech.SRG +import PGF.CId +import PGF.Data + +import Data.Char +import Data.List +import Data.Maybe +import Text.PrettyPrint.HughesPJ +import Debug.Trace + +width :: Int +width = 75 + +jsgfPrinter :: Options + -> PGF + -> CId -> String +jsgfPrinter opts pgf cnc = renderStyle st $ prJSGF sisr $ makeNonLeftRecursiveSRG opts pgf cnc + where st = style { lineLength = width } + sisr = flag optSISR opts + +prJSGF :: Maybe SISRFormat -> SRG -> Doc +prJSGF sisr srg + = header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules srg)) + where + header = text "#JSGF" <+> text "V1.0" <+> text "UTF-8" <+> lang <> char ';' $$ + comment ("JSGF speech recognition grammar for " ++ srgName srg) $$ + comment "Generated by GF" $$ + text ("grammar " ++ srgName srg ++ ";") + lang = maybe empty text (srgLanguage srg) + mainCat = rule True "MAIN" [prCat (srgStartCat srg)] + prRule (SRGRule cat rhs) = rule (isExternalCat srg cat) cat (map prAlt rhs) + prAlt (SRGAlt mp n rhs) = sep [initTag, p (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 + +prCat :: Cat -> 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 + +prSymbol :: Maybe SISRFormat -> CFTerm -> SRGSymbol -> Doc +prSymbol sisr cn (NonTerminal n@(c,_)) = prCat c <+> tag sisr (catSISR cn n) +prSymbol _ cn (Terminal t) | all isPunct t = empty -- removes punctuation + | otherwise = text 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 -> Cat -> [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/compiler/GF/Speech/PGFToCFG.hs b/src/compiler/GF/Speech/PGFToCFG.hs new file mode 100644 index 000000000..d22a4ea8d --- /dev/null +++ b/src/compiler/GF/Speech/PGFToCFG.hs @@ -0,0 +1,116 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Speech.PGFToCFG +-- +-- Approximates PGF grammars with context-free grammars. +---------------------------------------------------------------------- +module GF.Speech.PGFToCFG (bnfPrinter, pgfToCFG) where + +import PGF.CId +import PGF.Data as PGF +import PGF.Macros +import GF.Infra.Ident +import GF.Speech.CFG + +import Data.Array.IArray as Array +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set + +bnfPrinter :: PGF -> CId -> String +bnfPrinter = toBNF id + +toBNF :: (CFG -> CFG) -> PGF -> CId -> String +toBNF f pgf cnc = prCFG $ f $ pgfToCFG pgf cnc + + +pgfToCFG :: PGF + -> CId -- ^ Concrete syntax name + -> CFG +pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ concatMap fruleToCFRule rules) + where + pinfo = fromMaybe (error "pgfToCFG: No parser.") (lookParser pgf lang) + + rules :: [(FCat,Production)] + rules = [(fcat,prod) | (fcat,set) <- IntMap.toList (PGF.productions pinfo) + , prod <- Set.toList set] + + fcatCats :: Map FCat Cat + fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i) + | (c,fcs) <- Map.toList (startCats pinfo), + (fc,i) <- zip fcs [1..]] + + fcatCat :: FCat -> Cat + fcatCat c = Map.findWithDefault ("Unknown_" ++ show c) c fcatCats + + fcatToCat :: FCat -> FIndex -> Cat + fcatToCat c l = fcatCat c ++ row + where row = if catLinArity c == 1 then "" else "_" ++ show l + + -- gets the number of fields in the lincat for the given category + catLinArity :: FCat -> Int + catLinArity c = maximum (1:[rangeSize (bounds rhs) | (FFun _ _ rhs, _) <- topdownRules c]) + + topdownRules cat = f cat [] + where + f cat rules = maybe rules (Set.fold g rules) (IntMap.lookup cat (productions pinfo)) + + g (FApply funid args) rules = (functions pinfo ! funid,args) : rules + g (FCoerce cat) rules = f cat rules + + + extCats :: Set Cat + extCats = Set.fromList $ map lhsCat startRules + + startRules :: [CFRule] + startRules = [CFRule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0) + | (c,fcs) <- Map.toList (startCats pinfo), + fc <- fcs, not (isLiteralFCat fc), + r <- [0..catLinArity fc-1]] + + fruleToCFRule :: (FCat,Production) -> [CFRule] + fruleToCFRule (c,FApply funid args) = + [CFRule (fcatToCat c l) (mkRhs row) (profilesToTerm (map (fixProfile row) ps)) + | (l,seqid) <- Array.assocs rhs + , let row = sequences pinfo ! seqid + , not (containsLiterals row)] + where + FFun f ps rhs = functions pinfo ! funid + + mkRhs :: Array FPointPos FSymbol -> [CFSymbol] + mkRhs = concatMap fsymbolToSymbol . Array.elems + + containsLiterals :: Array FPointPos FSymbol -> Bool + containsLiterals row = any isLiteralFCat [args!!n | FSymCat n _ <- Array.elems row] || + not (null [n | FSymLit n _ <- Array.elems row]) -- only this is needed for PMCFG. + -- The first line is for backward compat. + + fsymbolToSymbol :: FSymbol -> [CFSymbol] + fsymbolToSymbol (FSymCat n l) = [NonTerminal (fcatToCat (args!!n) l)] + fsymbolToSymbol (FSymLit n l) = [NonTerminal (fcatToCat (args!!n) l)] + fsymbolToSymbol (FSymKS ts) = map Terminal ts + + fixProfile :: Array FPointPos FSymbol -> Profile -> Profile + fixProfile row = concatMap positions + where + nts = zip [0..] [j | nt <- Array.elems row, j <- getPos nt] + positions i = [k | (k,j) <- nts, j == i] + + getPos (FSymCat j _) = [j] + getPos (FSymLit j _) = [j] + getPos _ = [] + + profilesToTerm :: [Profile] -> CFTerm + profilesToTerm ps = CFObj f (zipWith profileToTerm argTypes ps) + where (argTypes,_) = catSkeleton $ lookType pgf f + + profileToTerm :: CId -> Profile -> CFTerm + profileToTerm t [] = CFMeta t + profileToTerm _ xs = CFRes (last xs) -- FIXME: unify + fruleToCFRule (c,FCoerce c') = + [CFRule (fcatToCat c l) [NonTerminal (fcatToCat c' l)] (CFRes 0) + | l <- [0..catLinArity c-1]] diff --git a/src/compiler/GF/Speech/PrRegExp.hs b/src/compiler/GF/Speech/PrRegExp.hs new file mode 100644 index 000000000..0fc35d541 --- /dev/null +++ b/src/compiler/GF/Speech/PrRegExp.hs @@ -0,0 +1,27 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Speech.PrRegExp +-- +-- This module prints a grammar as a regular expression. +----------------------------------------------------------------------------- + +module GF.Speech.PrRegExp (regexpPrinter,multiRegexpPrinter) where + +import GF.Speech.CFG +import GF.Speech.CFGToFA +import GF.Speech.PGFToCFG +import GF.Speech.RegExp +import PGF + +regexpPrinter :: PGF -> CId -> String +regexpPrinter pgf cnc = (++"\n") $ prRE id $ dfa2re $ cfgToFA $ pgfToCFG pgf cnc + +multiRegexpPrinter :: PGF -> CId -> String +multiRegexpPrinter pgf cnc = prREs $ mfa2res $ cfgToMFA $ pgfToCFG pgf cnc + +prREs :: [(String,RE CFSymbol)] -> String +prREs res = unlines [l ++ " = " ++ prRE id (mapRE showLabel re) | (l,re) <- res] + where showLabel = symbol (\l -> "<" ++ l ++ ">") id + +mfa2res :: MFA -> [(String,RE CFSymbol)] +mfa2res (MFA _ dfas) = [(l, minimizeRE (dfa2re dfa)) | (l,dfa) <- dfas] diff --git a/src/compiler/GF/Speech/RegExp.hs b/src/compiler/GF/Speech/RegExp.hs new file mode 100644 index 000000000..2592b3d57 --- /dev/null +++ b/src/compiler/GF/Speech/RegExp.hs @@ -0,0 +1,144 @@ +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 :: (a -> String) -> RE a -> String +prRE = prRE' 0 + +prRE' :: Int -> (a -> String) -> RE a -> String +prRE' _ _ (REUnion []) = "" +prRE' n f (REUnion xs) = p n 1 (concat (intersperse " | " (map (prRE' 1 f) xs))) +prRE' n f (REConcat xs) = p n 2 (unwords (map (prRE' 2 f) xs)) +prRE' n f (RERepeat x) = p n 3 (prRE' 3 f x) ++ "*" +prRE' _ f (RESymbol s) = f s + +p n m s | n >= m = "(" ++ s ++ ")" + | True = s diff --git a/src/compiler/GF/Speech/SISR.hs b/src/compiler/GF/Speech/SISR.hs new file mode 100644 index 000000000..f966d96b9 --- /dev/null +++ b/src/compiler/GF/Speech/SISR.hs @@ -0,0 +1,77 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Speech.SISR +-- +-- 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.Data.Utilities +import GF.Infra.Ident +import GF.Infra.Option (SISRFormat(..)) +import GF.Speech.CFG +import GF.Speech.SRG (SRGNT) +import PGF.CId + +import qualified GF.JavaScript.AbsJS as JS +import qualified GF.JavaScript.PrintJS as JS + +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 (showCId 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 (showCId typ))] + +fmtOut SISR_WD20030401 = JS.EVar (JS.Ident "$") +fmtOut SISR_1_0 = JS.EVar (JS.Ident "out") + +fmtRef SISR_WD20030401 c = JS.EVar (JS.Ident ("$" ++ c)) +fmtRef SISR_1_0 c = field (JS.EVar (JS.Ident "rules")) 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/compiler/GF/Speech/SLF.hs b/src/compiler/GF/Speech/SLF.hs new file mode 100644 index 000000000..84633149b --- /dev/null +++ b/src/compiler/GF/Speech/SLF.hs @@ -0,0 +1,178 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Speech.SLF +-- +-- 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. +-- +----------------------------------------------------------------------------- + +module GF.Speech.SLF (slfPrinter,slfGraphvizPrinter, + slfSubPrinter,slfSubGraphvizPrinter) where + +import GF.Data.Utilities +import GF.Speech.CFG +import GF.Speech.FiniteState +import GF.Speech.CFG +import GF.Speech.CFGToFA +import GF.Speech.PGFToCFG +import qualified GF.Data.Graphviz as Dot +import PGF +import PGF.CId + +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 CFSymbol) () + +mkFAs :: PGF -> CId -> (SLF_FA, [(String,SLF_FA)]) +mkFAs pgf cnc = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs]) + where MFA start subs = {- renameSubs $ -} cfgToMFA $ pgfToCFG pgf cnc + main = let (fa,s,f) = newFA_ in newTransition s f (NonTerminal 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 -> MFA +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 :: PGF -> CId -> String +slfGraphvizPrinter pgf cnc + = prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA' $ pgfToCFG pgf cnc + where + gvFA = mapStates (fromMaybe "") . mapTransitions (const "") + +-- +-- * SLF graphviz printing (with sub-networks) +-- + +slfSubGraphvizPrinter :: PGF -> CId -> String +slfSubGraphvizPrinter pgf cnc = Dot.prGraphviz g + where (main, subs) = mkFAs pgf cnc + 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 :: PGF -> CId -> String +slfPrinter pgf cnc + = prSLF $ automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA' $ pgfToCFG pgf cnc + +-- +-- * SLF printing (with sub-networks) +-- + +-- | Make a network with subnetworks in SLF +slfSubPrinter :: PGF -> CId -> String +slfSubPrinter pgf cnc = prSLFs slfs + where + (main,subs) = mkFAs pgf cnc + 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 CFSymbol -> SLFNode +mfaNodeToSLFNode i l = case l of + Nothing -> mkSLFNode i Nothing + Just (Terminal x) -> mkSLFNode i (Just x) + Just (NonTerminal 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/compiler/GF/Speech/SRG.hs b/src/compiler/GF/Speech/SRG.hs new file mode 100644 index 000000000..2270ec7a1 --- /dev/null +++ b/src/compiler/GF/Speech/SRG.hs @@ -0,0 +1,205 @@ +---------------------------------------------------------------------- +-- | +-- Module : SRG +-- +-- 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, SRGSymbol + , SRGNT, CFTerm + , ebnfPrinter + , makeNonLeftRecursiveSRG + , makeNonRecursiveSRG + , getSpeechLanguage + , isExternalCat + , lookupFM_ + ) where + +import GF.Data.Operations +import GF.Data.Utilities +import GF.Infra.Ident +import GF.Infra.Option +import GF.Speech.CFG +import GF.Speech.PGFToCFG +import GF.Data.Relation +import GF.Speech.FiniteState +import GF.Speech.RegExp +import GF.Speech.CFGToFA +import GF.Infra.Option +import PGF.CId +import PGF.Data +import PGF.Macros + +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 { srgName :: String -- ^ grammar name + , srgStartCat :: Cat -- ^ start category name + , srgExternalCats :: Set Cat + , srgLanguage :: Maybe String -- ^ The language for which the grammar + -- is intended, e.g. en-UK + , srgRules :: [SRGRule] + } + deriving (Eq,Show) + +data SRGRule = SRGRule Cat [SRGAlt] + 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 SRGSymbol + +type SRGSymbol = Symbol SRGNT Token + +-- | An SRG non-terminal. Category name and its number in the profile. +type SRGNT = (Cat, Int) + +ebnfPrinter :: Options -> PGF -> CId -> String +ebnfPrinter opts pgf cnc = prSRG opts $ makeSRG opts pgf cnc + +-- | Create a compact filtered non-left-recursive SRG. +makeNonLeftRecursiveSRG :: Options -> PGF -> CId -> SRG +makeNonLeftRecursiveSRG opts = makeSRG opts' + where + opts' = setDefaultCFGTransform opts CFGNoLR True + +makeSRG :: Options -> PGF -> CId -> SRG +makeSRG opts = mkSRG cfgToSRG preprocess + where + cfgToSRG cfg = [cfRulesToSRGRule rs | (_,rs) <- allRulesGrouped cfg] + preprocess = maybeTransform opts CFGMergeIdentical mergeIdentical + . maybeTransform opts CFGNoLR removeLeftRecursion + . maybeTransform opts CFGRegular makeRegular + . maybeTransform opts CFGTopDownFilter topDownFilter + . maybeTransform opts CFGBottomUpFilter bottomUpFilter + . maybeTransform opts CFGRemoveCycles removeCycles + . maybeTransform opts CFGStartCatOnly purgeExternalCats + +setDefaultCFGTransform :: Options -> CFGTransform -> Bool -> Options +setDefaultCFGTransform opts t b = setCFGTransform t b `addOptions` opts + +maybeTransform :: Options -> CFGTransform -> (CFG -> CFG) -> (CFG -> CFG) +maybeTransform opts t f = if cfgTransform opts t then f else id + +traceStats s g = trace ("---- " ++ s ++ ": " ++ stats g {- ++ "\n" ++ prCFRules g ++ "----" -}) g + +stats g = "Categories: " ++ show (countCats g) + ++ ", External categories: " ++ show (Set.size (cfgExternalCats g)) + ++ ", Rules: " ++ show (countRules g) + +makeNonRecursiveSRG :: Options + -> PGF + -> CId -- ^ Concrete syntax name. + -> SRG +makeNonRecursiveSRG opts = mkSRG cfgToSRG id + where + cfgToSRG cfg = [SRGRule l [SRGAlt Nothing dummyCFTerm (dfaToSRGItem dfa)] | (l,dfa) <- dfas] + where + MFA _ dfas = cfgToMFA cfg + dfaToSRGItem = mapRE dummySRGNT . minimizeRE . dfa2re + dummyCFTerm = CFMeta (mkCId "dummy") + dummySRGNT = mapSymbol (\c -> (c,0)) id + +mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG +mkSRG mkRules preprocess pgf cnc = + SRG { srgName = showCId cnc, + srgStartCat = cfgStartCat cfg, + srgExternalCats = cfgExternalCats cfg, + srgLanguage = getSpeechLanguage pgf cnc, + srgRules = mkRules cfg } + where cfg = renameCats (showCId cnc) $ preprocess $ pgfToCFG pgf cnc + +-- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string), +-- to C_N where N is an integer. +renameCats :: String -> CFG -> CFG +renameCats prefix cfg = mapCFGCats renameCat cfg + where renameCat c | isExternal c = c ++ "_cat" + | otherwise = Map.findWithDefault (badCat c) c names + isExternal c = c `Set.member` cfgExternalCats cfg + catsByPrefix = buildMultiMap [(takeWhile (/='_') cat, cat) | cat <- allCats' cfg, not (isExternal cat)] + names = Map.fromList [(c,pref++"_"++show i) | (pref,cs) <- catsByPrefix, (c,i) <- zip cs [1..]] + badCat c = error ("GF.Speech.SRG.renameCats: " ++ c ++ "\n" ++ prCFG cfg) + +getSpeechLanguage :: PGF -> CId -> Maybe String +getSpeechLanguage pgf cnc = fmap (replace '_' '-') $ lookConcrFlag pgf cnc (mkCId "language") + +cfRulesToSRGRule :: [CFRule] -> SRGRule +cfRulesToSRGRule rs@(r:_) = SRGRule (lhsCat r) rhs + where + alts = [((n,Nothing),mkSRGSymbols 0 ss) | CFRule c ss n <- rs] + rhs = [SRGAlt p n (srgItem sss) | ((n,p),sss) <- buildMultiMap alts ] + + mkSRGSymbols _ [] = [] + mkSRGSymbols i (NonTerminal c:ss) = NonTerminal (c,i) : mkSRGSymbols (i+1) ss + mkSRGSymbols i (Terminal t:ss) = Terminal t : mkSRGSymbols i ss + +srgLHSCat :: SRGRule -> Cat +srgLHSCat (SRGRule c _) = c + +isExternalCat :: SRG -> Cat -> Bool +isExternalCat srg c = c `Set.member` srgExternalCats srg + +-- +-- * Size-optimized EBNF SRGs +-- + +srgItem :: [[SRGSymbol]] -> 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 :: [[SRGSymbol]] -> SRGItem +mergeItems = minimizeRE . ungroupTokens . minimizeRE . unionRE . map seqRE . map groupTokens + +groupTokens :: [SRGSymbol] -> [Symbol SRGNT [Token]] +groupTokens [] = [] +groupTokens (Terminal t:ss) = case groupTokens ss of + Terminal ts:ss' -> Terminal (t:ts):ss' + ss' -> Terminal [t]:ss' +groupTokens (NonTerminal c:ss) = NonTerminal c : groupTokens ss + +ungroupTokens :: RE (Symbol SRGNT [Token]) -> RE SRGSymbol +ungroupTokens = joinRE . mapRE (symbol (RESymbol . NonTerminal) (REConcat . map (RESymbol . Terminal))) + +-- +-- * Utilities for building and printing SRGs +-- + +prSRG :: Options -> SRG -> String +prSRG opts srg = prProductions $ map prRule $ ext ++ int + where + sisr = flag optSISR opts + (ext,int) = partition (isExternalCat srg . srgLHSCat) (srgRules srg) + prRule (SRGRule c alts) = (c,unwords (intersperse "|" (concatMap prAlt alts))) + prAlt (SRGAlt _ t rhs) = + -- FIXME: hack: we high-jack the --sisr flag to add + -- a simple lambda calculus format for semantic interpretation + -- Maybe the --sisr flag should be renamed. + case sisr of + Just _ -> + -- copy tags to each part of a top-level union, + -- to get simpler output + case rhs of + REUnion xs -> map prOneAlt xs + _ -> [prOneAlt rhs] + where prOneAlt a = prRE prSym a ++ " { " ++ prCFTerm t ++ " }" + Nothing -> [prRE prSym rhs] + prSym = symbol fst (\t -> "\""++ t ++"\"") + +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) diff --git a/src/compiler/GF/Speech/SRGS_ABNF.hs b/src/compiler/GF/Speech/SRGS_ABNF.hs new file mode 100644 index 000000000..2df1316a8 --- /dev/null +++ b/src/compiler/GF/Speech/SRGS_ABNF.hs @@ -0,0 +1,127 @@ +---------------------------------------------------------------------- +-- | +-- 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.SRGS_ABNF (srgsAbnfPrinter, srgsAbnfNonRecursivePrinter) where + +import GF.Data.Utilities +import GF.Infra.Option +import GF.Speech.CFG +import GF.Speech.SISR as SISR +import GF.Speech.SRG +import GF.Speech.RegExp +import PGF (PGF, CId) + +import Data.Char +import Data.List +import Data.Maybe +import Text.PrettyPrint.HughesPJ +import Debug.Trace + +width :: Int +width = 75 + +srgsAbnfPrinter :: Options + -> PGF -> CId -> String +srgsAbnfPrinter opts pgf cnc = showDoc $ prABNF sisr $ makeNonLeftRecursiveSRG opts pgf cnc + where sisr = flag optSISR opts + +srgsAbnfNonRecursivePrinter :: Options -> PGF -> CId -> String +srgsAbnfNonRecursivePrinter opts pgf cnc = showDoc $ prABNF Nothing $ makeNonRecursiveSRG opts pgf cnc + +showDoc = renderStyle (style { lineLength = width }) + +prABNF :: Maybe SISRFormat -> SRG -> Doc +prABNF sisr srg + = header $++$ foldr ($++$) empty (map prRule (srgRules srg)) + where + header = text "#ABNF 1.0 UTF-8;" $$ + meta "description" ("Speech recognition grammar for " ++ srgName srg) $$ + meta "generator" "Grammatical Framework" $$ + language $$ tagFormat $$ mainCat + language = maybe empty (\l -> text "language" <+> text l <> char ';') (srgLanguage srg) + tagFormat | isJust sisr = text "tag-format" <+> text "" <> char ';' + | otherwise = empty + mainCat = text "root" <+> prCat (srgStartCat srg) <> char ';' + prRule (SRGRule cat alts) = rule (isExternalCat srg cat) cat (map prAlt alts) + 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 + +prCat :: Cat -> 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 -> SRGSymbol -> Doc +prSymbol sisr cn (NonTerminal n@(c,_)) = prCat c <+> tag sisr (catSISR cn n) +prSymbol _ cn (Terminal t) + | all isPunct t = empty -- removes punctuation + | otherwise = text 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 -> Cat -> [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/compiler/GF/Speech/SRGS_XML.hs b/src/compiler/GF/Speech/SRGS_XML.hs new file mode 100644 index 000000000..1f94de66d --- /dev/null +++ b/src/compiler/GF/Speech/SRGS_XML.hs @@ -0,0 +1,105 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Speech.SRGS_XML +-- +-- Prints an SRGS XML speech recognition grammars. +---------------------------------------------------------------------- +module GF.Speech.SRGS_XML (srgsXmlPrinter, srgsXmlNonRecursivePrinter) where + +import GF.Data.Utilities +import GF.Data.XML +import GF.Infra.Option +import GF.Speech.CFG +import GF.Speech.RegExp +import GF.Speech.SISR as SISR +import GF.Speech.SRG +import PGF (PGF, CId) + +import Control.Monad +import Data.Char (toUpper,toLower) +import Data.List +import Data.Maybe +import qualified Data.Map as Map + +srgsXmlPrinter :: Options + -> PGF -> CId -> String +srgsXmlPrinter opts pgf cnc = prSrgsXml sisr $ makeNonLeftRecursiveSRG opts pgf cnc + where sisr = flag optSISR opts + +srgsXmlNonRecursivePrinter :: Options -> PGF -> CId -> String +srgsXmlNonRecursivePrinter opts pgf cnc = prSrgsXml Nothing $ makeNonRecursiveSRG opts pgf cnc + + +prSrgsXml :: Maybe SISRFormat -> SRG -> String +prSrgsXml sisr srg = showXMLDoc (optimizeSRGS xmlGr) + where + xmlGr = grammar sisr (srgStartCat srg) (srgLanguage srg) $ + [meta "description" + ("SRGS XML speech recognition grammar for " ++ srgName srg ++ "."), + meta "generator" "Grammatical Framework"] + ++ map ruleToXML (srgRules srg) + ruleToXML (SRGRule cat alts) = Tag "rule" ([("id",cat)]++pub) (prRhs alts) + where pub = if isExternalCat srg cat then [("scope","public")] else [] + prRhs rhss = [oneOf (map (mkProd sisr) rhss)] + +mkProd :: Maybe SISRFormat -> SRGAlt -> XML +mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf) + where x = mkItem sisr n rhs + 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 + +symItem :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> XML +symItem sisr cn (NonTerminal n@(c,_)) = + Tag "item" [] $ [ETag "ruleref" [("uri","#" ++ c)]] ++ tag sisr (catSISR cn n) +symItem _ _ (Terminal 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)]] + +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/compiler/GF/Speech/VoiceXML.hs b/src/compiler/GF/Speech/VoiceXML.hs new file mode 100644 index 000000000..134964062 --- /dev/null +++ b/src/compiler/GF/Speech/VoiceXML.hs @@ -0,0 +1,243 @@ +---------------------------------------------------------------------- +-- | +-- Module : GF.Speech.VoiceXML +-- +-- Creates VoiceXML dialogue systems from PGF grammars. +----------------------------------------------------------------------------- +module GF.Speech.VoiceXML (grammar2vxml) where + +import GF.Data.Operations +import GF.Data.Str (sstrV) +import GF.Data.Utilities +import GF.Data.XML +import GF.Infra.Ident +import GF.Infra.Modules +import GF.Speech.SRG (getSpeechLanguage) +import PGF.CId +import PGF.Data +import PGF.Macros +import PGF.Linearize (realize) + +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 :: PGF -> CId -> String +grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name language start skel qs) "" + where skel = pgfSkeleton pgf + name = showCId cnc + qs = catQuestions pgf cnc (map fst skel) + language = getSpeechLanguage pgf cnc + start = lookStartCat pgf + +-- +-- * VSkeleton: a simple description of the abstract syntax. +-- + +type Skeleton = [(CId, [(CId, [CId])])] + +pgfSkeleton :: PGF -> Skeleton +pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType pgf f))) | f <- fs]) + | (c,fs) <- Map.toList (catfuns (abstract pgf)), + not (isLiteralCat c)] + +-- +-- * Questions to ask +-- + +type CatQuestions = [(CId,String)] + +catQuestions :: PGF -> CId -> [CId] -> CatQuestions +catQuestions pgf cnc cats = [(c,catQuestion pgf cnc c) | c <- cats] + +catQuestion :: PGF -> CId -> CId -> String +catQuestion pgf cnc cat = realize (lookPrintName pgf cnc cat) + + +{- +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 :: CId -> CatQuestions -> String +getCatQuestion c qs = + fromMaybe (error "No question for category " ++ showCId c) (lookup c qs) + +-- +-- * Generate VoiceXML +-- + +skel2vxml :: String -> Maybe String -> CId -> Skeleton -> 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 -> CId -> [(CId, [CId])] -> [XML] +catForms gr qs cat fs = + comments [showCId cat ++ " category."] + ++ [cat2form gr qs cat fs] + +cat2form :: String -> CatQuestions -> CId -> [(CId, [CId])] -> 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 -> CId -> CId -> [CId] -> [XML] +fun2sub gr cat fun args = + comments [showCId fun ++ " : (" + ++ concat (intersperse ", " (map showCId args)) + ++ ") " ++ showCId cat] ++ ss + where + ss = zipWith mkSub [0..] args + mkSub n t = subdialog s [("src","#"++catFormId t), + ("cond","term.name == "++string (showCId fun))] + [param "old" v, + filled [] [assign v (s++".term")]] + where s = showCId fun ++ "_" ++ show n + v = "term.args["++show n++"]" + +catFormId :: CId -> String +catFormId c = showCId 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 :: (CId, [(CId, [CId])]) -> Bool +isListCat (cat,rules) = "List" `isPrefixOf` showIdent cat && length rules == 2 + && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs + where c = drop 4 (showIdent cat) + fs = map (showIdent . fst) rules + +isBaseFun :: CId -> Bool +isBaseFun f = "Base" `isPrefixOf` showIdent f + +isConsFun :: CId -> Bool +isConsFun f = "Cons" `isPrefixOf` showIdent f + +baseSize :: (CId, [(CId, [CId])]) -> Int +baseSize (_,rules) = length bs + where Just (_,bs) = find (isBaseFun . fst) rules +-} diff --git a/src/compiler/GF/System/NoReadline.hs b/src/compiler/GF/System/NoReadline.hs new file mode 100644 index 000000000..1f1050e8c --- /dev/null +++ b/src/compiler/GF/System/NoReadline.hs @@ -0,0 +1,33 @@ +---------------------------------------------------------------------- +-- | +-- 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, setCompletionFunction, filenameCompletionFunction) 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 + +setCompletionFunction :: Maybe (String -> String -> Int -> IO [String]) -> IO () +setCompletionFunction _ = return () + +filenameCompletionFunction :: String -> IO [String] +filenameCompletionFunction _ = return [] diff --git a/src/compiler/GF/System/NoSignal.hs b/src/compiler/GF/System/NoSignal.hs new file mode 100644 index 000000000..5d82a431e --- /dev/null +++ b/src/compiler/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/compiler/GF/System/Readline.hs b/src/compiler/GF/System/Readline.hs new file mode 100644 index 000000000..ee38cdc0b --- /dev/null +++ b/src/compiler/GF/System/Readline.hs @@ -0,0 +1,35 @@ +{-# 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, setCompletionFunction, filenameCompletionFunction) where + +#ifdef USE_HASKELINE + +import GF.System.UseHaskeline + +#elif USE_READLINE + +import GF.System.UseReadline + +#elif USE_EDITLINE + +import GF.System.UseEditline + +#else + +import GF.System.NoReadline + +#endif diff --git a/src/compiler/GF/System/Signal.hs b/src/compiler/GF/System/Signal.hs new file mode 100644 index 000000000..fe8a12483 --- /dev/null +++ b/src/compiler/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/compiler/GF/System/UseEditline.hs b/src/compiler/GF/System/UseEditline.hs new file mode 100644 index 000000000..6d51a1be3 --- /dev/null +++ b/src/compiler/GF/System/UseEditline.hs @@ -0,0 +1,36 @@ +---------------------------------------------------------------------- +-- | +-- 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.UseEditline (fetchCommand, setCompletionFunction, filenameCompletionFunction) where + +import System.Console.Editline.Readline + +fetchCommand :: String -> IO (String) +fetchCommand s = do + setCompletionAppendCharacter Nothing + --setBasicQuoteCharacters "" + res <- readline s + case res of + Nothing -> return "q" + Just s -> do addHistory s + return s + +setCompletionFunction :: Maybe (String -> String -> Int -> IO [String]) -> IO () +setCompletionFunction Nothing = setCompletionEntryFunction Nothing +setCompletionFunction (Just fn) = setCompletionEntryFunction (Just my_fn) + where + my_fn prefix = do + s <- getLineBuffer + p <- getPoint + fn s prefix p diff --git a/src/compiler/GF/System/UseHaskeline.hs b/src/compiler/GF/System/UseHaskeline.hs new file mode 100644 index 000000000..140407439 --- /dev/null +++ b/src/compiler/GF/System/UseHaskeline.hs @@ -0,0 +1,43 @@ +---------------------------------------------------------------------- +-- | +-- 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.UseHaskeline (fetchCommand, setCompletionFunction, filenameCompletionFunction) where + +import System.Console.Haskeline +import System.Directory + +fetchCommand :: String -> IO (String) +fetchCommand s = do + settings <- getGFSettings + res <- runInputT settings (getInputLine s) + case res of + Nothing -> return "q" + Just s -> return s + +getGFSettings :: IO (Settings IO) +getGFSettings = do + path <- getAppUserDataDirectory "gf_history" + return $ + Settings { + complete = completeFilename, + historyFile = Just path, + autoAddHistory = True + } + + +setCompletionFunction :: Maybe (String -> String -> Int -> IO [String]) -> IO () +setCompletionFunction _ = return () + +filenameCompletionFunction :: String -> IO [String] +filenameCompletionFunction _ = return [] diff --git a/src/compiler/GF/System/UseReadline.hs b/src/compiler/GF/System/UseReadline.hs new file mode 100644 index 000000000..a0e051601 --- /dev/null +++ b/src/compiler/GF/System/UseReadline.hs @@ -0,0 +1,36 @@ +---------------------------------------------------------------------- +-- | +-- 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, setCompletionFunction, filenameCompletionFunction) where + +import System.Console.Readline + +fetchCommand :: String -> IO (String) +fetchCommand s = do + setCompletionAppendCharacter Nothing + setBasicQuoteCharacters "" + res <- readline s + case res of + Nothing -> return "q" + Just s -> do addHistory s + return s + +setCompletionFunction :: Maybe (String -> String -> Int -> IO [String]) -> IO () +setCompletionFunction Nothing = setCompletionEntryFunction Nothing +setCompletionFunction (Just fn) = setCompletionEntryFunction (Just my_fn) + where + my_fn prefix = do + s <- getLineBuffer + p <- getPoint + fn s prefix p diff --git a/src/compiler/GF/System/UseSignal.hs b/src/compiler/GF/System/UseSignal.hs new file mode 100644 index 000000000..20c70a568 --- /dev/null +++ b/src/compiler/GF/System/UseSignal.hs @@ -0,0 +1,72 @@ +{-# OPTIONS -cpp #-} +---------------------------------------------------------------------- +-- | +-- 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 (SomeException,catch) +import Prelude hiding (catch) +import System.IO + +#ifdef mingw32_HOST_OS +import GHC.ConsoleHandler + +myInstallHandler handler = installHandler handler +myCatch = Catch . const +myIgnore = Ignore +#else +import System.Posix.Signals + +myInstallHandler handler = installHandler sigINT handler Nothing +myCatch = Catch +myIgnore = Ignore +#endif + +{-# 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 SomeException a) +runInterruptibly a = + do t <- myThreadId + oldH <- myInstallHandler (myCatch (killThread t)) + x <- p `catch` h + myInstallHandler oldH + 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 <- myInstallHandler myIgnore + x <- a + myInstallHandler oldH + return x diff --git a/src/compiler/GF/Text/CP1250.hs b/src/compiler/GF/Text/CP1250.hs new file mode 100644 index 000000000..474c04ace --- /dev/null +++ b/src/compiler/GF/Text/CP1250.hs @@ -0,0 +1,77 @@ +module GF.Text.CP1250 where + +import Data.Char + +decodeCP1250 = map convert where + convert c + | c == '\x80' = chr 0x20AC + | c == '\x82' = chr 0x201A + | c == '\x84' = chr 0x201E + | c == '\x85' = chr 0x2026 + | c == '\x86' = chr 0x2020 + | c == '\x87' = chr 0x2021 + | c == '\x89' = chr 0x2030 + | c == '\x8A' = chr 0x0160 + | c == '\x8B' = chr 0x2039 + | c == '\x8C' = chr 0x015A + | c == '\x8D' = chr 0x0164 + | c == '\x8E' = chr 0x017D + | c == '\x8F' = chr 0x0179 + | c == '\x91' = chr 0x2018 + | c == '\x92' = chr 0x2019 + | c == '\x93' = chr 0x201C + | c == '\x94' = chr 0x201D + | c == '\x95' = chr 0x2022 + | c == '\x96' = chr 0x2013 + | c == '\x97' = chr 0x2014 + | c == '\x99' = chr 0x2122 + | c == '\x9A' = chr 0x0161 + | c == '\x9B' = chr 0x203A + | c == '\x9C' = chr 0x015B + | c == '\x9D' = chr 0x0165 + | c == '\x9E' = chr 0x017E + | c == '\x9F' = chr 0x017A + | c == '\xA1' = chr 0x02C7 + | c == '\xA5' = chr 0x0104 + | c == '\xB9' = chr 0x0105 + | c == '\xBC' = chr 0x013D + | c == '\xBE' = chr 0x013E + | otherwise = c + + +encodeCP1250 = map convert where + convert c + | oc == 0x20AC = '\x80' + | oc == 0x201A = '\x82' + | oc == 0x201E = '\x84' + | oc == 0x2026 = '\x85' + | oc == 0x2020 = '\x86' + | oc == 0x2021 = '\x87' + | oc == 0x2030 = '\x89' + | oc == 0x0160 = '\x8A' + | oc == 0x2039 = '\x8B' + | oc == 0x015A = '\x8C' + | oc == 0x0164 = '\x8D' + | oc == 0x017D = '\x8E' + | oc == 0x0179 = '\x8F' + | oc == 0x2018 = '\x91' + | oc == 0x2019 = '\x92' + | oc == 0x201C = '\x93' + | oc == 0x201D = '\x94' + | oc == 0x2022 = '\x95' + | oc == 0x2013 = '\x96' + | oc == 0x2014 = '\x97' + | oc == 0x2122 = '\x99' + | oc == 0x0161 = '\x9A' + | oc == 0x203A = '\x9B' + | oc == 0x015B = '\x9C' + | oc == 0x0165 = '\x9D' + | oc == 0x017E = '\x9E' + | oc == 0x017A = '\x9F' + | oc == 0x02C7 = '\xA1' + | oc == 0x0104 = '\xA5' + | oc == 0x0105 = '\xB9' + | oc == 0x013D = '\xBC' + | oc == 0x013E = '\xBE' + | otherwise = c + where oc = ord c diff --git a/src/compiler/GF/Text/CP1251.hs b/src/compiler/GF/Text/CP1251.hs new file mode 100644 index 000000000..7c277abab --- /dev/null +++ b/src/compiler/GF/Text/CP1251.hs @@ -0,0 +1,74 @@ +module GF.Text.CP1251 where + +import Data.Char + +decodeCP1251 = map convert where + convert c + | c >= '\xC0' && c <= '\xFF' = chr (ord c + (0x410-0xC0)) + | c == '\xA8' = chr 0x401 -- cyrillic capital letter lo + | c == '\x80' = chr 0x402 + | c == '\x81' = chr 0x403 + | c == '\xAA' = chr 0x404 + | c == '\xBD' = chr 0x405 + | c == '\xB2' = chr 0x406 + | c == '\xAF' = chr 0x407 + | c == '\xA3' = chr 0x408 + | c == '\x8A' = chr 0x409 + | c == '\x8C' = chr 0x40A + | c == '\x8E' = chr 0x40B + | c == '\x8D' = chr 0x40C + | c == '\xA1' = chr 0x40E + | c == '\x8F' = chr 0x40F + | c == '\xB8' = chr 0x451 -- cyrillic small letter lo + | c == '\x90' = chr 0x452 + | c == '\x83' = chr 0x453 + | c == '\xBA' = chr 0x454 + | c == '\xBE' = chr 0x455 + | c == '\xB3' = chr 0x456 + | c == '\xBF' = chr 0x457 + | c == '\xBC' = chr 0x458 + | c == '\x9A' = chr 0x459 + | c == '\x9C' = chr 0x45A + | c == '\x9E' = chr 0x45B + | c == '\x9D' = chr 0x45C + | c == '\xA2' = chr 0x45E + | c == '\x9F' = chr 0x45F + | c == '\xA5' = chr 0x490 + | c == '\xB4' = chr 0x491 + | otherwise = c + +encodeCP1251 = map convert where + convert c + | oc >= 0x410 && oc <= 0x44F = chr (oc - (0x410-0xC0)) + | oc == 0x401 = '\xA8' -- cyrillic capital letter lo + | oc == 0x402 = '\x80' + | oc == 0x403 = '\x81' + | oc == 0x404 = '\xAA' + | oc == 0x405 = '\xBD' + | oc == 0x406 = '\xB2' + | oc == 0x407 = '\xAF' + | oc == 0x408 = '\xA3' + | oc == 0x409 = '\x8A' + | oc == 0x40A = '\x8C' + | oc == 0x40B = '\x8E' + | oc == 0x40C = '\x8D' + | oc == 0x40E = '\xA1' + | oc == 0x40F = '\x8F' + | oc == 0x451 = '\xB8' -- cyrillic small letter lo + | oc == 0x452 = '\x90' + | oc == 0x453 = '\x83' + | oc == 0x454 = '\xBA' + | oc == 0x455 = '\xBE' + | oc == 0x456 = '\xB3' + | oc == 0x457 = '\xBF' + | oc == 0x458 = '\xBC' + | oc == 0x459 = '\x9A' + | oc == 0x45A = '\x9C' + | oc == 0x45B = '\x9E' + | oc == 0x45C = '\x9D' + | oc == 0x45E = '\xA2' + | oc == 0x45F = '\x9F' + | oc == 0x490 = '\xA5' + | oc == 0x491 = '\xB4' + | otherwise = c + where oc = ord c diff --git a/src/compiler/GF/Text/CP1252.hs b/src/compiler/GF/Text/CP1252.hs new file mode 100644 index 000000000..1e5affe53 --- /dev/null +++ b/src/compiler/GF/Text/CP1252.hs @@ -0,0 +1,6 @@ +module GF.Text.CP1252 where + +import Data.Char + +decodeCP1252 = map id +encodeCP1252 = map (\x -> if x <= '\255' then x else '?') diff --git a/src/compiler/GF/Text/Coding.hs b/src/compiler/GF/Text/Coding.hs new file mode 100644 index 000000000..e3cd7b0ea --- /dev/null +++ b/src/compiler/GF/Text/Coding.hs @@ -0,0 +1,21 @@ +module GF.Text.Coding where + +import GF.Infra.Option +import GF.Text.UTF8 +import GF.Text.CP1250 +import GF.Text.CP1251 +import GF.Text.CP1252 + +encodeUnicode e = case e of + UTF_8 -> encodeUTF8 + CP_1250 -> encodeCP1250 + CP_1251 -> encodeCP1251 + CP_1252 -> encodeCP1252 + _ -> id + +decodeUnicode e = case e of + UTF_8 -> decodeUTF8 + CP_1250 -> decodeCP1250 + CP_1251 -> decodeCP1251 + CP_1252 -> decodeCP1252 + _ -> id diff --git a/src/compiler/GF/Text/Lexing.hs b/src/compiler/GF/Text/Lexing.hs new file mode 100644 index 000000000..3300d311e --- /dev/null +++ b/src/compiler/GF/Text/Lexing.hs @@ -0,0 +1,131 @@ +module GF.Text.Lexing (stringOp,opInEnv) where + +import GF.Text.Transliterations +import GF.Text.UTF8 +import GF.Text.CP1251 + +import Data.Char +import Data.List (intersperse) + +-- lexers and unlexers - they work on space-separated word strings + +stringOp :: String -> Maybe (String -> String) +stringOp name = case name of + "chars" -> Just $ appLexer (filter (not . all isSpace) . map return) + "lextext" -> Just $ appLexer lexText + "lexcode" -> Just $ appLexer lexCode + "lexmixed" -> Just $ appLexer lexMixed + "words" -> Just $ appLexer words + "bind" -> Just $ appUnlexer bindTok + "unchars" -> Just $ appUnlexer concat + "unlextext" -> Just $ appUnlexer unlexText + "unlexcode" -> Just $ appUnlexer unlexCode + "unlexmixed" -> Just $ appUnlexer unlexMixed + "unwords" -> Just $ appUnlexer unwords + "to_html" -> Just wrapHTML + "to_utf8" -> Just encodeUTF8 + "from_utf8" -> Just decodeUTF8 + "to_cp1251" -> Just encodeCP1251 + "from_cp1251" -> Just decodeCP1251 + _ -> transliterate name + +-- perform op in environments beg--end, t.ex. between "--" +--- suboptimal implementation +opInEnv :: String -> String -> (String -> String) -> (String -> String) +opInEnv beg end op = concat . altern False . chop (lbeg, beg) [] where + chop mk@(lg, mark) s0 s = + let (tag,rest) = splitAt lg s in + if tag==mark then (reverse s0) : mark : chop (switch mk) [] rest + else case s of + c:cs -> chop mk (c:s0) cs + [] -> [reverse s0] + switch (lg,mark) = if mark==beg then (lend,end) else (lbeg,beg) + (lbeg,lend) = (length beg, length end) + altern m ts = case ts of + t:ws | not m && t==beg -> t : altern True ws + t:ws | m && t==end -> t : altern False ws + t:ws -> (if m then op t else t) : altern m ws + [] -> [] + +appLexer :: (String -> [String]) -> String -> String +appLexer f = unwords . filter (not . null) . f + +appUnlexer :: ([String] -> String) -> String -> String +appUnlexer f = unlines . map (f . words) . lines + +wrapHTML :: String -> String +wrapHTML = unlines . tag . intersperse "
" . lines where + tag ss = "":"":"":"":"" : ss ++ ["",""] + +lexText :: String -> [String] +lexText = uncap . lext where + lext s = case s of + c:cs | isMajorPunct c -> [c] : uncap (lext cs) + c:cs | isMinorPunct c -> [c] : lext cs + c:cs | isSpace c -> lext cs + _:_ -> let (w,cs) = break (\x -> isSpace x || isPunct x) s in w : lext cs + _ -> [s] + uncap s = case s of + (c:cs):ws -> (toLower c : cs):ws + _ -> s + +-- | Haskell lexer, usable for much code +lexCode :: String -> [String] +lexCode ss = case lex ss of + [(w@(_:_),ws)] -> w : lexCode ws + _ -> [] + +-- | LaTeX style lexer, with "math" environment using Code between $...$ +lexMixed :: String -> [String] +lexMixed = concat . alternate False where + alternate env s = case s of + _:_ -> case break (=='$') s of + (t,[]) -> lex env t : [] + (t,c:m) -> lex env t : [[c]] : alternate (not env) m + _ -> [] + lex env = if env then lexCode else lexText + +bindTok :: [String] -> String +bindTok ws = case ws of + w:"&+":ws2 -> w ++ bindTok ws2 + w:[] -> w + w:ws2 -> w ++ " " ++ bindTok ws2 + [] -> "" + +unlexText :: [String] -> String +unlexText = cap . unlext where + unlext s = case s of + w:[] -> w + w:[c]:[] | isPunct c -> w ++ [c] + w:[c]:cs | isMajorPunct c -> w ++ [c] ++ " " ++ cap (unlext cs) + w:[c]:cs | isMinorPunct c -> w ++ [c] ++ " " ++ unlext cs + w:ws -> w ++ " " ++ unlext ws + _ -> [] + cap s = case s of + c:cs -> toUpper c : cs + _ -> s + +unlexCode :: [String] -> String +unlexCode s = case s of + w:[] -> w + [c]:cs | isParen c -> [c] ++ unlexCode cs + w:cs@([c]:_) | isClosing c -> w ++ unlexCode cs + w:ws -> w ++ " " ++ unlexCode ws + _ -> [] + + +unlexMixed :: [String] -> String +unlexMixed = concat . alternate False where + alternate env s = case s of + _:_ -> case break (=="$") s of + (t,[]) -> unlex env t : [] + (t,c:m) -> unlex env t : sep env c : alternate (not env) m + _ -> [] + unlex env = if env then unlexCode else unlexText + sep env c = if env then c ++ " " else " " ++ c + +isPunct = flip elem ".?!,:;" +isMajorPunct = flip elem ".?!" +isMinorPunct = flip elem ",:;" +isParen = flip elem "()[]{}" +isClosing = flip elem ")]}" diff --git a/src/compiler/GF/Text/Transliterations.hs b/src/compiler/GF/Text/Transliterations.hs new file mode 100644 index 000000000..e2747f506 --- /dev/null +++ b/src/compiler/GF/Text/Transliterations.hs @@ -0,0 +1,206 @@ +module GF.Text.Transliterations ( + transliterate, + transliteration, + characterTable, + transliterationPrintNames + ) where + +import GF.Text.UTF8 + +import Data.Char +import Numeric +import qualified Data.Map as Map + +-- transliterations between ASCII and a Unicode character set + +-- current transliterations: devanagari, thai + +-- to add a new one: define the Unicode range and the corresponding ASCII strings, +-- which may be one or more characters long + +-- conventions to be followed: +-- each character is either [letter] or [letter+nonletters] +-- when using a sparse range of unicodes, mark missing codes as "-" in transliterations +-- characters can be invisible: ignored in translation to unicode + +transliterate :: String -> Maybe (String -> String) +transliterate s = case s of + 'f':'r':'o':'m':'_':t -> fmap appTransFromUnicode $ transliteration t + 't':'o':'_':t -> fmap appTransToUnicode $ transliteration t + _ -> Nothing + +transliteration :: String -> Maybe Transliteration +transliteration s = Map.lookup s allTransliterations + +allTransliterations = Map.fromAscList [ + ("ancientgreek", transAncientGreek), + ("arabic", transArabic), + ("devanagari", transDevanagari), + ("greek", transGreek), + ("hebrew", transHebrew), + ("persian", transPersian), + ("telugu", transTelugu), + ("thai", transThai) + ---- "urdu", transUrdu + ] + +-- used in command options and help +transliterationPrintNames = [(t,printname p) | (t,p) <- Map.toList allTransliterations] + +characterTable :: Transliteration -> String +characterTable = unlines . map prOne . Map.assocs . trans_from_unicode where + prOne (i,s) = unwords ["|", showHex i "", "|", [toEnum i], "|", s, "|"] + +data Transliteration = Trans { + trans_to_unicode :: Map.Map String Int, + trans_from_unicode :: Map.Map Int String, + invisible_chars :: [String], + printname :: String + } + +appTransToUnicode :: Transliteration -> String -> String +appTransToUnicode trans = + concat . + map (\c -> maybe c (return . toEnum) $ + Map.lookup c (trans_to_unicode trans) + ) . + filter (flip notElem (invisible_chars trans)) . + unchar + +appTransFromUnicode :: Transliteration -> String -> String +appTransFromUnicode trans = + concat . + map (maybe "?" id . + flip Map.lookup (trans_from_unicode trans) + ) . + map fromEnum + + +mkTransliteration :: String -> [String] -> [Int] -> Transliteration +mkTransliteration name ts us = + Trans (Map.fromList (tzip ts us)) (Map.fromList (uzip us ts)) [] name + where + tzip ts us = [(t,u) | (t,u) <- zip ts us, t /= "-"] + uzip us ts = [(u,t) | (u,t) <- zip us ts, t /= "-"] + + +unchar :: String -> [String] +unchar s = case s of + c:d:cs + | isAlpha d -> [c] : unchar (d:cs) + | isSpace d -> [c]:[d]: unchar cs + | otherwise -> let (ds,cs2) = break (\x -> isAlpha x || isSpace x) cs in + (c:d:ds) : unchar cs2 + [_] -> [s] + _ -> [] + +transThai :: Transliteration +transThai = mkTransliteration "Thai" allTrans allCodes where + allTrans = 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 - - - - - - " + allCodes = [0x0e00 .. 0x0e7f] + +transDevanagari :: Transliteration +transDevanagari = + (mkTransliteration "Devanagari" + allTransUrduHindi allCodes){invisible_chars = ["a"]} where + allCodes = [0x0900 .. 0x095f] + +allTransUrduHindi = words $ + "- M N - - a- A- i- I- u- U- R- - - - e- " ++ + "E- - - o- O- k K g G N: c C j J n: t. " ++ + "T. d. D. n. t T d D n - p P b B m y " ++ + "r - l - - v S s. s h - - r: - A i " ++ + "I u U R - - - e E o O - - - - - " ++ + "- - - - - - - - - - - z r. - - - " + +transUrdu :: Transliteration +transUrdu = + (mkTransliteration "Urdu" allTransUrduHindi allCodes){invisible_chars = ["a"]} where + allCodes = [0x0900 .. 0x095f] ---- TODO: this is devanagari + +transArabic :: Transliteration +transArabic = mkTransliteration "Arabic" allTrans allCodes where + allTrans = words $ + " V A: A? w? A- y? A b t. t v g H K d " ++ -- 0621 - 062f + "W r z s C S D T Z c G " ++ -- 0630 - 063a + " f q k l m n h w y. y a. u. i. a u " ++ -- 0641 - 064f + "i v2 o a: V+ V- i: a+ " ++ -- 0650 - 0657 + "A* " -- 0671 (used by AED) + allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++ + [0x0641..0x064f] ++ [0x0650..0x0657] ++ [0x0671] + +transPersian :: Transliteration +transPersian = (mkTransliteration "Persian/Farsi" allTrans allCodes) + {invisible_chars = ["a","u","i"]} where + allTrans = words $ + " V A: A? w? A- y? A b t. t t- j H K d " ++ -- 0621 - 062f + "W r z s C S D T Z c G " ++ -- 0630 - 063a + " f q k l m n h v y. y a. u. i. a u " ++ -- 0641 - 064f + "i v2 o a: V+ V- i: a+ " ++ -- 0650 - 0657 + "p c^ J g " + allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++ + [0x0641..0x064f] ++ [0x0650..0x0657] ++ + [0x067e,0x0686,0x0698,0x06af] + +transHebrew :: Transliteration +transHebrew = mkTransliteration "unvocalized Hebrew" allTrans allCodes where + allTrans = words $ + "A b g d h w z H T y K k l M m N " ++ + "n S O P p Z. Z q r s t - - - - - " ++ + "w2 w3 y2 g1 g2" + allCodes = [0x05d0..0x05f4] + +transTelugu :: Transliteration +transTelugu = mkTransliteration "Telugu" allTrans allCodes where + allTrans = words $ + "- c1 c2 c3 - A A: I I: U U: R_ L_ - E E: " ++ + "A' - O O: A_ k k. g g. n. c c. j j. n' T " ++ + "T. d d. N t t. d d. n - p p. b b. m y " ++ + "r R l L - v s' S s h - - - c5 a: i " ++ + "i: u u: r_ r. - e e: a' - o o: a_ c6 - - " ++ + "- - - - - c7 c8 z Z - - - - - - - " ++ + "R+ L+ l+ l* - - n0 n1 n2 n3 n4 n5 n6 n7 n8 n9 " + allCodes = [0x0c00 .. 0x0c7f] + +transGreek :: Transliteration +transGreek = mkTransliteration "modern Greek" allTrans allCodes where + allTrans = words $ + "- - - - - - A' - E' H' I' - O' - Y' W' " ++ + "i= A B G D E Z H V I K L M N X O " ++ + "P R - S T Y F C Q W I- Y- a' e' h' i' " ++ + "y= a b g d e z h v i k l m n x o " ++ + "p r s* s t y f c q w i- y- o' y' w' - " + allCodes = [0x0380 .. 0x03cf] + +transAncientGreek :: Transliteration +transAncientGreek = mkTransliteration "ancient Greek" allTrans allCodes where + allTrans = words $ + "- - - - - - - - - - - - - - - - " ++ + "i= A B G D E Z H V I K L M N X O " ++ + "P R - S T Y F C Q W I- Y- - - - - " ++ + "y= a b g d e z h v i k l m n x o " ++ + "p r s* s t y f c q w i- y- - - - - " ++ + "a) a( a)` a(` a)' a(' a)~ a(~ A) A( A)` A(` A)' A(' A)~ A(~ " ++ + "e) e( e)` e(` e)' e(' - - E) E( E)` E(` E)' E(' - - " ++ + "h) h( h)` h(` h)' h(' h)~ h(~ H) H( H)` H(` H)' H(' H)~ H(~ " ++ + "i) i( i)` i(` i)' i(' i)~ i(~ I) I( I)` I(` I)' I(' I)~ I(~ " ++ + "o) o( o)` o(` o)' o(' - - O) O( O)` O(` O)' O(' - - " ++ + "y) y( y)` y(` y)' y(' y)~ y(~ - Y( - Y(` - Y(' - Y(~ " ++ + "w) w( w)` w(` w)' w(' w)~ w(~ W) W( W)` W(` W)' W(' W)~ W(~ " ++ + "a` a' e` e' h` h' i` i' o` o' y` y' w` w' - - " ++ + "a|( a|) a|)` a|(` a|)' a|(' a|)~ a|(~ - - - - - - - - " ++ -- 1f80- + "h|( h|) h|)` h|(` h|)' h|(' h|)~ h|(~ - - - - - - - - " ++ -- 1f90- + "w|( w|) w|)` w|(` w|)' w|(' w|)~ w|(~ - - - - - - - - " ++ -- 1fa0- + "a. a_ a|` a| a|' - a~ a|~ - - - - - - - - " ++ -- 1fb0- + "- - h|` h| h|' - h~ h|~ - - - - - - - - " ++ -- 1fc0- + "i. i_ i=` i=' - - i~ i=~ - - - - - - - - " ++ -- 1fd0- + "y. y_ y=` y=' r) r( y~ y|~ - - - - - - - - " ++ -- 1fe0- + "- - w|` w| w|' - w~ w|~ - - - - - - - - " -- 1ff0- + allCodes = [0x0380 .. 0x03cf] ++ [0x1f00 .. 0x1fff] + diff --git a/src/compiler/GF/Text/UTF8.hs b/src/compiler/GF/Text/UTF8.hs new file mode 100644 index 000000000..5e9687684 --- /dev/null +++ b/src/compiler/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/compiler/GFC.hs b/src/compiler/GFC.hs new file mode 100644 index 000000000..8037d4f1a --- /dev/null +++ b/src/compiler/GFC.hs @@ -0,0 +1,88 @@ +module GFC (mainGFC) where +-- module Main where + +import PGF +import PGF.CId +import PGF.Data +import GF.Compile +import GF.Compile.Export + +import GF.Grammar.CF ---- should this be on a deeper level? AR 15/10/2008 + +import GF.Infra.UseIO +import GF.Infra.Option +import GF.Data.ErrM + +import Data.Maybe +import Data.Binary +import System.FilePath +import System.IO + + +mainGFC :: Options -> [FilePath] -> IOE () +mainGFC opts fs = + case () of + _ | null fs -> fail $ "No input files." + _ | all (extensionIs ".cf") fs -> compileCFFiles opts fs + _ | all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f) fs -> compileSourceFiles opts fs + _ | all (extensionIs ".pgf") fs -> unionPGFFiles opts fs + _ -> fail $ "Don't know what to do with these input files: " ++ unwords fs + where extensionIs ext = (== ext) . takeExtension + +compileSourceFiles :: Options -> [FilePath] -> IOE () +compileSourceFiles opts fs = + do gr <- batchCompile opts fs + let cnc = justModuleName (last fs) + if flag optStopAfterPhase opts == Compile + then return () + else do pgf <- link opts cnc gr + writePGF opts pgf + writeOutputs opts pgf + +compileCFFiles :: Options -> [FilePath] -> IOE () +compileCFFiles opts fs = + do s <- ioeIO $ fmap unlines $ mapM readFile fs + let cnc = justModuleName (last fs) + gf <- ioeErr $ getCF cnc s + gr <- compileSourceGrammar opts gf + if flag optStopAfterPhase opts == Compile + then return () + else do pgf <- link opts cnc gr + writePGF opts pgf + writeOutputs opts pgf + +unionPGFFiles :: Options -> [FilePath] -> IOE () +unionPGFFiles opts fs = + do pgfs <- mapM readPGFVerbose fs + let pgf = foldl1 unionPGF pgfs + pgfFile = grammarName opts pgf <.> "pgf" + if pgfFile `elem` fs + then putStrLnE $ "Refusing to overwrite " ++ pgfFile + else writePGF opts pgf + writeOutputs opts pgf + where readPGFVerbose f = putPointE Normal opts ("Reading " ++ f ++ "...") $ ioeIO $ readPGF f + +writeOutputs :: Options -> PGF -> IOE () +writeOutputs opts pgf = do + sequence_ [writeOutput opts name str + | fmt <- flag optOutputFormats opts, + (name,str) <- exportPGF opts fmt pgf] + +writePGF :: Options -> PGF -> IOE () +writePGF opts pgf = do + let outfile = grammarName opts pgf <.> "pgf" + putPointE Normal opts ("Writing " ++ outfile ++ "...") $ ioeIO $ encodeFile outfile pgf + +grammarName :: Options -> PGF -> String +grammarName opts pgf = fromMaybe (showCId (absname pgf)) (flag optName opts) + +writeOutput :: Options -> FilePath-> String -> IOE () +writeOutput opts file str = + do let path = case flag optOutputDir opts of + Nothing -> file + Just dir -> dir file + writeOutputFile opts path str + +writeOutputFile :: Options -> FilePath -> String -> IOE () +writeOutputFile opts outfile output = + do putPointE Normal opts ("Writing " ++ outfile ++ "...") $ ioeIO $ writeFile outfile output diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs new file mode 100644 index 000000000..2ea22efa6 --- /dev/null +++ b/src/compiler/GFI.hs @@ -0,0 +1,363 @@ +{-# LANGUAGE ScopedTypeVariables, CPP #-} +module GFI (mainGFI,mainRunGFI) where + +import GF.Command.Interpreter +import GF.Command.Importing +import GF.Command.Commands +import GF.Command.Abstract +import GF.Command.Parse +import GF.Data.ErrM +import GF.Grammar hiding (Ident) +import GF.Grammar.Parser (runP, pExp) +import GF.Compile.Rename +import GF.Compile.Concrete.Compute (computeConcrete) +import GF.Compile.Concrete.TypeCheck (inferLType) +import GF.Infra.Dependencies +import GF.Infra.CheckM +import GF.Infra.UseIO +import GF.Infra.Option +import GF.Infra.Modules (greatestResource) +import GF.System.Readline + +import GF.Text.Coding +import GF.Compile.Coding + +import PGF +import PGF.Data +import PGF.Macros + +import Data.Char +import Data.Maybe +import Data.List(isPrefixOf) +import qualified Data.Map as Map +import qualified Data.ByteString.Char8 as BS +import qualified Text.ParserCombinators.ReadP as RP +import System.Cmd +import System.CPUTime +import System.Directory +import Control.Exception +import Control.Monad +import Data.Version +import GF.System.Signal +--import System.IO.Error (try) +#ifdef mingw32_HOST_OS +import System.Win32.Console +import System.Win32.NLS +#endif + +import Paths_gf + +mainRunGFI :: Options -> [FilePath] -> IO () +mainRunGFI opts files = do + let opts1 = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet})) opts + gfenv <- emptyGFEnv + gfenv <- importInEnv gfenv opts1 files + loop opts1 gfenv + return () + +mainGFI :: Options -> [FilePath] -> IO () +mainGFI opts files = do + putStrLn welcome + gfenv <- emptyGFEnv + gfenv <- importInEnv gfenv opts files + loop opts gfenv + return () + +loopOptNewCPU opts gfenv' + | not (verbAtLeast opts Normal) = return gfenv' + | otherwise = do + cpu' <- getCPUTime + putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec") + return $ gfenv' {cputime = cpu'} + +loop :: Options -> GFEnv -> IO GFEnv +loop opts gfenv0 = do + let loopNewCPU = loopOptNewCPU opts + let isv = verbAtLeast opts Normal + let ifv act = if isv then act else return () + let env = commandenv gfenv0 + let sgr = sourcegrammar gfenv0 + setCompletionFunction (Just (wordCompletion gfenv0)) + let fetch = case flag optMode opts of + ModeRun -> tryGetLine + _ -> fetchCommand (prompt env) + s0 <- fetch + let gfenv = gfenv0 {history = s0 : history gfenv0} + let + enc = encode gfenv + s = decode gfenv s0 + pwords = case words s of + w:ws -> getCommandOp w :ws + ws -> ws + + -- special commands, requiring source grammar in env + + case pwords of + + "q":_ -> ifv (putStrLn "See you.") >> return gfenv + + _ -> do + r <- runInterruptibly $ case pwords of + + "!":ws -> do + system $ unwords ws + loopNewCPU gfenv + "cc":ws -> do + let + pOpts style q ("-table" :ws) = pOpts TermPrintTable q ws + pOpts style q ("-all" :ws) = pOpts TermPrintAll q ws + pOpts style q ("-default":ws) = pOpts TermPrintDefault q ws + pOpts style q ("-unqual" :ws) = pOpts style Unqualified ws + pOpts style q ("-qual" :ws) = pOpts style Qualified ws + pOpts style q ws = (style,q,unwords ws) + + (style,q,s) = pOpts TermPrintDefault Qualified (tail (words s0)) + + checkComputeTerm gr t = do + mo <- maybe (Bad "no source grammar in scope") return $ greatestResource gr + ((t,_),_) <- runCheck $ do t <- renameSourceTerm gr mo t + inferLType gr [] t + computeConcrete sgr t + + case runP pExp (BS.pack s) of + Left (_,msg) -> putStrLn msg + Right t -> case checkComputeTerm sgr (codeTerm (decode gfenv) t) of + Ok x -> putStrLn $ enc (showTerm style q x) + Bad s -> putStrLn $ enc s + loopNewCPU gfenv + "dg":ws -> do + writeFile "_gfdepgraph.dot" (depGraph sgr) + putStrLn "wrote graph in file _gfdepgraph.dot" + loopNewCPU gfenv + "i":args -> do + gfenv' <- case parseOptions args of + Ok (opts',files) -> do + curr_dir <- getCurrentDirectory + lib_dir <- getLibraryDirectory (addOptions opts opts') + importInEnv gfenv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files + Bad err -> do + putStrLn $ "Command parse error: " ++ err + return gfenv + loopNewCPU gfenv' + + -- other special commands, working on GFEnv + "e":_ -> loopNewCPU $ gfenv { + commandenv=emptyCommandEnv, sourcegrammar = emptySourceGrammar + } + + "dc":f:ws -> do + case readCommandLine (unwords ws) of + Just comm -> loopNewCPU $ gfenv { + commandenv = env { + commandmacros = Map.insert f comm (commandmacros env) + } + } + _ -> putStrLn "command definition not parsed" >> loopNewCPU gfenv + + "dt":f:ws -> do + case readExpr (unwords ws) of + Just exp -> loopNewCPU $ gfenv { + commandenv = env { + expmacros = Map.insert f exp (expmacros env) + } + } + _ -> putStrLn "value definition not parsed" >> loopNewCPU gfenv + + "ph":_ -> + mapM_ (putStrLn . enc) (reverse (history gfenv0)) >> loopNewCPU gfenv + "se":c:_ -> + case lookup c encodings of + Just cod -> do +#ifdef mingw32_HOST_OS + case c of + 'c':'p':c -> case reads c of + [(cp,"")] -> setConsoleCP cp >> setConsoleOutputCP cp + _ -> return () + "utf8" -> setConsoleCP 65001 >> setConsoleOutputCP 65001 + _ -> return () +#endif + loopNewCPU $ gfenv {coding = cod} + Nothing -> do putStrLn "unknown encoding" + loopNewCPU gfenv + + -- ordinary commands, working on CommandEnv + _ -> do + interpretCommandLine enc env s + loopNewCPU gfenv +-- gfenv' <- return $ either (const gfenv) id r + gfenv' <- either (\e -> (print e >> return gfenv)) return r + loop opts gfenv' + +importInEnv :: GFEnv -> Options -> [FilePath] -> IO GFEnv +importInEnv gfenv opts files + | flag optRetainResource opts = + do src <- importSource (sourcegrammar gfenv) opts files + return $ gfenv {sourcegrammar = src} + | otherwise = + do let opts' = addOptions (setOptimization OptCSE False) opts + pgf0 = multigrammar (commandenv gfenv) + pgf1 <- importGrammar pgf0 opts' files + if (verbAtLeast opts Normal) + then putStrLnFlush $ unwords $ "\nLanguages:" : map showCId (languages pgf1) + else return () + return $ gfenv { commandenv = mkCommandEnv (coding gfenv) pgf1 } + +tryGetLine = do + res <- try getLine + case res of + Left (e :: SomeException) -> return "q" + Right l -> return l + +welcome = unlines [ + " ", + " * * * ", + " * * ", + " * * ", + " * ", + " * ", + " * * * * * * * ", + " * * * ", + " * * * * * * ", + " * * * ", + " * * * ", + " ", + "This is GF version "++showVersion version++". ", + "License: see help -license. ", + "Differences from GF 2.9: see help -changes.", + "Bug reports: http://code.google.com/p/grammatical-framework/issues/list" + ] + +prompt env + | abs == wildCId = "> " + | otherwise = showCId abs ++ "> " + where + abs = abstractName (multigrammar env) + +data GFEnv = GFEnv { + sourcegrammar :: SourceGrammar, -- gfo grammar -retain + commandenv :: CommandEnv, + history :: [String], + cputime :: Integer, + coding :: Encoding + } + +emptyGFEnv :: IO GFEnv +emptyGFEnv = do +#ifdef mingw32_HOST_OS + codepage <- getACP + let coding = fromMaybe UTF_8 (lookup ("cp"++show codepage) encodings) +#else + let coding = UTF_8 +#endif + return $ GFEnv emptySourceGrammar (mkCommandEnv coding emptyPGF) [] 0 coding + +encode = encodeUnicode . coding +decode = decodeUnicode . coding + +wordCompletion gfenv line0 prefix0 p = + case wc_type (take p line) of + CmplCmd pref + -> ret ' ' [name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name] + CmplStr (Just (Command _ opts _)) s + -> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optType opts))) + case mb_state0 of + Right state0 -> let ws = words (take (length s - length prefix) s) + in case loop state0 ws of + Nothing -> ret ' ' [] + Just state -> let compls = getCompletions state prefix + in ret ' ' (map (encode gfenv) (Map.keys compls)) + Left (_ :: SomeException) -> ret ' ' [] + CmplOpt (Just (Command n _ _)) pref + -> case Map.lookup n (commands cmdEnv) of + Just inf -> do let flg_compls = ['-':flg | (flg,_) <- flags inf, isPrefixOf pref flg] + opt_compls = ['-':opt | (opt,_) <- options inf, isPrefixOf pref opt] + ret (if null flg_compls then ' ' else '=') + (flg_compls++opt_compls) + Nothing -> ret ' ' [] + CmplIdent (Just (Command "i" _ _)) _ -- HACK: file name completion for command i + -> filenameCompletionFunction prefix + CmplIdent _ pref + -> do mb_abs <- try (evaluate (abstract pgf)) + case mb_abs of + Right abs -> ret ' ' [name | cid <- Map.keys (funs abs), let name = showCId cid, isPrefixOf pref name] + Left (_ :: SomeException) -> ret ' ' [] + _ -> ret ' ' [] + where + line = decode gfenv line0 + prefix = decode gfenv prefix0 + + pgf = multigrammar cmdEnv + cmdEnv = commandenv gfenv + optLang opts = valCIdOpts "lang" (head (languages pgf)) opts + optType opts = + let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts + in case readType str of + Just ty -> ty + Nothing -> error ("Can't parse '"++str++"' as type") + + loop ps [] = Just ps + loop ps (t:ts) = case nextState ps t of + Left es -> Nothing + Right ps -> loop ps ts + + ret c [x] = return [x++[c]] + ret _ xs = return xs + + +data CompletionType + = CmplCmd Ident + | CmplStr (Maybe Command) String + | CmplOpt (Maybe Command) Ident + | CmplIdent (Maybe Command) Ident + deriving Show + +wc_type :: String -> CompletionType +wc_type = cmd_name + where + cmd_name cs = + let cs1 = dropWhile isSpace cs + in go cs1 cs1 + where + go x [] = CmplCmd x + go x (c:cs) + | isIdent c = go x cs + | otherwise = cmd x cs + + cmd x [] = ret CmplIdent x "" 0 + cmd _ ('|':cs) = cmd_name cs + cmd _ (';':cs) = cmd_name cs + cmd x ('"':cs) = str x cs cs + cmd x ('-':cs) = option x cs cs + cmd x (c :cs) + | isIdent c = ident x (c:cs) cs + | otherwise = cmd x cs + + option x y [] = ret CmplOpt x y 1 + option x y ('=':cs) = optValue x y cs + option x y (c :cs) + | isIdent c = option x y cs + | otherwise = cmd x cs + + optValue x y ('"':cs) = str x y cs + optValue x y cs = cmd x cs + + ident x y [] = ret CmplIdent x y 0 + ident x y (c:cs) + | isIdent c = ident x y cs + | otherwise = cmd x cs + + str x y [] = ret CmplStr x y 1 + str x y ('\"':cs) = cmd x cs + str x y ('\\':c:cs) = str x y cs + str x y (c:cs) = str x y cs + + ret f x y d = f cmd y + where + x1 = take (length x - length y - d) x + x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1 + + cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of + [x] -> Just x + _ -> Nothing + + isIdent c = c == '_' || c == '\'' || isAlphaNum c diff --git a/src/config.guess b/src/config.guess deleted file mode 100644 index c085f4f51..000000000 --- a/src/config.guess +++ /dev/null @@ -1,1497 +0,0 @@ -#! /bin/sh -# Attempt to guess a canonical system name. -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -# 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, -# Inc. - -timestamp='2006-05-13' - -# This file is free software; you can redistribute it and/or modify it -# under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA -# 02110-1301, USA. -# -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that program. - - -# Originally written by Per Bothner . -# Please send patches to . Submit a context -# diff and a properly formatted ChangeLog entry. -# -# This script attempts to guess a canonical system name similar to -# config.sub. If it succeeds, it prints the system name on stdout, and -# exits with 0. Otherwise, it exits with 1. -# -# The plan is that this can be called by configure scripts if you -# don't specify an explicit build system type. - -me=`echo "$0" | sed -e 's,.*/,,'` - -usage="\ -Usage: $0 [OPTION] - -Output the configuration name of the system \`$me' is run on. - -Operation modes: - -h, --help print this help, then exit - -t, --time-stamp print date of last modification, then exit - -v, --version print version number, then exit - -Report bugs and patches to ." - -version="\ -GNU config.guess ($timestamp) - -Originally written by Per Bothner. -Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 -Free Software Foundation, Inc. - -This is free software; see the source for copying conditions. There is NO -warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." - -help=" -Try \`$me --help' for more information." - -# Parse command line -while test $# -gt 0 ; do - case $1 in - --time-stamp | --time* | -t ) - echo "$timestamp" ; exit ;; - --version | -v ) - echo "$version" ; exit ;; - --help | --h* | -h ) - echo "$usage"; exit ;; - -- ) # Stop option processing - shift; break ;; - - ) # Use stdin as input. - break ;; - -* ) - echo "$me: invalid option $1$help" >&2 - exit 1 ;; - * ) - break ;; - esac -done - -if test $# != 0; then - echo "$me: too many arguments$help" >&2 - exit 1 -fi - -trap 'exit 1' 1 2 15 - -# CC_FOR_BUILD -- compiler used by this script. Note that the use of a -# compiler to aid in system detection is discouraged as it requires -# temporary files to be created and, as you can see below, it is a -# headache to deal with in a portable fashion. - -# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still -# use `HOST_CC' if defined, but it is deprecated. - -# Portable tmp directory creation inspired by the Autoconf team. - -set_cc_for_build=' -trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; -trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; -: ${TMPDIR=/tmp} ; - { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || - { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || - { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || - { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; -dummy=$tmp/dummy ; -tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; -case $CC_FOR_BUILD,$HOST_CC,$CC in - ,,) echo "int x;" > $dummy.c ; - for c in cc gcc c89 c99 ; do - if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then - CC_FOR_BUILD="$c"; break ; - fi ; - done ; - if test x"$CC_FOR_BUILD" = x ; then - CC_FOR_BUILD=no_compiler_found ; - fi - ;; - ,,*) CC_FOR_BUILD=$CC ;; - ,*,*) CC_FOR_BUILD=$HOST_CC ;; -esac ; set_cc_for_build= ;' - -# This is needed to find uname on a Pyramid OSx when run in the BSD universe. -# (ghazi@noc.rutgers.edu 1994-08-24) -if (test -f /.attbin/uname) >/dev/null 2>&1 ; then - PATH=$PATH:/.attbin ; export PATH -fi - -UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown -UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown -UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown -UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown - -# Note: order is significant - the case branches are not exclusive. - -case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in - *:NetBSD:*:*) - # NetBSD (nbsd) targets should (where applicable) match one or - # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*, - # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently - # switched to ELF, *-*-netbsd* would select the old - # object file format. This provides both forward - # compatibility and a consistent mechanism for selecting the - # object file format. - # - # Note: NetBSD doesn't particularly care about the vendor - # portion of the name. We always set it to "unknown". - sysctl="sysctl -n hw.machine_arch" - UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ - /usr/sbin/$sysctl 2>/dev/null || echo unknown)` - case "${UNAME_MACHINE_ARCH}" in - armeb) machine=armeb-unknown ;; - arm*) machine=arm-unknown ;; - sh3el) machine=shl-unknown ;; - sh3eb) machine=sh-unknown ;; - *) machine=${UNAME_MACHINE_ARCH}-unknown ;; - esac - # The Operating System including object format, if it has switched - # to ELF recently, or will in the future. - case "${UNAME_MACHINE_ARCH}" in - arm*|i386|m68k|ns32k|sh3*|sparc|vax) - eval $set_cc_for_build - if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ - | grep __ELF__ >/dev/null - then - # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). - # Return netbsd for either. FIX? - os=netbsd - else - os=netbsdelf - fi - ;; - *) - os=netbsd - ;; - esac - # The OS release - # Debian GNU/NetBSD machines have a different userland, and - # thus, need a distinct triplet. However, they do not need - # kernel version information, so it can be replaced with a - # suitable tag, in the style of linux-gnu. - case "${UNAME_VERSION}" in - Debian*) - release='-gnu' - ;; - *) - release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` - ;; - esac - # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: - # contains redundant information, the shorter form: - # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. - echo "${machine}-${os}${release}" - exit ;; - *:OpenBSD:*:*) - UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` - echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} - exit ;; - *:ekkoBSD:*:*) - echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} - exit ;; - *:SolidBSD:*:*) - echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} - exit ;; - macppc:MirBSD:*:*) - echo powerppc-unknown-mirbsd${UNAME_RELEASE} - exit ;; - *:MirBSD:*:*) - echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} - exit ;; - alpha:OSF1:*:*) - case $UNAME_RELEASE in - *4.0) - UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` - ;; - *5.*) - UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` - ;; - esac - # According to Compaq, /usr/sbin/psrinfo has been available on - # OSF/1 and Tru64 systems produced since 1995. I hope that - # covers most systems running today. This code pipes the CPU - # types through head -n 1, so we only detect the type of CPU 0. - ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` - case "$ALPHA_CPU_TYPE" in - "EV4 (21064)") - UNAME_MACHINE="alpha" ;; - "EV4.5 (21064)") - UNAME_MACHINE="alpha" ;; - "LCA4 (21066/21068)") - UNAME_MACHINE="alpha" ;; - "EV5 (21164)") - UNAME_MACHINE="alphaev5" ;; - "EV5.6 (21164A)") - UNAME_MACHINE="alphaev56" ;; - "EV5.6 (21164PC)") - UNAME_MACHINE="alphapca56" ;; - "EV5.7 (21164PC)") - UNAME_MACHINE="alphapca57" ;; - "EV6 (21264)") - UNAME_MACHINE="alphaev6" ;; - "EV6.7 (21264A)") - UNAME_MACHINE="alphaev67" ;; - "EV6.8CB (21264C)") - UNAME_MACHINE="alphaev68" ;; - "EV6.8AL (21264B)") - UNAME_MACHINE="alphaev68" ;; - "EV6.8CX (21264D)") - UNAME_MACHINE="alphaev68" ;; - "EV6.9A (21264/EV69A)") - UNAME_MACHINE="alphaev69" ;; - "EV7 (21364)") - UNAME_MACHINE="alphaev7" ;; - "EV7.9 (21364A)") - UNAME_MACHINE="alphaev79" ;; - esac - # A Pn.n version is a patched version. - # A Vn.n version is a released version. - # A Tn.n version is a released field test version. - # A Xn.n version is an unreleased experimental baselevel. - # 1.2 uses "1.2" for uname -r. - echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - exit ;; - Alpha\ *:Windows_NT*:*) - # How do we know it's Interix rather than the generic POSIX subsystem? - # Should we change UNAME_MACHINE based on the output of uname instead - # of the specific Alpha model? - echo alpha-pc-interix - exit ;; - 21064:Windows_NT:50:3) - echo alpha-dec-winnt3.5 - exit ;; - Amiga*:UNIX_System_V:4.0:*) - echo m68k-unknown-sysv4 - exit ;; - *:[Aa]miga[Oo][Ss]:*:*) - echo ${UNAME_MACHINE}-unknown-amigaos - exit ;; - *:[Mm]orph[Oo][Ss]:*:*) - echo ${UNAME_MACHINE}-unknown-morphos - exit ;; - *:OS/390:*:*) - echo i370-ibm-openedition - exit ;; - *:z/VM:*:*) - echo s390-ibm-zvmoe - exit ;; - *:OS400:*:*) - echo powerpc-ibm-os400 - exit ;; - arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) - echo arm-acorn-riscix${UNAME_RELEASE} - exit ;; - arm:riscos:*:*|arm:RISCOS:*:*) - echo arm-unknown-riscos - exit ;; - SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) - echo hppa1.1-hitachi-hiuxmpp - exit ;; - Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) - # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. - if test "`(/bin/universe) 2>/dev/null`" = att ; then - echo pyramid-pyramid-sysv3 - else - echo pyramid-pyramid-bsd - fi - exit ;; - NILE*:*:*:dcosx) - echo pyramid-pyramid-svr4 - exit ;; - DRS?6000:unix:4.0:6*) - echo sparc-icl-nx6 - exit ;; - DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) - case `/usr/bin/uname -p` in - sparc) echo sparc-icl-nx7; exit ;; - esac ;; - sun4H:SunOS:5.*:*) - echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) - echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - i86pc:SunOS:5.*:*) - echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4*:SunOS:6*:*) - # According to config.sub, this is the proper way to canonicalize - # SunOS6. Hard to guess exactly what SunOS6 will be like, but - # it's likely to be more like Solaris than SunOS4. - echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - sun4*:SunOS:*:*) - case "`/usr/bin/arch -k`" in - Series*|S4*) - UNAME_RELEASE=`uname -v` - ;; - esac - # Japanese Language versions have a version number like `4.1.3-JL'. - echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` - exit ;; - sun3*:SunOS:*:*) - echo m68k-sun-sunos${UNAME_RELEASE} - exit ;; - sun*:*:4.2BSD:*) - UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` - test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 - case "`/bin/arch`" in - sun3) - echo m68k-sun-sunos${UNAME_RELEASE} - ;; - sun4) - echo sparc-sun-sunos${UNAME_RELEASE} - ;; - esac - exit ;; - aushp:SunOS:*:*) - echo sparc-auspex-sunos${UNAME_RELEASE} - exit ;; - # The situation for MiNT is a little confusing. The machine name - # can be virtually everything (everything which is not - # "atarist" or "atariste" at least should have a processor - # > m68000). The system name ranges from "MiNT" over "FreeMiNT" - # to the lowercase version "mint" (or "freemint"). Finally - # the system name "TOS" denotes a system which is actually not - # MiNT. But MiNT is downward compatible to TOS, so this should - # be no problem. - atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit ;; - atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit ;; - *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) - echo m68k-atari-mint${UNAME_RELEASE} - exit ;; - milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) - echo m68k-milan-mint${UNAME_RELEASE} - exit ;; - hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) - echo m68k-hades-mint${UNAME_RELEASE} - exit ;; - *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) - echo m68k-unknown-mint${UNAME_RELEASE} - exit ;; - m68k:machten:*:*) - echo m68k-apple-machten${UNAME_RELEASE} - exit ;; - powerpc:machten:*:*) - echo powerpc-apple-machten${UNAME_RELEASE} - exit ;; - RISC*:Mach:*:*) - echo mips-dec-mach_bsd4.3 - exit ;; - RISC*:ULTRIX:*:*) - echo mips-dec-ultrix${UNAME_RELEASE} - exit ;; - VAX*:ULTRIX*:*:*) - echo vax-dec-ultrix${UNAME_RELEASE} - exit ;; - 2020:CLIX:*:* | 2430:CLIX:*:*) - echo clipper-intergraph-clix${UNAME_RELEASE} - exit ;; - mips:*:*:UMIPS | mips:*:*:RISCos) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c -#ifdef __cplusplus -#include /* for printf() prototype */ - int main (int argc, char *argv[]) { -#else - int main (argc, argv) int argc; char *argv[]; { -#endif - #if defined (host_mips) && defined (MIPSEB) - #if defined (SYSTYPE_SYSV) - printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); - #endif - #if defined (SYSTYPE_SVR4) - printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); - #endif - #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) - printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); - #endif - #endif - exit (-1); - } -EOF - $CC_FOR_BUILD -o $dummy $dummy.c && - dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && - SYSTEM_NAME=`$dummy $dummyarg` && - { echo "$SYSTEM_NAME"; exit; } - echo mips-mips-riscos${UNAME_RELEASE} - exit ;; - Motorola:PowerMAX_OS:*:*) - echo powerpc-motorola-powermax - exit ;; - Motorola:*:4.3:PL8-*) - echo powerpc-harris-powermax - exit ;; - Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) - echo powerpc-harris-powermax - exit ;; - Night_Hawk:Power_UNIX:*:*) - echo powerpc-harris-powerunix - exit ;; - m88k:CX/UX:7*:*) - echo m88k-harris-cxux7 - exit ;; - m88k:*:4*:R4*) - echo m88k-motorola-sysv4 - exit ;; - m88k:*:3*:R3*) - echo m88k-motorola-sysv3 - exit ;; - AViiON:dgux:*:*) - # DG/UX returns AViiON for all architectures - UNAME_PROCESSOR=`/usr/bin/uname -p` - if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] - then - if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ - [ ${TARGET_BINARY_INTERFACE}x = x ] - then - echo m88k-dg-dgux${UNAME_RELEASE} - else - echo m88k-dg-dguxbcs${UNAME_RELEASE} - fi - else - echo i586-dg-dgux${UNAME_RELEASE} - fi - exit ;; - M88*:DolphinOS:*:*) # DolphinOS (SVR3) - echo m88k-dolphin-sysv3 - exit ;; - M88*:*:R3*:*) - # Delta 88k system running SVR3 - echo m88k-motorola-sysv3 - exit ;; - XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) - echo m88k-tektronix-sysv3 - exit ;; - Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) - echo m68k-tektronix-bsd - exit ;; - *:IRIX*:*:*) - echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` - exit ;; - ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. - echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id - exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' - i*86:AIX:*:*) - echo i386-ibm-aix - exit ;; - ia64:AIX:*:*) - if [ -x /usr/bin/oslevel ] ; then - IBM_REV=`/usr/bin/oslevel` - else - IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} - fi - echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} - exit ;; - *:AIX:2:3) - if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - - main() - { - if (!__power_pc()) - exit(1); - puts("powerpc-ibm-aix3.2.5"); - exit(0); - } -EOF - if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` - then - echo "$SYSTEM_NAME" - else - echo rs6000-ibm-aix3.2.5 - fi - elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then - echo rs6000-ibm-aix3.2.4 - else - echo rs6000-ibm-aix3.2 - fi - exit ;; - *:AIX:*:[45]) - IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` - if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then - IBM_ARCH=rs6000 - else - IBM_ARCH=powerpc - fi - if [ -x /usr/bin/oslevel ] ; then - IBM_REV=`/usr/bin/oslevel` - else - IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} - fi - echo ${IBM_ARCH}-ibm-aix${IBM_REV} - exit ;; - *:AIX:*:*) - echo rs6000-ibm-aix - exit ;; - ibmrt:4.4BSD:*|romp-ibm:BSD:*) - echo romp-ibm-bsd4.4 - exit ;; - ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and - echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to - exit ;; # report: romp-ibm BSD 4.3 - *:BOSX:*:*) - echo rs6000-bull-bosx - exit ;; - DPX/2?00:B.O.S.:*:*) - echo m68k-bull-sysv3 - exit ;; - 9000/[34]??:4.3bsd:1.*:*) - echo m68k-hp-bsd - exit ;; - hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) - echo m68k-hp-bsd4.4 - exit ;; - 9000/[34678]??:HP-UX:*:*) - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - case "${UNAME_MACHINE}" in - 9000/31? ) HP_ARCH=m68000 ;; - 9000/[34]?? ) HP_ARCH=m68k ;; - 9000/[678][0-9][0-9]) - if [ -x /usr/bin/getconf ]; then - sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` - sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` - case "${sc_cpu_version}" in - 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 - 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 - 532) # CPU_PA_RISC2_0 - case "${sc_kernel_bits}" in - 32) HP_ARCH="hppa2.0n" ;; - 64) HP_ARCH="hppa2.0w" ;; - '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 - esac ;; - esac - fi - if [ "${HP_ARCH}" = "" ]; then - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - - #define _HPUX_SOURCE - #include - #include - - int main () - { - #if defined(_SC_KERNEL_BITS) - long bits = sysconf(_SC_KERNEL_BITS); - #endif - long cpu = sysconf (_SC_CPU_VERSION); - - switch (cpu) - { - case CPU_PA_RISC1_0: puts ("hppa1.0"); break; - case CPU_PA_RISC1_1: puts ("hppa1.1"); break; - case CPU_PA_RISC2_0: - #if defined(_SC_KERNEL_BITS) - switch (bits) - { - case 64: puts ("hppa2.0w"); break; - case 32: puts ("hppa2.0n"); break; - default: puts ("hppa2.0"); break; - } break; - #else /* !defined(_SC_KERNEL_BITS) */ - puts ("hppa2.0"); break; - #endif - default: puts ("hppa1.0"); break; - } - exit (0); - } -EOF - (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` - test -z "$HP_ARCH" && HP_ARCH=hppa - fi ;; - esac - if [ ${HP_ARCH} = "hppa2.0w" ] - then - eval $set_cc_for_build - - # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating - # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler - # generating 64-bit code. GNU and HP use different nomenclature: - # - # $ CC_FOR_BUILD=cc ./config.guess - # => hppa2.0w-hp-hpux11.23 - # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess - # => hppa64-hp-hpux11.23 - - if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | - grep __LP64__ >/dev/null - then - HP_ARCH="hppa2.0w" - else - HP_ARCH="hppa64" - fi - fi - echo ${HP_ARCH}-hp-hpux${HPUX_REV} - exit ;; - ia64:HP-UX:*:*) - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - echo ia64-hp-hpux${HPUX_REV} - exit ;; - 3050*:HI-UX:*:*) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - int - main () - { - long cpu = sysconf (_SC_CPU_VERSION); - /* The order matters, because CPU_IS_HP_MC68K erroneously returns - true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct - results, however. */ - if (CPU_IS_PA_RISC (cpu)) - { - switch (cpu) - { - case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; - case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; - case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; - default: puts ("hppa-hitachi-hiuxwe2"); break; - } - } - else if (CPU_IS_HP_MC68K (cpu)) - puts ("m68k-hitachi-hiuxwe2"); - else puts ("unknown-hitachi-hiuxwe2"); - exit (0); - } -EOF - $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && - { echo "$SYSTEM_NAME"; exit; } - echo unknown-hitachi-hiuxwe2 - exit ;; - 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) - echo hppa1.1-hp-bsd - exit ;; - 9000/8??:4.3bsd:*:*) - echo hppa1.0-hp-bsd - exit ;; - *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) - echo hppa1.0-hp-mpeix - exit ;; - hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) - echo hppa1.1-hp-osf - exit ;; - hp8??:OSF1:*:*) - echo hppa1.0-hp-osf - exit ;; - i*86:OSF1:*:*) - if [ -x /usr/sbin/sysversion ] ; then - echo ${UNAME_MACHINE}-unknown-osf1mk - else - echo ${UNAME_MACHINE}-unknown-osf1 - fi - exit ;; - parisc*:Lites*:*:*) - echo hppa1.1-hp-lites - exit ;; - C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) - echo c1-convex-bsd - exit ;; - C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit ;; - C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) - echo c34-convex-bsd - exit ;; - C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) - echo c38-convex-bsd - exit ;; - C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) - echo c4-convex-bsd - exit ;; - CRAY*Y-MP:*:*:*) - echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*[A-Z]90:*:*:*) - echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ - | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ - -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ - -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*TS:*:*:*) - echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*T3E:*:*:*) - echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - CRAY*SV1:*:*:*) - echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - *:UNICOS/mp:*:*) - echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' - exit ;; - F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) - FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` - FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` - echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" - exit ;; - 5000:UNIX_System_V:4.*:*) - FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` - FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` - echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" - exit ;; - i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) - echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} - exit ;; - sparc*:BSD/OS:*:*) - echo sparc-unknown-bsdi${UNAME_RELEASE} - exit ;; - *:BSD/OS:*:*) - echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} - exit ;; - *:FreeBSD:*:*) - case ${UNAME_MACHINE} in - pc98) - echo i386-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; - amd64) - echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; - *) - echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; - esac - exit ;; - i*:CYGWIN*:*) - echo ${UNAME_MACHINE}-pc-cygwin - exit ;; - i*:MINGW*:*) - echo ${UNAME_MACHINE}-pc-mingw32 - exit ;; - i*:windows32*:*) - # uname -m includes "-pc" on this system. - echo ${UNAME_MACHINE}-mingw32 - exit ;; - i*:PW*:*) - echo ${UNAME_MACHINE}-pc-pw32 - exit ;; - x86:Interix*:[345]*) - echo i586-pc-interix${UNAME_RELEASE} - exit ;; - EM64T:Interix*:[345]*) - echo x86_64-unknown-interix${UNAME_RELEASE} - exit ;; - [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) - echo i${UNAME_MACHINE}-pc-mks - exit ;; - i*:Windows_NT*:* | Pentium*:Windows_NT*:*) - # How do we know it's Interix rather than the generic POSIX subsystem? - # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we - # UNAME_MACHINE based on the output of uname instead of i386? - echo i586-pc-interix - exit ;; - i*:UWIN*:*) - echo ${UNAME_MACHINE}-pc-uwin - exit ;; - amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) - echo x86_64-unknown-cygwin - exit ;; - p*:CYGWIN*:*) - echo powerpcle-unknown-cygwin - exit ;; - prep*:SunOS:5.*:*) - echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit ;; - *:GNU:*:*) - # the GNU system - echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` - exit ;; - *:GNU/*:*:*) - # other systems with GNU libc and userland - echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu - exit ;; - i*86:Minix:*:*) - echo ${UNAME_MACHINE}-pc-minix - exit ;; - arm*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - cris:Linux:*:*) - echo cris-axis-linux-gnu - exit ;; - crisv32:Linux:*:*) - echo crisv32-axis-linux-gnu - exit ;; - frv:Linux:*:*) - echo frv-unknown-linux-gnu - exit ;; - ia64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - m32r*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - m68*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - mips:Linux:*:*) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #undef CPU - #undef mips - #undef mipsel - #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) - CPU=mipsel - #else - #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) - CPU=mips - #else - CPU= - #endif - #endif -EOF - eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n ' - /^CPU/{ - s: ::g - p - }'`" - test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } - ;; - mips64:Linux:*:*) - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #undef CPU - #undef mips64 - #undef mips64el - #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) - CPU=mips64el - #else - #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) - CPU=mips64 - #else - CPU= - #endif - #endif -EOF - eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n ' - /^CPU/{ - s: ::g - p - }'`" - test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } - ;; - or32:Linux:*:*) - echo or32-unknown-linux-gnu - exit ;; - ppc:Linux:*:*) - echo powerpc-unknown-linux-gnu - exit ;; - ppc64:Linux:*:*) - echo powerpc64-unknown-linux-gnu - exit ;; - alpha:Linux:*:*) - case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in - EV5) UNAME_MACHINE=alphaev5 ;; - EV56) UNAME_MACHINE=alphaev56 ;; - PCA56) UNAME_MACHINE=alphapca56 ;; - PCA57) UNAME_MACHINE=alphapca56 ;; - EV6) UNAME_MACHINE=alphaev6 ;; - EV67) UNAME_MACHINE=alphaev67 ;; - EV68*) UNAME_MACHINE=alphaev68 ;; - esac - objdump --private-headers /bin/sh | grep ld.so.1 >/dev/null - if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi - echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} - exit ;; - parisc:Linux:*:* | hppa:Linux:*:*) - # Look for CPU level - case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in - PA7*) echo hppa1.1-unknown-linux-gnu ;; - PA8*) echo hppa2.0-unknown-linux-gnu ;; - *) echo hppa-unknown-linux-gnu ;; - esac - exit ;; - parisc64:Linux:*:* | hppa64:Linux:*:*) - echo hppa64-unknown-linux-gnu - exit ;; - s390:Linux:*:* | s390x:Linux:*:*) - echo ${UNAME_MACHINE}-ibm-linux - exit ;; - sh64*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - sh*:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - sparc:Linux:*:* | sparc64:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-gnu - exit ;; - vax:Linux:*:*) - echo ${UNAME_MACHINE}-dec-linux-gnu - exit ;; - x86_64:Linux:*:*) - echo x86_64-unknown-linux-gnu - exit ;; - i*86:Linux:*:*) - # The BFD linker knows what the default object file format is, so - # first see if it will tell us. cd to the root directory to prevent - # problems with other programs or directories called `ld' in the path. - # Set LC_ALL=C to ensure ld outputs messages in English. - ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \ - | sed -ne '/supported targets:/!d - s/[ ][ ]*/ /g - s/.*supported targets: *// - s/ .*// - p'` - case "$ld_supported_targets" in - elf32-i386) - TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu" - ;; - a.out-i386-linux) - echo "${UNAME_MACHINE}-pc-linux-gnuaout" - exit ;; - coff-i386) - echo "${UNAME_MACHINE}-pc-linux-gnucoff" - exit ;; - "") - # Either a pre-BFD a.out linker (linux-gnuoldld) or - # one that does not give us useful --help. - echo "${UNAME_MACHINE}-pc-linux-gnuoldld" - exit ;; - esac - # Determine whether the default compiler is a.out or elf - eval $set_cc_for_build - sed 's/^ //' << EOF >$dummy.c - #include - #ifdef __ELF__ - # ifdef __GLIBC__ - # if __GLIBC__ >= 2 - LIBC=gnu - # else - LIBC=gnulibc1 - # endif - # else - LIBC=gnulibc1 - # endif - #else - #if defined(__INTEL_COMPILER) || defined(__PGI) || defined(__SUNPRO_C) || defined(__SUNPRO_CC) - LIBC=gnu - #else - LIBC=gnuaout - #endif - #endif - #ifdef __dietlibc__ - LIBC=dietlibc - #endif -EOF - eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n ' - /^LIBC/{ - s: ::g - p - }'`" - test x"${LIBC}" != x && { - echo "${UNAME_MACHINE}-pc-linux-${LIBC}" - exit - } - test x"${TENTATIVE}" != x && { echo "${TENTATIVE}"; exit; } - ;; - i*86:DYNIX/ptx:4*:*) - # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. - # earlier versions are messed up and put the nodename in both - # sysname and nodename. - echo i386-sequent-sysv4 - exit ;; - i*86:UNIX_SV:4.2MP:2.*) - # Unixware is an offshoot of SVR4, but it has its own version - # number series starting with 2... - # I am not positive that other SVR4 systems won't match this, - # I just have to hope. -- rms. - # Use sysv4.2uw... so that sysv4* matches it. - echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} - exit ;; - i*86:OS/2:*:*) - # If we were able to find `uname', then EMX Unix compatibility - # is probably installed. - echo ${UNAME_MACHINE}-pc-os2-emx - exit ;; - i*86:XTS-300:*:STOP) - echo ${UNAME_MACHINE}-unknown-stop - exit ;; - i*86:atheos:*:*) - echo ${UNAME_MACHINE}-unknown-atheos - exit ;; - i*86:syllable:*:*) - echo ${UNAME_MACHINE}-pc-syllable - exit ;; - i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*) - echo i386-unknown-lynxos${UNAME_RELEASE} - exit ;; - i*86:*DOS:*:*) - echo ${UNAME_MACHINE}-pc-msdosdjgpp - exit ;; - i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) - UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` - if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then - echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} - else - echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} - fi - exit ;; - i*86:*:5:[678]*) - # UnixWare 7.x, OpenUNIX and OpenServer 6. - case `/bin/uname -X | grep "^Machine"` in - *486*) UNAME_MACHINE=i486 ;; - *Pentium) UNAME_MACHINE=i586 ;; - *Pent*|*Celeron) UNAME_MACHINE=i686 ;; - esac - echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} - exit ;; - i*86:*:3.2:*) - if test -f /usr/options/cb.name; then - UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then - UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` - (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 - (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ - && UNAME_MACHINE=i586 - (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ - && UNAME_MACHINE=i686 - (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ - && UNAME_MACHINE=i686 - echo ${UNAME_MACHINE}-pc-sco$UNAME_REL - else - echo ${UNAME_MACHINE}-pc-sysv32 - fi - exit ;; - pc:*:*:*) - # Left here for compatibility: - # uname -m prints for DJGPP always 'pc', but it prints nothing about - # the processor, so we play safe by assuming i386. - echo i386-pc-msdosdjgpp - exit ;; - Intel:Mach:3*:*) - echo i386-pc-mach3 - exit ;; - paragon:*:*:*) - echo i860-intel-osf1 - exit ;; - i860:*:4.*:*) # i860-SVR4 - if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then - echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 - else # Add other i860-SVR4 vendors below as they are discovered. - echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 - fi - exit ;; - mini*:CTIX:SYS*5:*) - # "miniframe" - echo m68010-convergent-sysv - exit ;; - mc68k:UNIX:SYSTEM5:3.51m) - echo m68k-convergent-sysv - exit ;; - M680?0:D-NIX:5.3:*) - echo m68k-diab-dnix - exit ;; - M68*:*:R3V[5678]*:*) - test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; - 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) - OS_REL='' - test -r /etc/.relid \ - && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && { echo i486-ncr-sysv4.3${OS_REL}; exit; } - /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ - && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; - 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) - /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ - && { echo i486-ncr-sysv4; exit; } ;; - m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) - echo m68k-unknown-lynxos${UNAME_RELEASE} - exit ;; - mc68030:UNIX_System_V:4.*:*) - echo m68k-atari-sysv4 - exit ;; - TSUNAMI:LynxOS:2.*:*) - echo sparc-unknown-lynxos${UNAME_RELEASE} - exit ;; - rs6000:LynxOS:2.*:*) - echo rs6000-unknown-lynxos${UNAME_RELEASE} - exit ;; - PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*) - echo powerpc-unknown-lynxos${UNAME_RELEASE} - exit ;; - SM[BE]S:UNIX_SV:*:*) - echo mips-dde-sysv${UNAME_RELEASE} - exit ;; - RM*:ReliantUNIX-*:*:*) - echo mips-sni-sysv4 - exit ;; - RM*:SINIX-*:*:*) - echo mips-sni-sysv4 - exit ;; - *:SINIX-*:*:*) - if uname -p 2>/dev/null >/dev/null ; then - UNAME_MACHINE=`(uname -p) 2>/dev/null` - echo ${UNAME_MACHINE}-sni-sysv4 - else - echo ns32k-sni-sysv - fi - exit ;; - PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort - # says - echo i586-unisys-sysv4 - exit ;; - *:UNIX_System_V:4*:FTX*) - # From Gerald Hewes . - # How about differentiating between stratus architectures? -djm - echo hppa1.1-stratus-sysv4 - exit ;; - *:*:*:FTX*) - # From seanf@swdc.stratus.com. - echo i860-stratus-sysv4 - exit ;; - i*86:VOS:*:*) - # From Paul.Green@stratus.com. - echo ${UNAME_MACHINE}-stratus-vos - exit ;; - *:VOS:*:*) - # From Paul.Green@stratus.com. - echo hppa1.1-stratus-vos - exit ;; - mc68*:A/UX:*:*) - echo m68k-apple-aux${UNAME_RELEASE} - exit ;; - news*:NEWS-OS:6*:*) - echo mips-sony-newsos6 - exit ;; - R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) - if [ -d /usr/nec ]; then - echo mips-nec-sysv${UNAME_RELEASE} - else - echo mips-unknown-sysv${UNAME_RELEASE} - fi - exit ;; - BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. - echo powerpc-be-beos - exit ;; - BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. - echo powerpc-apple-beos - exit ;; - BePC:BeOS:*:*) # BeOS running on Intel PC compatible. - echo i586-pc-beos - exit ;; - SX-4:SUPER-UX:*:*) - echo sx4-nec-superux${UNAME_RELEASE} - exit ;; - SX-5:SUPER-UX:*:*) - echo sx5-nec-superux${UNAME_RELEASE} - exit ;; - SX-6:SUPER-UX:*:*) - echo sx6-nec-superux${UNAME_RELEASE} - exit ;; - Power*:Rhapsody:*:*) - echo powerpc-apple-rhapsody${UNAME_RELEASE} - exit ;; - *:Rhapsody:*:*) - echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} - exit ;; - *:Darwin:*:*) - UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown - case $UNAME_PROCESSOR in - unknown) UNAME_PROCESSOR=powerpc ;; - esac - echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} - exit ;; - *:procnto*:*:* | *:QNX:[0123456789]*:*) - UNAME_PROCESSOR=`uname -p` - if test "$UNAME_PROCESSOR" = "x86"; then - UNAME_PROCESSOR=i386 - UNAME_MACHINE=pc - fi - echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} - exit ;; - *:QNX:*:4*) - echo i386-pc-qnx - exit ;; - NSE-?:NONSTOP_KERNEL:*:*) - echo nse-tandem-nsk${UNAME_RELEASE} - exit ;; - NSR-?:NONSTOP_KERNEL:*:*) - echo nsr-tandem-nsk${UNAME_RELEASE} - exit ;; - *:NonStop-UX:*:*) - echo mips-compaq-nonstopux - exit ;; - BS2000:POSIX*:*:*) - echo bs2000-siemens-sysv - exit ;; - DS/*:UNIX_System_V:*:*) - echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} - exit ;; - *:Plan9:*:*) - # "uname -m" is not consistent, so use $cputype instead. 386 - # is converted to i386 for consistency with other x86 - # operating systems. - if test "$cputype" = "386"; then - UNAME_MACHINE=i386 - else - UNAME_MACHINE="$cputype" - fi - echo ${UNAME_MACHINE}-unknown-plan9 - exit ;; - *:TOPS-10:*:*) - echo pdp10-unknown-tops10 - exit ;; - *:TENEX:*:*) - echo pdp10-unknown-tenex - exit ;; - KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) - echo pdp10-dec-tops20 - exit ;; - XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) - echo pdp10-xkl-tops20 - exit ;; - *:TOPS-20:*:*) - echo pdp10-unknown-tops20 - exit ;; - *:ITS:*:*) - echo pdp10-unknown-its - exit ;; - SEI:*:*:SEIUX) - echo mips-sei-seiux${UNAME_RELEASE} - exit ;; - *:DragonFly:*:*) - echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` - exit ;; - *:*VMS:*:*) - UNAME_MACHINE=`(uname -p) 2>/dev/null` - case "${UNAME_MACHINE}" in - A*) echo alpha-dec-vms ; exit ;; - I*) echo ia64-dec-vms ; exit ;; - V*) echo vax-dec-vms ; exit ;; - esac ;; - *:XENIX:*:SysV) - echo i386-pc-xenix - exit ;; - i*86:skyos:*:*) - echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' - exit ;; - i*86:rdos:*:*) - echo ${UNAME_MACHINE}-pc-rdos - exit ;; -esac - -#echo '(No uname command or uname output not recognized.)' 1>&2 -#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 - -eval $set_cc_for_build -cat >$dummy.c < -# include -#endif -main () -{ -#if defined (sony) -#if defined (MIPSEB) - /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, - I don't know.... */ - printf ("mips-sony-bsd\n"); exit (0); -#else -#include - printf ("m68k-sony-newsos%s\n", -#ifdef NEWSOS4 - "4" -#else - "" -#endif - ); exit (0); -#endif -#endif - -#if defined (__arm) && defined (__acorn) && defined (__unix) - printf ("arm-acorn-riscix\n"); exit (0); -#endif - -#if defined (hp300) && !defined (hpux) - printf ("m68k-hp-bsd\n"); exit (0); -#endif - -#if defined (NeXT) -#if !defined (__ARCHITECTURE__) -#define __ARCHITECTURE__ "m68k" -#endif - int version; - version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; - if (version < 4) - printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); - else - printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); - exit (0); -#endif - -#if defined (MULTIMAX) || defined (n16) -#if defined (UMAXV) - printf ("ns32k-encore-sysv\n"); exit (0); -#else -#if defined (CMU) - printf ("ns32k-encore-mach\n"); exit (0); -#else - printf ("ns32k-encore-bsd\n"); exit (0); -#endif -#endif -#endif - -#if defined (__386BSD__) - printf ("i386-pc-bsd\n"); exit (0); -#endif - -#if defined (sequent) -#if defined (i386) - printf ("i386-sequent-dynix\n"); exit (0); -#endif -#if defined (ns32000) - printf ("ns32k-sequent-dynix\n"); exit (0); -#endif -#endif - -#if defined (_SEQUENT_) - struct utsname un; - - uname(&un); - - if (strncmp(un.version, "V2", 2) == 0) { - printf ("i386-sequent-ptx2\n"); exit (0); - } - if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ - printf ("i386-sequent-ptx1\n"); exit (0); - } - printf ("i386-sequent-ptx\n"); exit (0); - -#endif - -#if defined (vax) -# if !defined (ultrix) -# include -# if defined (BSD) -# if BSD == 43 - printf ("vax-dec-bsd4.3\n"); exit (0); -# else -# if BSD == 199006 - printf ("vax-dec-bsd4.3reno\n"); exit (0); -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# endif -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# else - printf ("vax-dec-ultrix\n"); exit (0); -# endif -#endif - -#if defined (alliant) && defined (i860) - printf ("i860-alliant-bsd\n"); exit (0); -#endif - - exit (1); -} -EOF - -$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` && - { echo "$SYSTEM_NAME"; exit; } - -# Apollos put the system type in the environment. - -test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } - -# Convex versions that predate uname can use getsysinfo(1) - -if [ -x /usr/convex/getsysinfo ] -then - case `getsysinfo -f cpu_type` in - c1*) - echo c1-convex-bsd - exit ;; - c2*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit ;; - c34*) - echo c34-convex-bsd - exit ;; - c38*) - echo c38-convex-bsd - exit ;; - c4*) - echo c4-convex-bsd - exit ;; - esac -fi - -cat >&2 < in order to provide the needed -information to handle your system. - -config.guess timestamp = $timestamp - -uname -m = `(uname -m) 2>/dev/null || echo unknown` -uname -r = `(uname -r) 2>/dev/null || echo unknown` -uname -s = `(uname -s) 2>/dev/null || echo unknown` -uname -v = `(uname -v) 2>/dev/null || echo unknown` - -/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` -/bin/uname -X = `(/bin/uname -X) 2>/dev/null` - -hostinfo = `(hostinfo) 2>/dev/null` -/bin/universe = `(/bin/universe) 2>/dev/null` -/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` -/bin/arch = `(/bin/arch) 2>/dev/null` -/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` -/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` - -UNAME_MACHINE = ${UNAME_MACHINE} -UNAME_RELEASE = ${UNAME_RELEASE} -UNAME_SYSTEM = ${UNAME_SYSTEM} -UNAME_VERSION = ${UNAME_VERSION} -EOF - -exit 1 - -# Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "timestamp='" -# time-stamp-format: "%:y-%02m-%02d" -# time-stamp-end: "'" -# End: diff --git a/src/config.mk.in b/src/config.mk.in deleted file mode 100644 index e8a8ab567..000000000 --- a/src/config.mk.in +++ /dev/null @@ -1,37 +0,0 @@ -# GF configuration file. configure will produce config.mk from this file -# @configure_input@ - -PACKAGE_VERSION = @PACKAGE_VERSION@ - -prefix = @prefix@ -exec_prefix = @exec_prefix@ -bindir = @bindir@ -libdir = @libdir@ -datadir = @datadir@ - -host = @host@ -build = @build@ - -GHCFLAGS = @GHCFLAGS@ -CPPFLAGS = @CPPFLAGS@ -LDFLAGS = @LDFLAGS@ - -EXEEXT = @EXEEXT@ - -INSTALL = @INSTALL@ -TAR = @TAR@ - -GHC = "@GHC@" -GHCI = "@GHCI@" - -READLINE = @READLINE@ - -INTERRUPT = @INTERRUPT@ - -ATK = @ATK@ - -ENABLE_JAVA = @ENABLE_JAVA@ - -JAVAC = "@JAVAC@" -JAR = "@JAR@" - diff --git a/src/config.sub b/src/config.sub deleted file mode 100644 index 4d936e239..000000000 --- a/src/config.sub +++ /dev/null @@ -1,1608 +0,0 @@ -#! /bin/sh -# Configuration validation subroutine script. -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, -# 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, -# Inc. - -timestamp='2006-05-13' - -# This file is (in principle) common to ALL GNU software. -# The presence of a machine in this file suggests that SOME GNU software -# can handle that machine. It does not imply ALL GNU software can. -# -# This file is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA -# 02110-1301, USA. -# -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that program. - - -# Please send patches to . Submit a context -# diff and a properly formatted ChangeLog entry. -# -# Configuration subroutine to validate and canonicalize a configuration type. -# Supply the specified configuration type as an argument. -# If it is invalid, we print an error message on stderr and exit with code 1. -# Otherwise, we print the canonical config type on stdout and succeed. - -# This file is supposed to be the same for all GNU packages -# and recognize all the CPU types, system types and aliases -# that are meaningful with *any* GNU software. -# Each package is responsible for reporting which valid configurations -# it does not support. The user should be able to distinguish -# a failure to support a valid configuration from a meaningless -# configuration. - -# The goal of this file is to map all the various variations of a given -# machine specification into a single specification in the form: -# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM -# or in some cases, the newer four-part form: -# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM -# It is wrong to echo any other type of specification. - -me=`echo "$0" | sed -e 's,.*/,,'` - -usage="\ -Usage: $0 [OPTION] CPU-MFR-OPSYS - $0 [OPTION] ALIAS - -Canonicalize a configuration name. - -Operation modes: - -h, --help print this help, then exit - -t, --time-stamp print date of last modification, then exit - -v, --version print version number, then exit - -Report bugs and patches to ." - -version="\ -GNU config.sub ($timestamp) - -Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 -Free Software Foundation, Inc. - -This is free software; see the source for copying conditions. There is NO -warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." - -help=" -Try \`$me --help' for more information." - -# Parse command line -while test $# -gt 0 ; do - case $1 in - --time-stamp | --time* | -t ) - echo "$timestamp" ; exit ;; - --version | -v ) - echo "$version" ; exit ;; - --help | --h* | -h ) - echo "$usage"; exit ;; - -- ) # Stop option processing - shift; break ;; - - ) # Use stdin as input. - break ;; - -* ) - echo "$me: invalid option $1$help" - exit 1 ;; - - *local*) - # First pass through any local machine types. - echo $1 - exit ;; - - * ) - break ;; - esac -done - -case $# in - 0) echo "$me: missing argument$help" >&2 - exit 1;; - 1) ;; - *) echo "$me: too many arguments$help" >&2 - exit 1;; -esac - -# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). -# Here we must recognize all the valid KERNEL-OS combinations. -maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` -case $maybe_os in - nto-qnx* | linux-gnu* | linux-dietlibc | linux-newlib* | linux-uclibc* | \ - uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* | \ - storm-chaos* | os2-emx* | rtmk-nova*) - os=-$maybe_os - basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` - ;; - *) - basic_machine=`echo $1 | sed 's/-[^-]*$//'` - if [ $basic_machine != $1 ] - then os=`echo $1 | sed 's/.*-/-/'` - else os=; fi - ;; -esac - -### Let's recognize common machines as not being operating systems so -### that things like config.sub decstation-3100 work. We also -### recognize some manufacturers as not being operating systems, so we -### can provide default operating systems below. -case $os in - -sun*os*) - # Prevent following clause from handling this invalid input. - ;; - -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ - -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ - -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ - -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ - -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ - -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ - -apple | -axis | -knuth | -cray) - os= - basic_machine=$1 - ;; - -sim | -cisco | -oki | -wec | -winbond) - os= - basic_machine=$1 - ;; - -scout) - ;; - -wrs) - os=-vxworks - basic_machine=$1 - ;; - -chorusos*) - os=-chorusos - basic_machine=$1 - ;; - -chorusrdb) - os=-chorusrdb - basic_machine=$1 - ;; - -hiux*) - os=-hiuxwe2 - ;; - -sco6) - os=-sco5v6 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco5) - os=-sco3.2v5 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco4) - os=-sco3.2v4 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco3.2.[4-9]*) - os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco3.2v[4-9]*) - # Don't forget version if it is 3.2v4 or newer. - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco5v6*) - # Don't forget version if it is 3.2v4 or newer. - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -sco*) - os=-sco3.2v2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -udk*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -isc) - os=-isc2.2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -clix*) - basic_machine=clipper-intergraph - ;; - -isc*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` - ;; - -lynx*) - os=-lynxos - ;; - -ptx*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` - ;; - -windowsnt*) - os=`echo $os | sed -e 's/windowsnt/winnt/'` - ;; - -psos*) - os=-psos - ;; - -mint | -mint[0-9]*) - basic_machine=m68k-atari - os=-mint - ;; -esac - -# Decode aliases for certain CPU-COMPANY combinations. -case $basic_machine in - # Recognize the basic CPU types without company name. - # Some are omitted here because they have special meanings below. - 1750a | 580 \ - | a29k \ - | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ - | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ - | am33_2.0 \ - | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr \ - | bfin \ - | c4x | clipper \ - | d10v | d30v | dlx | dsp16xx \ - | fr30 | frv \ - | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ - | i370 | i860 | i960 | ia64 \ - | ip2k | iq2000 \ - | m32c | m32r | m32rle | m68000 | m68k | m88k \ - | maxq | mb | microblaze | mcore \ - | mips | mipsbe | mipseb | mipsel | mipsle \ - | mips16 \ - | mips64 | mips64el \ - | mips64vr | mips64vrel \ - | mips64orion | mips64orionel \ - | mips64vr4100 | mips64vr4100el \ - | mips64vr4300 | mips64vr4300el \ - | mips64vr5000 | mips64vr5000el \ - | mips64vr5900 | mips64vr5900el \ - | mipsisa32 | mipsisa32el \ - | mipsisa32r2 | mipsisa32r2el \ - | mipsisa64 | mipsisa64el \ - | mipsisa64r2 | mipsisa64r2el \ - | mipsisa64sb1 | mipsisa64sb1el \ - | mipsisa64sr71k | mipsisa64sr71kel \ - | mipstx39 | mipstx39el \ - | mn10200 | mn10300 \ - | mt \ - | msp430 \ - | nios | nios2 \ - | ns16k | ns32k \ - | or32 \ - | pdp10 | pdp11 | pj | pjl \ - | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \ - | pyramid \ - | sh | sh[1234] | sh[24]a | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ - | sh64 | sh64le \ - | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ - | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ - | spu | strongarm \ - | tahoe | thumb | tic4x | tic80 | tron \ - | v850 | v850e \ - | we32k \ - | x86 | xscale | xscalee[bl] | xstormy16 | xtensa \ - | z8k) - basic_machine=$basic_machine-unknown - ;; - m6811 | m68hc11 | m6812 | m68hc12) - # Motorola 68HC11/12. - basic_machine=$basic_machine-unknown - os=-none - ;; - m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) - ;; - ms1) - basic_machine=mt-unknown - ;; - - # We use `pc' rather than `unknown' - # because (1) that's what they normally are, and - # (2) the word "unknown" tends to confuse beginning users. - i*86 | x86_64) - basic_machine=$basic_machine-pc - ;; - # Object if more than one company name word. - *-*-*) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; - # Recognize the basic CPU types with company name. - 580-* \ - | a29k-* \ - | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ - | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ - | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ - | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ - | avr-* \ - | bfin-* | bs2000-* \ - | c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* | c55x-* | c6x-* \ - | clipper-* | craynv-* | cydra-* \ - | d10v-* | d30v-* | dlx-* \ - | elxsi-* \ - | f30[01]-* | f700-* | fr30-* | frv-* | fx80-* \ - | h8300-* | h8500-* \ - | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ - | i*86-* | i860-* | i960-* | ia64-* \ - | ip2k-* | iq2000-* \ - | m32c-* | m32r-* | m32rle-* \ - | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ - | m88110-* | m88k-* | maxq-* | mcore-* \ - | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ - | mips16-* \ - | mips64-* | mips64el-* \ - | mips64vr-* | mips64vrel-* \ - | mips64orion-* | mips64orionel-* \ - | mips64vr4100-* | mips64vr4100el-* \ - | mips64vr4300-* | mips64vr4300el-* \ - | mips64vr5000-* | mips64vr5000el-* \ - | mips64vr5900-* | mips64vr5900el-* \ - | mipsisa32-* | mipsisa32el-* \ - | mipsisa32r2-* | mipsisa32r2el-* \ - | mipsisa64-* | mipsisa64el-* \ - | mipsisa64r2-* | mipsisa64r2el-* \ - | mipsisa64sb1-* | mipsisa64sb1el-* \ - | mipsisa64sr71k-* | mipsisa64sr71kel-* \ - | mipstx39-* | mipstx39el-* \ - | mmix-* \ - | mt-* \ - | msp430-* \ - | nios-* | nios2-* \ - | none-* | np1-* | ns16k-* | ns32k-* \ - | orion-* \ - | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ - | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \ - | pyramid-* \ - | romp-* | rs6000-* \ - | sh-* | sh[1234]-* | sh[24]a-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ - | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ - | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ - | sparclite-* \ - | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | strongarm-* | sv1-* | sx?-* \ - | tahoe-* | thumb-* \ - | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ - | tron-* \ - | v850-* | v850e-* | vax-* \ - | we32k-* \ - | x86-* | x86_64-* | xps100-* | xscale-* | xscalee[bl]-* \ - | xstormy16-* | xtensa-* \ - | ymp-* \ - | z8k-*) - ;; - # Recognize the various machine names and aliases which stand - # for a CPU type and a company and sometimes even an OS. - 386bsd) - basic_machine=i386-unknown - os=-bsd - ;; - 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) - basic_machine=m68000-att - ;; - 3b*) - basic_machine=we32k-att - ;; - a29khif) - basic_machine=a29k-amd - os=-udi - ;; - abacus) - basic_machine=abacus-unknown - ;; - adobe68k) - basic_machine=m68010-adobe - os=-scout - ;; - alliant | fx80) - basic_machine=fx80-alliant - ;; - altos | altos3068) - basic_machine=m68k-altos - ;; - am29k) - basic_machine=a29k-none - os=-bsd - ;; - amd64) - basic_machine=x86_64-pc - ;; - amd64-*) - basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - amdahl) - basic_machine=580-amdahl - os=-sysv - ;; - amiga | amiga-*) - basic_machine=m68k-unknown - ;; - amigaos | amigados) - basic_machine=m68k-unknown - os=-amigaos - ;; - amigaunix | amix) - basic_machine=m68k-unknown - os=-sysv4 - ;; - apollo68) - basic_machine=m68k-apollo - os=-sysv - ;; - apollo68bsd) - basic_machine=m68k-apollo - os=-bsd - ;; - aux) - basic_machine=m68k-apple - os=-aux - ;; - balance) - basic_machine=ns32k-sequent - os=-dynix - ;; - c90) - basic_machine=c90-cray - os=-unicos - ;; - convex-c1) - basic_machine=c1-convex - os=-bsd - ;; - convex-c2) - basic_machine=c2-convex - os=-bsd - ;; - convex-c32) - basic_machine=c32-convex - os=-bsd - ;; - convex-c34) - basic_machine=c34-convex - os=-bsd - ;; - convex-c38) - basic_machine=c38-convex - os=-bsd - ;; - cray | j90) - basic_machine=j90-cray - os=-unicos - ;; - craynv) - basic_machine=craynv-cray - os=-unicosmp - ;; - cr16c) - basic_machine=cr16c-unknown - os=-elf - ;; - crds | unos) - basic_machine=m68k-crds - ;; - crisv32 | crisv32-* | etraxfs*) - basic_machine=crisv32-axis - ;; - cris | cris-* | etrax*) - basic_machine=cris-axis - ;; - crx) - basic_machine=crx-unknown - os=-elf - ;; - da30 | da30-*) - basic_machine=m68k-da30 - ;; - decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) - basic_machine=mips-dec - ;; - decsystem10* | dec10*) - basic_machine=pdp10-dec - os=-tops10 - ;; - decsystem20* | dec20*) - basic_machine=pdp10-dec - os=-tops20 - ;; - delta | 3300 | motorola-3300 | motorola-delta \ - | 3300-motorola | delta-motorola) - basic_machine=m68k-motorola - ;; - delta88) - basic_machine=m88k-motorola - os=-sysv3 - ;; - djgpp) - basic_machine=i586-pc - os=-msdosdjgpp - ;; - dpx20 | dpx20-*) - basic_machine=rs6000-bull - os=-bosx - ;; - dpx2* | dpx2*-bull) - basic_machine=m68k-bull - os=-sysv3 - ;; - ebmon29k) - basic_machine=a29k-amd - os=-ebmon - ;; - elxsi) - basic_machine=elxsi-elxsi - os=-bsd - ;; - encore | umax | mmax) - basic_machine=ns32k-encore - ;; - es1800 | OSE68k | ose68k | ose | OSE) - basic_machine=m68k-ericsson - os=-ose - ;; - fx2800) - basic_machine=i860-alliant - ;; - genix) - basic_machine=ns32k-ns - ;; - gmicro) - basic_machine=tron-gmicro - os=-sysv - ;; - go32) - basic_machine=i386-pc - os=-go32 - ;; - h3050r* | hiux*) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - h8300hms) - basic_machine=h8300-hitachi - os=-hms - ;; - h8300xray) - basic_machine=h8300-hitachi - os=-xray - ;; - h8500hms) - basic_machine=h8500-hitachi - os=-hms - ;; - harris) - basic_machine=m88k-harris - os=-sysv3 - ;; - hp300-*) - basic_machine=m68k-hp - ;; - hp300bsd) - basic_machine=m68k-hp - os=-bsd - ;; - hp300hpux) - basic_machine=m68k-hp - os=-hpux - ;; - hp3k9[0-9][0-9] | hp9[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hp9k2[0-9][0-9] | hp9k31[0-9]) - basic_machine=m68000-hp - ;; - hp9k3[2-9][0-9]) - basic_machine=m68k-hp - ;; - hp9k6[0-9][0-9] | hp6[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hp9k7[0-79][0-9] | hp7[0-79][0-9]) - basic_machine=hppa1.1-hp - ;; - hp9k78[0-9] | hp78[0-9]) - # FIXME: really hppa2.0-hp - basic_machine=hppa1.1-hp - ;; - hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) - # FIXME: really hppa2.0-hp - basic_machine=hppa1.1-hp - ;; - hp9k8[0-9][13679] | hp8[0-9][13679]) - basic_machine=hppa1.1-hp - ;; - hp9k8[0-9][0-9] | hp8[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - hppa-next) - os=-nextstep3 - ;; - hppaosf) - basic_machine=hppa1.1-hp - os=-osf - ;; - hppro) - basic_machine=hppa1.1-hp - os=-proelf - ;; - i370-ibm* | ibm*) - basic_machine=i370-ibm - ;; -# I'm not sure what "Sysv32" means. Should this be sysv3.2? - i*86v32) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv32 - ;; - i*86v4*) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv4 - ;; - i*86v) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-sysv - ;; - i*86sol2) - basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` - os=-solaris2 - ;; - i386mach) - basic_machine=i386-mach - os=-mach - ;; - i386-vsta | vsta) - basic_machine=i386-unknown - os=-vsta - ;; - iris | iris4d) - basic_machine=mips-sgi - case $os in - -irix*) - ;; - *) - os=-irix4 - ;; - esac - ;; - isi68 | isi) - basic_machine=m68k-isi - os=-sysv - ;; - m88k-omron*) - basic_machine=m88k-omron - ;; - magnum | m3230) - basic_machine=mips-mips - os=-sysv - ;; - merlin) - basic_machine=ns32k-utek - os=-sysv - ;; - mingw32) - basic_machine=i386-pc - os=-mingw32 - ;; - miniframe) - basic_machine=m68000-convergent - ;; - *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) - basic_machine=m68k-atari - os=-mint - ;; - mips3*-*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` - ;; - mips3*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown - ;; - monitor) - basic_machine=m68k-rom68k - os=-coff - ;; - morphos) - basic_machine=powerpc-unknown - os=-morphos - ;; - msdos) - basic_machine=i386-pc - os=-msdos - ;; - ms1-*) - basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` - ;; - mvs) - basic_machine=i370-ibm - os=-mvs - ;; - ncr3000) - basic_machine=i486-ncr - os=-sysv4 - ;; - netbsd386) - basic_machine=i386-unknown - os=-netbsd - ;; - netwinder) - basic_machine=armv4l-rebel - os=-linux - ;; - news | news700 | news800 | news900) - basic_machine=m68k-sony - os=-newsos - ;; - news1000) - basic_machine=m68030-sony - os=-newsos - ;; - news-3600 | risc-news) - basic_machine=mips-sony - os=-newsos - ;; - necv70) - basic_machine=v70-nec - os=-sysv - ;; - next | m*-next ) - basic_machine=m68k-next - case $os in - -nextstep* ) - ;; - -ns2*) - os=-nextstep2 - ;; - *) - os=-nextstep3 - ;; - esac - ;; - nh3000) - basic_machine=m68k-harris - os=-cxux - ;; - nh[45]000) - basic_machine=m88k-harris - os=-cxux - ;; - nindy960) - basic_machine=i960-intel - os=-nindy - ;; - mon960) - basic_machine=i960-intel - os=-mon960 - ;; - nonstopux) - basic_machine=mips-compaq - os=-nonstopux - ;; - np1) - basic_machine=np1-gould - ;; - nsr-tandem) - basic_machine=nsr-tandem - ;; - op50n-* | op60c-*) - basic_machine=hppa1.1-oki - os=-proelf - ;; - openrisc | openrisc-*) - basic_machine=or32-unknown - ;; - os400) - basic_machine=powerpc-ibm - os=-os400 - ;; - OSE68000 | ose68000) - basic_machine=m68000-ericsson - os=-ose - ;; - os68k) - basic_machine=m68k-none - os=-os68k - ;; - pa-hitachi) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - paragon) - basic_machine=i860-intel - os=-osf - ;; - pbd) - basic_machine=sparc-tti - ;; - pbb) - basic_machine=m68k-tti - ;; - pc532 | pc532-*) - basic_machine=ns32k-pc532 - ;; - pc98) - basic_machine=i386-pc - ;; - pc98-*) - basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentium | p5 | k5 | k6 | nexgen | viac3) - basic_machine=i586-pc - ;; - pentiumpro | p6 | 6x86 | athlon | athlon_*) - basic_machine=i686-pc - ;; - pentiumii | pentium2 | pentiumiii | pentium3) - basic_machine=i686-pc - ;; - pentium4) - basic_machine=i786-pc - ;; - pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) - basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentiumpro-* | p6-* | 6x86-* | athlon-*) - basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) - basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pentium4-*) - basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pn) - basic_machine=pn-gould - ;; - power) basic_machine=power-ibm - ;; - ppc) basic_machine=powerpc-unknown - ;; - ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppcle | powerpclittle | ppc-le | powerpc-little) - basic_machine=powerpcle-unknown - ;; - ppcle-* | powerpclittle-*) - basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppc64) basic_machine=powerpc64-unknown - ;; - ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ppc64le | powerpc64little | ppc64-le | powerpc64-little) - basic_machine=powerpc64le-unknown - ;; - ppc64le-* | powerpc64little-*) - basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - ps2) - basic_machine=i386-ibm - ;; - pw32) - basic_machine=i586-unknown - os=-pw32 - ;; - rdos) - basic_machine=i386-pc - os=-rdos - ;; - rom68k) - basic_machine=m68k-rom68k - os=-coff - ;; - rm[46]00) - basic_machine=mips-siemens - ;; - rtpc | rtpc-*) - basic_machine=romp-ibm - ;; - s390 | s390-*) - basic_machine=s390-ibm - ;; - s390x | s390x-*) - basic_machine=s390x-ibm - ;; - sa29200) - basic_machine=a29k-amd - os=-udi - ;; - sb1) - basic_machine=mipsisa64sb1-unknown - ;; - sb1el) - basic_machine=mipsisa64sb1el-unknown - ;; - sei) - basic_machine=mips-sei - os=-seiux - ;; - sequent) - basic_machine=i386-sequent - ;; - sh) - basic_machine=sh-hitachi - os=-hms - ;; - sh64) - basic_machine=sh64-unknown - ;; - sparclite-wrs | simso-wrs) - basic_machine=sparclite-wrs - os=-vxworks - ;; - sps7) - basic_machine=m68k-bull - os=-sysv2 - ;; - spur) - basic_machine=spur-unknown - ;; - st2000) - basic_machine=m68k-tandem - ;; - stratus) - basic_machine=i860-stratus - os=-sysv4 - ;; - sun2) - basic_machine=m68000-sun - ;; - sun2os3) - basic_machine=m68000-sun - os=-sunos3 - ;; - sun2os4) - basic_machine=m68000-sun - os=-sunos4 - ;; - sun3os3) - basic_machine=m68k-sun - os=-sunos3 - ;; - sun3os4) - basic_machine=m68k-sun - os=-sunos4 - ;; - sun4os3) - basic_machine=sparc-sun - os=-sunos3 - ;; - sun4os4) - basic_machine=sparc-sun - os=-sunos4 - ;; - sun4sol2) - basic_machine=sparc-sun - os=-solaris2 - ;; - sun3 | sun3-*) - basic_machine=m68k-sun - ;; - sun4) - basic_machine=sparc-sun - ;; - sun386 | sun386i | roadrunner) - basic_machine=i386-sun - ;; - sv1) - basic_machine=sv1-cray - os=-unicos - ;; - symmetry) - basic_machine=i386-sequent - os=-dynix - ;; - t3e) - basic_machine=alphaev5-cray - os=-unicos - ;; - t90) - basic_machine=t90-cray - os=-unicos - ;; - tic54x | c54x*) - basic_machine=tic54x-unknown - os=-coff - ;; - tic55x | c55x*) - basic_machine=tic55x-unknown - os=-coff - ;; - tic6x | c6x*) - basic_machine=tic6x-unknown - os=-coff - ;; - tx39) - basic_machine=mipstx39-unknown - ;; - tx39el) - basic_machine=mipstx39el-unknown - ;; - toad1) - basic_machine=pdp10-xkl - os=-tops20 - ;; - tower | tower-32) - basic_machine=m68k-ncr - ;; - tpf) - basic_machine=s390x-ibm - os=-tpf - ;; - udi29k) - basic_machine=a29k-amd - os=-udi - ;; - ultra3) - basic_machine=a29k-nyu - os=-sym1 - ;; - v810 | necv810) - basic_machine=v810-nec - os=-none - ;; - vaxv) - basic_machine=vax-dec - os=-sysv - ;; - vms) - basic_machine=vax-dec - os=-vms - ;; - vpp*|vx|vx-*) - basic_machine=f301-fujitsu - ;; - vxworks960) - basic_machine=i960-wrs - os=-vxworks - ;; - vxworks68) - basic_machine=m68k-wrs - os=-vxworks - ;; - vxworks29k) - basic_machine=a29k-wrs - os=-vxworks - ;; - w65*) - basic_machine=w65-wdc - os=-none - ;; - w89k-*) - basic_machine=hppa1.1-winbond - os=-proelf - ;; - xbox) - basic_machine=i686-pc - os=-mingw32 - ;; - xps | xps100) - basic_machine=xps100-honeywell - ;; - ymp) - basic_machine=ymp-cray - os=-unicos - ;; - z8k-*-coff) - basic_machine=z8k-unknown - os=-sim - ;; - none) - basic_machine=none-none - os=-none - ;; - -# Here we handle the default manufacturer of certain CPU types. It is in -# some cases the only manufacturer, in others, it is the most popular. - w89k) - basic_machine=hppa1.1-winbond - ;; - op50n) - basic_machine=hppa1.1-oki - ;; - op60c) - basic_machine=hppa1.1-oki - ;; - romp) - basic_machine=romp-ibm - ;; - mmix) - basic_machine=mmix-knuth - ;; - rs6000) - basic_machine=rs6000-ibm - ;; - vax) - basic_machine=vax-dec - ;; - pdp10) - # there are many clones, so DEC is not a safe bet - basic_machine=pdp10-unknown - ;; - pdp11) - basic_machine=pdp11-dec - ;; - we32k) - basic_machine=we32k-att - ;; - sh[1234] | sh[24]a | sh[34]eb | sh[1234]le | sh[23]ele) - basic_machine=sh-unknown - ;; - sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v) - basic_machine=sparc-sun - ;; - cydra) - basic_machine=cydra-cydrome - ;; - orion) - basic_machine=orion-highlevel - ;; - orion105) - basic_machine=clipper-highlevel - ;; - mac | mpw | mac-mpw) - basic_machine=m68k-apple - ;; - pmac | pmac-mpw) - basic_machine=powerpc-apple - ;; - *-unknown) - # Make sure to match an already-canonicalized machine name. - ;; - *) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; -esac - -# Here we canonicalize certain aliases for manufacturers. -case $basic_machine in - *-digital*) - basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` - ;; - *-commodore*) - basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` - ;; - *) - ;; -esac - -# Decode manufacturer-specific aliases for certain operating systems. - -if [ x"$os" != x"" ] -then -case $os in - # First match some system type aliases - # that might get confused with valid system types. - # -solaris* is a basic system type, with this one exception. - -solaris1 | -solaris1.*) - os=`echo $os | sed -e 's|solaris1|sunos4|'` - ;; - -solaris) - os=-solaris2 - ;; - -svr4*) - os=-sysv4 - ;; - -unixware*) - os=-sysv4.2uw - ;; - -gnu/linux*) - os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` - ;; - # First accept the basic system types. - # The portable systems comes first. - # Each alternative MUST END IN A *, to match a version number. - # -sysv* is not here because it comes later, after sysvr4. - -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ - | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\ - | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ - | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ - | -aos* \ - | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ - | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ - | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ - | -openbsd* | -solidbsd* \ - | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ - | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ - | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ - | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ - | -chorusos* | -chorusrdb* \ - | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ - | -mingw32* | -linux-gnu* | -linux-newlib* | -linux-uclibc* \ - | -uxpv* | -beos* | -mpeix* | -udk* \ - | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ - | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ - | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ - | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ - | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ - | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ - | -skyos* | -haiku* | -rdos*) - # Remember, each alternative MUST END IN *, to match a version number. - ;; - -qnx*) - case $basic_machine in - x86-* | i*86-*) - ;; - *) - os=-nto$os - ;; - esac - ;; - -nto-qnx*) - ;; - -nto*) - os=`echo $os | sed -e 's|nto|nto-qnx|'` - ;; - -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ - | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \ - | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) - ;; - -mac*) - os=`echo $os | sed -e 's|mac|macos|'` - ;; - -linux-dietlibc) - os=-linux-dietlibc - ;; - -linux*) - os=`echo $os | sed -e 's|linux|linux-gnu|'` - ;; - -sunos5*) - os=`echo $os | sed -e 's|sunos5|solaris2|'` - ;; - -sunos6*) - os=`echo $os | sed -e 's|sunos6|solaris3|'` - ;; - -opened*) - os=-openedition - ;; - -os400*) - os=-os400 - ;; - -wince*) - os=-wince - ;; - -osfrose*) - os=-osfrose - ;; - -osf*) - os=-osf - ;; - -utek*) - os=-bsd - ;; - -dynix*) - os=-bsd - ;; - -acis*) - os=-aos - ;; - -atheos*) - os=-atheos - ;; - -syllable*) - os=-syllable - ;; - -386bsd) - os=-bsd - ;; - -ctix* | -uts*) - os=-sysv - ;; - -nova*) - os=-rtmk-nova - ;; - -ns2 ) - os=-nextstep2 - ;; - -nsk*) - os=-nsk - ;; - # Preserve the version number of sinix5. - -sinix5.*) - os=`echo $os | sed -e 's|sinix|sysv|'` - ;; - -sinix*) - os=-sysv4 - ;; - -tpf*) - os=-tpf - ;; - -triton*) - os=-sysv3 - ;; - -oss*) - os=-sysv3 - ;; - -svr4) - os=-sysv4 - ;; - -svr3) - os=-sysv3 - ;; - -sysvr4) - os=-sysv4 - ;; - # This must come after -sysvr4. - -sysv*) - ;; - -ose*) - os=-ose - ;; - -es1800*) - os=-ose - ;; - -xenix) - os=-xenix - ;; - -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) - os=-mint - ;; - -aros*) - os=-aros - ;; - -kaos*) - os=-kaos - ;; - -zvmoe) - os=-zvmoe - ;; - -none) - ;; - *) - # Get rid of the `-' at the beginning of $os. - os=`echo $os | sed 's/[^-]*-//'` - echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 - exit 1 - ;; -esac -else - -# Here we handle the default operating systems that come with various machines. -# The value should be what the vendor currently ships out the door with their -# machine or put another way, the most popular os provided with the machine. - -# Note that if you're going to try to match "-MANUFACTURER" here (say, -# "-sun"), then you have to tell the case statement up towards the top -# that MANUFACTURER isn't an operating system. Otherwise, code above -# will signal an error saying that MANUFACTURER isn't an operating -# system, and we'll never get to this point. - -case $basic_machine in - spu-*) - os=-elf - ;; - *-acorn) - os=-riscix1.2 - ;; - arm*-rebel) - os=-linux - ;; - arm*-semi) - os=-aout - ;; - c4x-* | tic4x-*) - os=-coff - ;; - # This must come before the *-dec entry. - pdp10-*) - os=-tops20 - ;; - pdp11-*) - os=-none - ;; - *-dec | vax-*) - os=-ultrix4.2 - ;; - m68*-apollo) - os=-domain - ;; - i386-sun) - os=-sunos4.0.2 - ;; - m68000-sun) - os=-sunos3 - # This also exists in the configure program, but was not the - # default. - # os=-sunos4 - ;; - m68*-cisco) - os=-aout - ;; - mips*-cisco) - os=-elf - ;; - mips*-*) - os=-elf - ;; - or32-*) - os=-coff - ;; - *-tti) # must be before sparc entry or we get the wrong os. - os=-sysv3 - ;; - sparc-* | *-sun) - os=-sunos4.1.1 - ;; - *-be) - os=-beos - ;; - *-haiku) - os=-haiku - ;; - *-ibm) - os=-aix - ;; - *-knuth) - os=-mmixware - ;; - *-wec) - os=-proelf - ;; - *-winbond) - os=-proelf - ;; - *-oki) - os=-proelf - ;; - *-hp) - os=-hpux - ;; - *-hitachi) - os=-hiux - ;; - i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) - os=-sysv - ;; - *-cbm) - os=-amigaos - ;; - *-dg) - os=-dgux - ;; - *-dolphin) - os=-sysv3 - ;; - m68k-ccur) - os=-rtu - ;; - m88k-omron*) - os=-luna - ;; - *-next ) - os=-nextstep - ;; - *-sequent) - os=-ptx - ;; - *-crds) - os=-unos - ;; - *-ns) - os=-genix - ;; - i370-*) - os=-mvs - ;; - *-next) - os=-nextstep3 - ;; - *-gould) - os=-sysv - ;; - *-highlevel) - os=-bsd - ;; - *-encore) - os=-bsd - ;; - *-sgi) - os=-irix - ;; - *-siemens) - os=-sysv4 - ;; - *-masscomp) - os=-rtu - ;; - f30[01]-fujitsu | f700-fujitsu) - os=-uxpv - ;; - *-rom68k) - os=-coff - ;; - *-*bug) - os=-coff - ;; - *-apple) - os=-macos - ;; - *-atari*) - os=-mint - ;; - *) - os=-none - ;; -esac -fi - -# Here we handle the case where we know the os, and the CPU type, but not the -# manufacturer. We pick the logical manufacturer. -vendor=unknown -case $basic_machine in - *-unknown) - case $os in - -riscix*) - vendor=acorn - ;; - -sunos*) - vendor=sun - ;; - -aix*) - vendor=ibm - ;; - -beos*) - vendor=be - ;; - -hpux*) - vendor=hp - ;; - -mpeix*) - vendor=hp - ;; - -hiux*) - vendor=hitachi - ;; - -unos*) - vendor=crds - ;; - -dgux*) - vendor=dg - ;; - -luna*) - vendor=omron - ;; - -genix*) - vendor=ns - ;; - -mvs* | -opened*) - vendor=ibm - ;; - -os400*) - vendor=ibm - ;; - -ptx*) - vendor=sequent - ;; - -tpf*) - vendor=ibm - ;; - -vxsim* | -vxworks* | -windiss*) - vendor=wrs - ;; - -aux*) - vendor=apple - ;; - -hms*) - vendor=hitachi - ;; - -mpw* | -macos*) - vendor=apple - ;; - -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) - vendor=atari - ;; - -vos*) - vendor=stratus - ;; - esac - basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` - ;; -esac - -echo $basic_machine$os -exit - -# Local variables: -# eval: (add-hook 'write-file-hooks 'time-stamp) -# time-stamp-start: "timestamp='" -# time-stamp-format: "%:y-%02m-%02d" -# time-stamp-end: "'" -# End: diff --git a/src/configure.ac b/src/configure.ac deleted file mode 100644 index c38acbff5..000000000 --- a/src/configure.ac +++ /dev/null @@ -1,229 +0,0 @@ -dnl Run autoconf to generate configure from this file - -AC_INIT([GF],[3.0-beta3],[aarne@cs.chalmers.se],[GF]) - -AC_PREREQ(2.53) - -AC_REVISION($Revision: 1.26 $) - -AC_CONFIG_FILES([config.mk gfc]) - -AC_CANONICAL_HOST - -dnl *********************************************** -dnl Executable suffix -dnl *********************************************** - - -AC_MSG_CHECKING([executable suffix]) -case $host_os in - cygwin) - EXEEXT='.exe';; - *) - EXEEXT='';; -esac -AC_MSG_RESULT(['$EXEEXT']) -AC_SUBST(EXEEXT) - -dnl *********************************************** -dnl GHC -dnl *********************************************** - -AC_ARG_WITH(ghc, - AC_HELP_STRING([--with-ghc=], - [Use a different command instead of - 'ghc' for the Haskell compiler.]), - [AC_CHECK_FILE("$withval",GHC="$withval",[AC_PATH_PROG(GHC,"$withval")])], - [AC_PATH_PROG(GHC,ghc)]) - -GHCI=$(dirname $GHC)/ghci - -GHC_VERSION=`$GHC --version | sed -e 's/.*version //'` -AC_MSG_CHECKING([GHC version]) -AC_MSG_RESULT($GHC_VERSION) - - -AC_SUBST(GHC) -AC_SUBST(GHCI) - -dnl *********************************************** -dnl readline -dnl *********************************************** - -AC_ARG_WITH(readline, - AC_HELP_STRING([--with-readline=], - [Select which readline implementation to use. - Available alternatives are: 'readline' (GNU readline), - 'no' (don't use readline) - (default = readline)]), - [if test "$withval" = "yes"; then - READLINE="readline" - else - READLINE="$withval" - fi], - [if test "$host_os" = "cygwin"; then - AC_MSG_WARN([There are problems with readline for Windows, - for example, pipe characters do not work. - Disabling readline support. - Use --with-readline to override.]) - READLINE="no" - else - READLINE="readline" - fi]) - -case $READLINE in - readline) - ;; - no) - ;; - *) - AC_MSG_ERROR([Bad value for --with-readline: $READLINE]) - ;; -esac - -AC_SUBST(READLINE) - -dnl *********************************************** -dnl command interruption -dnl *********************************************** - -AC_ARG_WITH(interrupt, - AC_HELP_STRING([--with-interrupt=], - [Choose whether to enable interruption of commands - with SIGINT (Ctrl-C) - Available alternatives are: 'yes', 'no' - (default = yes)]), - [INTERRUPT="$withval"], - [if test "$host_os" = "cygwin"; then - AC_MSG_WARN([Command interruption does not work under - Cygwin, because of missing signal handler support. - Disabling command interruption support. - Use --with-interrupt to override.]) - INTERRUPT="no" - else - INTERRUPT="yes" - fi]) - -case $INTERRUPT in - yes) - ;; - no) - ;; - *) - AC_MSG_ERROR([Bad value for --with-interrupt: $INTERRUPT]) - ;; -esac - -AC_SUBST(INTERRUPT) - -dnl *********************************************** -dnl ATK speech recognition -dnl *********************************************** - -AC_ARG_WITH(atk, - AC_HELP_STRING([--with-atk=], - [Choose whether to compile in support for speech - recognition using ATK. Requires ATK and libatkrec. - Available alternatives are: 'yes', 'no' - (default = no)]), - [ATK="$withval"], - [ATK="no"]) - -case $ATK in - yes) - AC_MSG_CHECKING([for atkrec package]) - ATKREC_VERSION=`ghc-pkg field atkrec version` - if test "$ATKREC_VERSION" = ""; then - AC_MSG_RESULT(['not found']) - AC_MSG_WARN([Disabling ATK support.]) - ATK="no" - else - AC_MSG_RESULT([$ATKREC_VERSION]) - fi - ;; - no) - ;; - *) - AC_MSG_ERROR([Bad value for --with-atk: $ATK]) - - ;; -esac - -AC_SUBST(ATK) - -dnl *********************************************** -dnl java stuff -dnl *********************************************** - -AC_ARG_ENABLE(java, -AC_HELP_STRING([--enable-java], - [Build Java components. (default = yes)]), -[ENABLE_JAVA="$enableval"], -[ENABLE_JAVA=yes] -) - -if test "$ENABLE_JAVA" = "yes"; then - - AC_ARG_WITH(javac, - AC_HELP_STRING([--with-javac=], - [Use a different command instead of - 'javac' for the Java compiler.]), - [AC_CHECK_FILE("$withval",JAVAC="$withval",[AC_PATH_PROG(JAVAC,"$withval")])], - [AC_PATH_PROG(JAVAC,javac)]) - AC_SUBST(JAVAC) - - AC_ARG_WITH(java, - AC_HELP_STRING([--with-java=], - [Use a different command instead of - 'java' for the Java Virtual Machine.]), - [AC_CHECK_FILE("$withval",JAVA="$withval",[AC_PATH_PROG(JAVA,"$withval")])], - [AC_PATH_PROG(JAVA,java)]) - AC_SUBST(JAVA) - - AC_ARG_WITH(jar, - AC_HELP_STRING([--with-jar=], - [Use a different command instead of - 'jar' for the Java archive tool.]), - [AC_CHECK_FILE("$withval",JAR="$withval",[AC_PATH_PROG(JAR,"$withval")])], - [AC_PATH_PROG(JAR,jar)]) - AC_SUBST(JAR) - - if test "$JAVAC" = "" || test ! -x "$JAVAC" \ - || test "$JAVA" = "" || test ! -x "$JAVA" \ - || test "$JAR" = "" || test ! -x "$JAR"; then - - AC_MSG_WARN([Not building Java components.]) - ENABLE_JAVA=no - fi - -fi - -AC_SUBST(ENABLE_JAVA) - - -dnl *********************************************** -dnl TAR -dnl *********************************************** - -AC_CHECK_PROGS(TAR, gtar tar) - -dnl *********************************************** -dnl Other programs -dnl *********************************************** - -AC_PROG_INSTALL - -dnl *********************************************** -dnl Program flags -dnl *********************************************** - -AC_SUBST(GHCFLAGS) -AC_SUBST(CPPFLAGS) -AC_SUBST(LDFLAGS) - -dnl *********************************************** -dnl Output -dnl *********************************************** - -AC_OUTPUT - diff --git a/src/exper/EditShell.hs b/src/exper/EditShell.hs deleted file mode 100644 index dd7fd8eea..000000000 --- a/src/exper/EditShell.hs +++ /dev/null @@ -1,136 +0,0 @@ -module Main where - -import PGF.Editor -import PGF - -import Data.Char -import System (getArgs) - --- a rough editor shell using the PGF.Edito API --- compile: --- cd .. ; ghc --make exper/EditShell.hs --- use: --- EditShell file.pgf - -main = do - putStrLn "Hi, I'm the Editor! Type h for help on commands." - file:_ <- getArgs - pgf <- readPGF file - let dict = pgf2dict pgf - let st0 = new (startCat pgf) - let lang = head (languages pgf) ---- for printnames; enable choosing lang - editLoop pgf dict lang st0 -- alt 1: all editing commands --- dialogueLoop pgf dict lang st0 -- alt 2: just refinement by parsing (see bottom) - -editLoop :: PGF -> Dict -> Language -> State -> IO State -editLoop pgf dict lang st = do - putStrLn $ - if null (allMetas st) - then unlines - (["The tree is complete:",prState st] ++ linearizeAll pgf (stateTree st)) - else if isMetaFocus st - then "I want something of type " ++ showType (focusType st) ++ - " (0 - " ++ show (length (refineMenu dict st)-1) ++ ")" - else "Do you want to change this node?" - c <- getLine - st' <- interpret pgf dict st c - editLoop pgf dict lang st' - -interpret :: PGF -> Dict -> State -> String -> IO State -interpret pgf dict st c = case words c of - "r":f:_ -> do - let st' = goNextMeta (refine dict (mkCId f) st) - prLState pgf st' - return st' - "p":ws -> do - let tts = parseAll pgf (focusType st) (dropWhile (not . isSpace) c) - st' <- selectReplace dict (concat tts) st - prLState pgf st' - return st' - "a":_ -> do - t:_ <- generateRandom pgf (focusType st) - let st' = goNextMeta (replace dict t st) - prLState pgf st' - return st' - "d":_ -> do - let st' = delete st - prLState pgf st' - return st' - "m":_ -> do - putStrLn (unwords (map prCId (refineMenu dict st))) - return st - d : _ | all isDigit d -> do - let f = refineMenu dict st !! read d - let st' = goNextMeta (refine dict f st) - prLState pgf st' - return st' - p@('[':_):_ -> do - let st' = goPosition (mkPosition (read p)) st - prLState pgf st' - return st' - ">":_ -> do - let st' = goNext st - prLState pgf st' - return st' - "x":_ -> do - mapM_ putStrLn [show (showPosition p) ++ showType t | (p,t) <- allMetas st] - return st - "h":_ -> putStrLn commandHelp >> return st - _ -> do - putStrLn "command not understood" - return st - -prLState pgf st = do - let t = stateTree st - putStrLn (unlines ([ - "Now I have:","", - prState st] ++ - linearizeAll pgf t)) - --- prompt selection from list of trees, such as ambiguous choice -selectReplace :: Dict -> [Tree] -> State -> IO State -selectReplace dict ts st = case ts of - [] -> putStrLn "no results" >> return st - [t] -> return $ goNextMeta $ replace dict t st - _ -> do - mapM_ putStrLn $ "choose tree by entering its number:" : - [show i ++ " : " ++ showTree t | (i,t) <- zip [0..] ts] - d <- getLine - let t = ts !! read d - return $ goNextMeta $ replace dict t st - -commandHelp = unlines [ - "a -- refine with a random subtree", - "d -- delete current subtree", - "h -- display this help message", - "m -- show refinement menu", - "p Anything -- parse Anything and refine with it", - "r Function -- refine with Function", - "x -- show all unknown positions and their types", - "4 -- refine with 4th item from menu (see m)", - "[1,2,3] -- go to position 1,2,3", - "> -- go to next node" - ] - ----------------- --- for a dialogue system, working just by parsing; questions are cat printnames ----------------- - -dialogueLoop :: PGF -> Dict -> Language -> State -> IO State -dialogueLoop pgf dict lang st = do - putStrLn $ - if null (allMetas st) - then "Ready!\n " ++ unlines (linearizeAll pgf (stateTree st)) - else if isMetaFocus st - then showPrintName pgf lang (focusType st) - else "Do you want to change this node?" - c <- getLine - st' <- interpretD pgf dict st c - dialogueLoop pgf dict lang st' - -interpretD :: PGF -> Dict -> State -> String -> IO State -interpretD pgf dict st c = do - let tts = parseAll pgf (focusType st) c - st' <- selectReplace dict (concat tts) st --- prLState pgf st' - return st' diff --git a/src/exper/Evaluate.hs b/src/exper/Evaluate.hs deleted file mode 100644 index 413c82402..000000000 --- a/src/exper/Evaluate.hs +++ /dev/null @@ -1,461 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Evaluate --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/01 15:39:12 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.19 $ --- --- Computation of source terms. Used in compilation and in @cc@ command. ------------------------------------------------------------------------------ - -module GF.Compile.Evaluate (appEvalConcrete) 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 - _ -> ft -{- - (FTC _, []) -> ft - (FTC f, [a]) -> case appPredefined (App f a) of - Ok (t,_) -> FTC t - _ -> error $ "error: appFTerm" +++ prFTerm 0 ft +++ unwords (map prt ts) - _ -> error $ "error: appFTerm" +++ prFTerm 0 ft +++ unwords (map prt ts) --} - -apps :: Term -> (Term,[Term]) -apps t = case t of - App f a -> (f',xs ++ [a]) where (f',xs) = apps f - _ -> (t,[]) - -appEvalConcrete gr bt = liftM fst $ appSTM (evalConcrete gr bt) emptyEEnv - -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 - return $ mkAbs vars trm3 - - 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") _ -> 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@(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) - - 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' - _ -> 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 <- lookupModule 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/exper/Optimize.hs b/src/exper/Optimize.hs deleted file mode 100644 index 7cf88554f..000000000 --- a/src/exper/Optimize.hs +++ /dev/null @@ -1,273 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Optimize --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/16 13:56:13 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.18 $ --- --- Top-level partial evaluation for GF source modules. ------------------------------------------------------------------------------ - -module GF.Compile.Optimize (optimizeModule) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Grammar.PrGrammar -import GF.Grammar.Macros -import GF.Grammar.Lookup -import GF.Grammar.Refresh -import GF.Grammar.Compute -import GF.Compile.BackOpt -import GF.Compile.CheckGrammar -import GF.Compile.Update - -import GF.Compile.Evaluate - -import GF.Data.Operations -import GF.Infra.CheckM -import GF.Infra.Option - -import Control.Monad -import Data.List - --- | 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,SourceModule)] -> (Ident,SourceModule) -> - Err (Ident,SourceModule) -optimizeModule opts ms mo@(_,mi) = case mi of - m0@(Module mt st fs me ops js) | st == MSComplete && isModRes m0 -> do - mo1 <- evalModule oopts ms mo - return $ 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 - _ -> evalModule oopts ms mo - where - oopts = addOptions opts (iOpts (flagsModule mo)) - optim = maybe "all" id $ getOptVal oopts useOptimizer - -evalModule :: Options -> [(Ident,SourceModule)] -> (Ident,SourceModule) -> Err (Ident,SourceModule) -evalModule oopts ms mo@(name,mod) = case mod of - - m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of -{- - -- now: don't optimize resource - - _ | isModRes m0 -> do - let deps = allOperDependencies name js - ids <- topoSortOpers deps - MGrammar (mod' : _) <- foldM evalOp gr ids - return $ mod' --} - MTConcrete a -> do ------ - js0 <- appEvalConcrete gr js - js' <- mapMTree (evalCncInfo oopts gr name a) js0 ---- <- gr0 6/12/2005 - return $ (name, Module mt st fs me ops js') - - _ -> return $ (name,mod) - _ -> return $ (name,mod) - where - gr0 = MGrammar $ ms - gr = MGrammar $ (name,mod) : ms - - evalOp g@(MGrammar ((_, 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) = errIn ("optimizing" +++ prt c) $ case info of - - CncCat ptyp pde ppr -> do - - pde' <- case (ptyp,pde) of - (Yes typ, Yes de) -> - liftM yes $ pEval ([(varStr, typeStr)], typ) de - (Yes typ, Nope) -> - liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(varStr, typeStr)],typ) - (May b, Nope) -> - return $ May b - _ -> return pde -- indirection - - ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c) - - return (c, CncCat ptyp pde' ppr') - - CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> - eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do - pde' <- case pde of ------ Yes de -> 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 +++ ":") - --- | 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 trm1 >>= comp subst >>= outCase subst - else etaExpand trm1 >>= comp subst - return $ mkAbs vars trm3 - - where - - globalTable = oElem showAll opts --- i -all - - comp g t = {- refreshTerm t >>= -} computeTerm gr g t - - etaExpand t = recordExpand val t --- >>= caseEx -- done by comp - - outCase subst t = do - pts <- getParams context - let (args,ptyps) = unzip $ filter (flip occur t . fst) pts - if null args - then return t - else do - let argtyp = RecType $ tuple2recordType ptyps - let pvars = map (Vr . zIdent . prt) args -- gets eliminated - patt <- term2patt $ R $ tuple2record $ pvars - let t' = replace (zip args pvars) t - t1 <- comp subst $ T (TTyped argtyp) [(patt, t')] - return $ S t1 $ R $ tuple2record args - - --- notice: this assumes that all lin types follow the "old JFP style" - getParams = liftM concat . mapM getParam - getParam (argv,RecType rs) = return - [(P (Vr argv) lab, ptyp) | (lab,ptyp) <- rs, not (isLinLabel lab)] - ---getParam (_,ty) | ty==typeStr = return [] --- in lindef - getParam (av,ty) = - Bad ("record type expected not" +++ prt ty +++ "for" +++ prt av) - --- all lin types are rec types - - replace :: [(Term,Term)] -> Term -> Term - replace reps trm = case trm of - -- this is the important case - P _ _ -> maybe trm id $ lookup trm reps - _ -> composSafeOp (replace reps) trm - - occur t trm = case trm of - - -- this is the important case - P _ _ -> t == trm - S x y -> occur t y || occur t x - App f x -> occur t x || occur t f - Abs _ f -> occur t f - R rs -> any (occur t) (map (snd . snd) rs) - T _ cs -> any (occur t) (map snd cs) - C x y -> occur t x || occur t y - Glue x y -> occur t x || occur t y - ExtR x y -> occur t x || occur t y - FV ts -> any (occur t) ts - V _ ts -> any (occur t) ts - Let (_,(_,x)) y -> occur t x || occur t y - _ -> False - - --- here we must be careful not to reduce --- variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}} --- {s = variants {"Auto" ; "Wagen"} ; g = variants {N ; M}} ; - -recordExpand :: Type -> Term -> Err Term -recordExpand typ trm = case unComputed typ of - RecType tys -> case trm of - FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs] - _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys] - _ -> return trm - - --- | auxiliaries for compiling the resource - -mkLinDefault :: SourceGrammar -> Type -> Err Term -mkLinDefault gr typ = do - case unComputed typ of - RecType lts -> mapPairsM mkDefField lts >>= (return . Abs varStr . R . mkAssign) - _ -> prtBad "linearization type must be a record type, not" typ - where - mkDefField typ = case unComputed typ of - Table p t -> do - t' <- mkDefField t - let T _ cs = mkWildCases t' - return $ T (TWild p) cs - Sort "Str" -> return $ Vr varStr - QC q p -> lookupFirstTag gr q p - RecType r -> do - let (ls,ts) = unzip r - ts' <- mapM mkDefField ts - return $ R $ [assign l t | (l,t) <- zip ls ts'] - _ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val - _ -> prtBad "linearization type field cannot be" typ - --- | Form the printname: if given, compute. If not, use the computed --- lin for functions, cat name for cats (dispatch made in evalCncDef above). ---- We cannot use linearization at this stage, since we do not know the ---- defaults we would need for question marks - and we're not yet in canon. -evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term -evalPrintname gr c ppr lin = - case ppr of - Yes pr -> comp pr - _ -> case lin of - Yes t -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm - _ -> return $ K $ prt c ---- - where - comp = computeConcrete gr - - oneBranch t = case t of - Abs _ b -> oneBranch b - R (r:_) -> oneBranch $ snd $ snd r - T _ (c:_) -> oneBranch $ snd c - V _ (c:_) -> oneBranch c - FV (t:_) -> oneBranch t - C x y -> C (oneBranch x) (oneBranch y) - S x _ -> oneBranch x - P x _ -> oneBranch x - Alts (d,_) -> oneBranch d - _ -> t - - --- very unclean cleaner - clean s = case s of - '+':'+':' ':cs -> clean cs - '"':cs -> clean cs - c:cs -> c: clean cs - _ -> s - diff --git a/src/gf.spec b/src/gf.spec deleted file mode 100644 index 8dfbee6f5..000000000 --- a/src/gf.spec +++ /dev/null @@ -1,119 +0,0 @@ -%define name GF -%define version 3.0 -%define release 1 - -Name: %{name} -Summary: Grammatical Framework -Version: %{version} -Release: %{release} -License: GPL -Group: Sciences/Other -Vendor: The Language Technology Group -URL: http://www.cs.chalmers.se/~aarne/GF/ -Source: GF-%{version}.tgz -BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-buildroot -BuildRequires: ghc - -%description -The Grammatical Framework (=GF) is a grammar formalism based on type theory. -It consists of - - * a special-purpose programming language - * a compiler of the language - * a generic grammar processor - -The compiler reads GF grammars from user-provided files, and the -generic grammar processor performs various tasks with the grammars: - - * generation - * parsing - * translation - * type checking - * computation - * paraphrasing - * random generation - * syntax editing - -GF particularly addresses the following aspects of grammars: - - * multilinguality (parallel grammars for different languages) - * semantics (semantic conditions of well-formedness, semantic - properties of expressions) - * grammar engineering (modularity, information hiding, reusable - libraries) - - -%package editor -Summary: Java syntax editor for Grammatical Framework (GF). -Group: Sciences/Other -Requires: %{name} - -%description editor -This package contains the syntax editor GUI for GF. - -%package editor2 -Summary: Java syntax editor for Grammatical Framework (GF). -Group: Sciences/Other -Requires: %{name} - -%description editor2 -This package contains the syntax editor GUI for GF with printname enhancements and HTML support. - - -%prep -rm -rf $RPM_BUILD_ROOT -%setup -q - -%build -cd src -%configure -make all - -%install -cd src -%makeinstall - -%clean -rm -rf $RPM_BUILD_ROOT - -%files -%defattr(-,root,root,0755) -%{_bindir}/gf -%{_bindir}/gfdoc -%doc LICENSE README doc/{DocGF.pdf,gf2-highlights.html,index.html} - -%files editor -%defattr(-,root,root,0755) -%{_bindir}/jgf -%{_datadir}/%{name}-%{version}/gf-java.jar - -%files editor2 -%defattr(-,root,root,0755) -%{_bindir}/gfeditor -%{_datadir}/%{name}-%{version}/gfeditor.jar - - -%changelog -* Tue Jun 21 2005 Hans-Joachim Daniels 2.3pre -- added the printnames and HTML enhanced editor as editor2 - -* Thu May 12 2005 Bjorn Bringert 2.2pre2-1 -- Split package into gf and gf-editor packages. - -* Wed May 11 2005 Bjorn Bringert 2.2pre1-1 -- Release of GF 2.2 - -* Mon Nov 8 2004 Aarne Ranta 2.1-1 -- Release of GF 2.1 - -* Thu Jun 24 2004 Bjorn Bringert 2.0-2 -- Set ownership correctly. -- Move jar-file to share (thanks to Anders Carlsson for pointing this out.) -- Added vendor tag. - -* Tue Jun 22 2004 Bjorn Bringert 2.0-1 -- Include gfdoc binary - -* Mon Jun 21 2004 Bjorn Bringert 2.0-1 -- Initial packaging - diff --git a/src/gf.wxs.in b/src/gf.wxs.in deleted file mode 100644 index e2b21f12b..000000000 --- a/src/gf.wxs.in +++ /dev/null @@ -1,63 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/src/gf_atk.cfg b/src/gf_atk.cfg deleted file mode 100644 index 37bb2c4f5..000000000 --- a/src/gf_atk.cfg +++ /dev/null @@ -1,98 +0,0 @@ -# GF ATK configuration file -# ------------------------ - -# -- Basic audio signal processing -- - -SOURCEFORMAT = HAUDIO -SOURCERATE = 625 - -# Set in GF/System/ATKSpeechInput.hs -# TARGETKIND = MFCC_0_D_A - -TARGETRATE = 100000.0 -WINDOWSIZE = 250000.0 -ENORMALISE = F -ZMEANSOURCE = F -USEHAMMING = T -PREEMCOEF = 0.97 -USEPOWER = T -NUMCHANS = 26 -CEPLIFTER = 22 -NUMCEPS = 12 -SILFLOOR = 50.0 -USESILDET = T -MEASURESIL = F -OUTSILWARN = T - -# -- Silence detection --- - -HPARM: CALWINDOW = 40 -HPARM: SPEECHTHRESH = 9.0 -HPARM: SILDISCARD = 10.0 -HPARM: SILENERGY = 0.0 -HPARM: SPCSEQCOUNT = 10 -HPARM: SPCGLCHCOUNT = 0 -HPARM: SILGLCHCOUNT = 2 -HPARM: SILSEQCOUNT = 50 - -# -- Cepstral mean --- - -HPARM: CMNTCONST = 0.995 -HPARM: CMNRESETONSTOP = F -HPARM: CMNMINFRAMES = 12 - -# -- Recogniser -- - -AREC: TRBAKFREQ = 1 - -# hands free, don't return results until end -AREC: RUNMODE = 01441 - -AREC: GENBEAM = 200.0 -AREC: WORDBEAM = 175.0 -AREC: WORDPEN = -10.0 - -HNET: FORCECXTEXP = T -HNET: ALLOWXWRDEXP = F -HNET: MARKSUBLAT = F -ARMAN: AUTOSIL = F - -HREC: CONFSCALE = 0.15 -HREC: CONFOFFSET = 0.0 -#HREC: CONFBGHMM = bghmm - -# -- Set visibility and positions of ATK controls -- - -AIN: DISPSHOW = T -AIN: DISPXORIGIN = 440 -AIN: DISPYORIGIN = 220 -AIN: DISPHEIGHT = 40 -AIN: DISPWIDTH = 160 - -ACODE: DISPSHOW = F -ACODE: DISPXORIGIN = 40 -ACODE: DISPYORIGIN = 220 -ACODE: DISPHEIGHT = 220 -ACODE: DISPWIDTH = 380 -ACODE: MAXFGFEATS = 13 -ACODE: NUMSTREAMS = 1 - -AREC: DISPSHOW = T -AREC: DISPXORIGIN = 40 -AREC: DISPYORIGIN = 20 -AREC: DISPHEIGHT = 160 -AREC: DISPWIDTH = 560 - - -# -- Debugging -- - -HMMSET: TRACE = 0 -ADICT: TRACE = 0 -AGRAM: TRACE = 0 -GGRAM: TRACE = 0 -AREC: TRACE = 0 -ARMAN: TRACE = 0 -HPARM: TRACE = 0 -HNET: TRACE = 0 -HREC: TRACE = 0 - diff --git a/src/gfc.in b/src/gfc.in deleted file mode 100644 index bd08db0b8..000000000 --- a/src/gfc.in +++ /dev/null @@ -1,30 +0,0 @@ -#!/bin/sh - -prefix="@prefix@" - -case "@host@" in - *-cygwin) - prefix=`cygpath -w "$prefix"`;; -esac - -exec_prefix="@exec_prefix@" -GF_BIN_DIR="@bindir@" -GF_DATA_DIR="@datadir@/GF-@PACKAGE_VERSION@" - -GFBIN="$GF_BIN_DIR/gf" - -if [ ! -x "${GFBIN}" ]; then - GF_BIN_DIR=`dirname $0` - GFBIN="$GF_BIN_DIR/gf" -fi - -if [ ! -x "${GFBIN}" ]; then - GFBIN=`which gf` -fi - -if [ ! -x "${GFBIN}" ]; then - echo "gf not found." - exit 1 -fi - -exec $GFBIN --batch "$@" diff --git a/src/haddock/haddock-check.perl b/src/haddock/haddock-check.perl deleted file mode 100644 index 93647bac7..000000000 --- a/src/haddock/haddock-check.perl +++ /dev/null @@ -1,169 +0,0 @@ - -# checking that a file is haddocky: -# - checking if it has an export list -# - if there is no export list, it tries to find all defined functions -# - checking that all exported functions have type signatures -# - checking that the module header is OK - -# changes on files: -# - transforming hard space to ordinary space - -# limitations: -# - there might be some problems with nested comments -# - cannot handle type signatures for several functions -# (i.e. "a, b, c :: t") -# but on the other hand -- haddock has some problems with these too... - -$operChar = qr/[\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]/; -$operCharColon = qr/[\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]/; -$nonOperChar = qr/[^\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]/; -$nonOperCharColon = qr/[^\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]/; - -$operSym = qr/$operChar $operCharColon*/x; -$funSym = qr/[a-z] \w* \'*/x; -$funOrOper = qr/(?: $funSym | \($operSym\) )/x; - -$keyword = qr/(?: type | data | module | newtype | infix[lr]? | import | instance | class )/x; -$keyOper = qr/^(?: \.\. | \:\:? | \= | \\ | \| | \<\- | \-\> | \@ | \~ | \=\> | \. )$/x; - -sub check_headerline { - my ($title, $regexp) = @_; - if (s/^-- \s $title \s* : \s+ (.+?) \s*\n//sx) { - $name = $1; - push @ERR, "Incorrect ".lcfirst $title.": $name" - unless $name =~ $regexp; - return $&; - } else { - push @ERR, "Header missing: ".lcfirst $title.""; - } -} - -if ($#ARGV >= 0) { - @FILES = @ARGV; -} else { -# @dirs = qw{. api canonical cf cfgm compile for-ghc-nofud -# grammar infra notrace parsers shell -# source speech translate useGrammar util visualization -# GF GF/* GF/*/* GF/*/*/*}; - @dirs = qw{GF GF/* GF/*/* GF/*/*/*}; - @FILES = grep(!/\/(Par|Lex)(GF|GFC|CFG)\.hs$/, - glob "{".join(",",@dirs)."}/*.hs"); -} - -for $file (@FILES) { - $file =~ s/\.hs//; - - open F, "<$file.hs"; - $_ = join "", ; - close F; - - @ERR = (); - - # substituting hard spaces for ordinary spaces - $nchars = tr/\240/ /; - if ($nchars > 0) { - push @ERR, "!! > Substituted $nchars hard spaces"; - open F, ">$file.hs"; - print F $_; - close F; - } - - # the module header - $hdr_module = $module = ""; - - s/^ \{-\# \s+ OPTIONS \s+ -cpp \s+ \#-\} //sx; # removing ghc options (cpp) - s/^ \s+ //sx; # removing initial whitespace - s/^ (--+ \s* \n) +//sx; # removing initial comment lines - unless (s/^ -- \s \| \s* \n//sx) { - push @ERR, "Incorrect module header"; - } else { - $hdr_module = s/^-- \s Module \s* : \s+ (.+?) \s*\n//sx ? $1 : ""; - &check_headerline("Maintainer", qr/^ [\wåäöÅÄÖüÜ\s\@\.]+ $/x); - &check_headerline("Stability", qr/.*/); - &check_headerline("Portability", qr/.*/); - s/^ (--+ \s* \n) +//sx; - push @ERR, "Missing CVS information" - unless s/^(-- \s+ \> \s+ CVS \s+ \$ .*? \$ \s* \n)+//sx; - s/^ (--+ \s* \n) +//sx; - push @ERR, "Missing module description" - unless /^ -- \s+ [^\(]/x; - } - - # removing comments - s/\{- .*? -\}//gsx; - s/-- ($nonOperSymColon .*? \n | \n)/\n/gx; - - # removing \n in front of whitespace (for simplification) - s/\n+[ \t]/ /gs; - - # the export list - $exportlist = ""; - - if (/\n module \s+ ((?: \w | \.)+) \s+ \( (.*?) \) \s+ where/sx) { - ($module, $exportlist) = ($1, $2); - - $exportlist =~ s/\b module \s+ [A-Z] \w*//gsx; - $exportlist =~ s/\(\.\.\)//g; - - } elsif (/\n module \s+ ((?: \w | \.)+) \s+ where/sx) { - $module = $1; - - # modules without export lists - # push @ERR, "No export list"; - - # function definitions - while (/^ (.*? $nonOperCharColon) = (?! $operCharColon)/gmx) { - $defn = $1; - next if $defn =~ /^ $keyword \b/x; - - if ($defn =~ /\` ($funSym) \`/x) { - $fn = $1; - } elsif ($defn =~ /(? Error in function defintion: $defn"; - next; - } - - $exportlist .= " $fn "; - } - } else { - push @ERR, "No module header found"; - } - - push @ERR, "Module names not matching: $module != $hdr_module" - if $hdr_module && $module !~ /\Q$hdr_module\E$/; - - # fixing exportlist (double spaces as separator) - $exportlist = " $exportlist "; - $exportlist =~ s/(\s | \,)+/ /gx; - - # removing functions with type signatures from export list - while (/^ ($funOrOper (\s* , \s* $funOrOper)*) \s* ::/gmx) { - $functionlist = $1; - while ($functionlist =~ s/^ ($funOrOper) (\s* , \s*)?//x) { - $function = $1; - $exportlist =~ s/\s \Q$function\E \s/ /gx; - } - } - - # reporting exported functions without type signatures - $reported = 0; - $untyped = ""; - while ($exportlist =~ /\s ($funOrOper) \s/x) { - $function = $1; - $exportlist =~ s/\s \Q$function\E \s/ /gx; - $reported++; - $untyped .= " $function"; - } - push @ERR, "No type signature for $reported function(s):\n " . $untyped - if $reported; - - print "-- $file\n > " . join("\n > ", @ERR) . "\n" - if @ERR; -} - - diff --git a/src/haddock/haddock-script.csh b/src/haddock/haddock-script.csh deleted file mode 100644 index 77b3761f8..000000000 --- a/src/haddock/haddock-script.csh +++ /dev/null @@ -1,73 +0,0 @@ -#!/bin/tcsh - -###################################################################### -# Author: Peter Ljunglöf -# Time-stamp: "2005-05-12, 23:17" -# CVS $Date: 2005/05/13 12:40:20 $ -# CVS $Author: peb $ -# -# a script for producing documentation through Haddock -###################################################################### - -set basedir = `pwd` -set docdir = haddock/html -set tempdir = haddock/.temp-files -set resourcedir = haddock/resources - -set files = (`find GF -name '*.hs'` GF.hs) - -###################################################################### - -echo 1. Creating and cleaning Haddock directory -echo -- $docdir - -mkdir -p $docdir -rm -rf $docdir/* - -###################################################################### - -echo -echo 2. Copying Haskell files to temporary directory: $tempdir - -rm -rf $tempdir - -foreach f ($files) - # echo -- $f - mkdir -p `dirname $tempdir/$f` - perl -pe 's/^#/-- CPP #/' $f > $tempdir/$f -end - -###################################################################### - -echo -echo 3. Invoking Haddock - -cd $tempdir -haddock -o $basedir/$docdir -h -t 'Grammatical Framework' $files -cd $basedir - -###################################################################### - -echo -echo 4. Restructuring to HTML framesets - -echo -- Substituting for frame targets inside html files -mv $docdir/index.html $docdir/index-frame.html -foreach f ($docdir/*.html) - # echo -- $f - perl -pe 's/ .tempfile - mv .tempfile $f -end - -echo -- Copying resource files: -echo -- `ls $resourcedir/*.*` -cp $resourcedir/*.* $docdir - -###################################################################### - -echo -echo 5. Finished -echo -- The documentation is located at: -echo -- $docdir/index.html - - diff --git a/src/haddock/resources/blank.html b/src/haddock/resources/blank.html deleted file mode 100644 index 63ab0b172..000000000 --- a/src/haddock/resources/blank.html +++ /dev/null @@ -1,10 +0,0 @@ - - - - - - - - - - diff --git a/src/haddock/resources/index.html b/src/haddock/resources/index.html deleted file mode 100644 index 5d8822dc5..000000000 --- a/src/haddock/resources/index.html +++ /dev/null @@ -1,14 +0,0 @@ - - - - - - -Grammatical Framework programmer's documentation - - - - - - diff --git a/src/install-sh b/src/install-sh deleted file mode 100644 index e9de23842..000000000 --- a/src/install-sh +++ /dev/null @@ -1,251 +0,0 @@ -#!/bin/sh -# -# install - install a program, script, or datafile -# This comes from X11R5 (mit/util/scripts/install.sh). -# -# Copyright 1991 by the Massachusetts Institute of Technology -# -# Permission to use, copy, modify, distribute, and sell this software and its -# documentation for any purpose is hereby granted without fee, provided that -# the above copyright notice appear in all copies and that both that -# copyright notice and this permission notice appear in supporting -# documentation, and that the name of M.I.T. not be used in advertising or -# publicity pertaining to distribution of the software without specific, -# written prior permission. M.I.T. makes no representations about the -# suitability of this software for any purpose. It is provided "as is" -# without express or implied warranty. -# -# Calling this script install-sh is preferred over install.sh, to prevent -# `make' implicit rules from creating a file called install from it -# when there is no Makefile. -# -# This script is compatible with the BSD install script, but was written -# from scratch. It can only install one file at a time, a restriction -# shared with many OS's install programs. - - -# set DOITPROG to echo to test this script - -# Don't use :- since 4.3BSD and earlier shells don't like it. -doit="${DOITPROG-}" - - -# put in absolute paths if you don't have them in your path; or use env. vars. - -mvprog="${MVPROG-mv}" -cpprog="${CPPROG-cp}" -chmodprog="${CHMODPROG-chmod}" -chownprog="${CHOWNPROG-chown}" -chgrpprog="${CHGRPPROG-chgrp}" -stripprog="${STRIPPROG-strip}" -rmprog="${RMPROG-rm}" -mkdirprog="${MKDIRPROG-mkdir}" - -transformbasename="" -transform_arg="" -instcmd="$mvprog" -chmodcmd="$chmodprog 0755" -chowncmd="" -chgrpcmd="" -stripcmd="" -rmcmd="$rmprog -f" -mvcmd="$mvprog" -src="" -dst="" -dir_arg="" - -while [ x"$1" != x ]; do - case $1 in - -c) instcmd="$cpprog" - shift - continue;; - - -d) dir_arg=true - shift - continue;; - - -m) chmodcmd="$chmodprog $2" - shift - shift - continue;; - - -o) chowncmd="$chownprog $2" - shift - shift - continue;; - - -g) chgrpcmd="$chgrpprog $2" - shift - shift - continue;; - - -s) stripcmd="$stripprog" - shift - continue;; - - -t=*) transformarg=`echo $1 | sed 's/-t=//'` - shift - continue;; - - -b=*) transformbasename=`echo $1 | sed 's/-b=//'` - shift - continue;; - - *) if [ x"$src" = x ] - then - src=$1 - else - # this colon is to work around a 386BSD /bin/sh bug - : - dst=$1 - fi - shift - continue;; - esac -done - -if [ x"$src" = x ] -then - echo "install: no input file specified" - exit 1 -else - true -fi - -if [ x"$dir_arg" != x ]; then - dst=$src - src="" - - if [ -d $dst ]; then - instcmd=: - chmodcmd="" - else - instcmd=mkdir - fi -else - -# Waiting for this to be detected by the "$instcmd $src $dsttmp" command -# might cause directories to be created, which would be especially bad -# if $src (and thus $dsttmp) contains '*'. - - if [ -f $src -o -d $src ] - then - true - else - echo "install: $src does not exist" - exit 1 - fi - - if [ x"$dst" = x ] - then - echo "install: no destination specified" - exit 1 - else - true - fi - -# If destination is a directory, append the input filename; if your system -# does not like double slashes in filenames, you may need to add some logic - - if [ -d $dst ] - then - dst="$dst"/`basename $src` - else - true - fi -fi - -## this sed command emulates the dirname command -dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` - -# Make sure that the destination directory exists. -# this part is taken from Noah Friedman's mkinstalldirs script - -# Skip lots of stat calls in the usual case. -if [ ! -d "$dstdir" ]; then -defaultIFS=' -' -IFS="${IFS-${defaultIFS}}" - -oIFS="${IFS}" -# Some sh's can't handle IFS=/ for some reason. -IFS='%' -set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` -IFS="${oIFS}" - -pathcomp='' - -while [ $# -ne 0 ] ; do - pathcomp="${pathcomp}${1}" - shift - - if [ ! -d "${pathcomp}" ] ; - then - $mkdirprog "${pathcomp}" - else - true - fi - - pathcomp="${pathcomp}/" -done -fi - -if [ x"$dir_arg" != x ] -then - $doit $instcmd $dst && - - if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && - if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && - if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && - if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi -else - -# If we're going to rename the final executable, determine the name now. - - if [ x"$transformarg" = x ] - then - dstfile=`basename $dst` - else - dstfile=`basename $dst $transformbasename | - sed $transformarg`$transformbasename - fi - -# don't allow the sed command to completely eliminate the filename - - if [ x"$dstfile" = x ] - then - dstfile=`basename $dst` - else - true - fi - -# Make a temp file name in the proper directory. - - dsttmp=$dstdir/#inst.$$# - -# Move or copy the file name to the temp name - - $doit $instcmd $src $dsttmp && - - trap "rm -f ${dsttmp}" 0 && - -# and set any options; do chmod last to preserve setuid bits - -# If any of these fail, we abort the whole thing. If we want to -# ignore errors from any of these, just make sure not to ignore -# errors from the above "$doit $instcmd $src $dsttmp" command. - - if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && - if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && - if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && - if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && - -# Now rename the file to the real destination. - - $doit $rmcmd -f $dstdir/$dstfile && - $doit $mvcmd $dsttmp $dstdir/$dstfile - -fi && - - -exit 0 diff --git a/src/runtime/c/Makefile b/src/runtime/c/Makefile new file mode 100644 index 000000000..72ac7ea79 --- /dev/null +++ b/src/runtime/c/Makefile @@ -0,0 +1,19 @@ +CC = gcc +CFLAGS += -O2 -W -Wall + +.PHONY: all clean + +all: libgfcc.a + +libgfcc.a: gfcc-tree.o gfcc-term.o + ar r $@ $^ + +gfcc-tree.o: gfcc-tree.c gfcc-tree.h + $(CC) $(CFLAGS) -c -o $@ $< + +gfcc-term.o: gfcc-term.c gfcc-term.h + $(CC) $(CFLAGS) -c -o $@ $< + +clean: + -rm -f libgfcc.a + -rm -f *.o diff --git a/src/runtime/c/gfcc-term.c b/src/runtime/c/gfcc-term.c new file mode 100644 index 000000000..b427479e6 --- /dev/null +++ b/src/runtime/c/gfcc-term.c @@ -0,0 +1,203 @@ +#include "gfcc-term.h" + +#include +#include +#include + +static void *buffer = NULL; +static size_t current; + +extern void term_alloc_pool(size_t size) { + if (buffer == NULL) + buffer = malloc(size); + current = 0; +} + +extern void term_free_pool() { + if (buffer != NULL) + free(buffer); + buffer = NULL; +} + +extern void *term_alloc(size_t size) { + void *off = buffer + current; + current += size; + return off; +} + +static inline Term *create_term(TermType type, int n) { + Term *t = (Term*)term_alloc(sizeof(Term) + n * sizeof(Term *)); + t->type = type; + t->value.size = n; /* FIXME: hack! */ + return t; +} + +extern Term *term_array(int n, ...) { + Term *t = create_term(TERM_ARRAY, n); + va_list ap; + int i; + + va_start(ap, n); + for (i = 0; i < n; i++) { + term_set_child(t, i, va_arg(ap, Term *)); + } + va_end(ap); + + return t; +} + +extern Term *term_seq(int n, ...) { + Term *t = create_term(TERM_SEQUENCE, n); + va_list ap; + int i; + + va_start(ap, n); + for (i = 0; i < n; i++) { + term_set_child(t, i, va_arg(ap, Term *)); + } + va_end(ap); + + return t; +} + +extern Term *term_variants(int n, ...) { + Term *t = create_term(TERM_VARIANTS, n); + va_list ap; + int i; + + va_start(ap, n); + for (i = 0; i < n; i++) { + term_set_child(t, i, va_arg(ap, Term *)); + } + va_end(ap); + + return t; +} + +extern Term *term_glue(int n, ...) { + Term *t = create_term(TERM_GLUE, n); + va_list ap; + int i; + + va_start(ap, n); + for (i = 0; i < n; i++) { + term_set_child(t, i, va_arg(ap, Term *)); + } + va_end(ap); + + return t; +} + +extern Term *term_rp(Term *t1, Term *t2) { + Term *t = create_term(TERM_RECORD_PARAM, 2); + term_set_child(t, 0, t1); + term_set_child(t, 1, t2); + return t; +} + +extern Term *term_suffix(const char *pref, Term *suf) { + Term *t = create_term(TERM_SUFFIX_TABLE, 2); + term_set_child(t,0,term_str(pref)); + term_set_child(t,1,suf); + return t; +} + +extern Term *term_str(const char *s) { + Term *t = create_term(TERM_STRING, 0); + t->value.string_value = s; + return t; +} + +extern Term *term_int(int i) { + Term *t = create_term(TERM_INTEGER,0); + t->value.integer_value = i; + return t; +} + +extern Term *term_meta() { + return create_term(TERM_META, 0); +} + + + +extern Term *term_sel_int(Term *t, int i) { + switch (t->type) { + case TERM_ARRAY: + return term_get_child(t,i); + case TERM_SUFFIX_TABLE: + return term_glue(2, + term_get_child(t,0), + term_sel_int(term_get_child(t,1),i)); + case TERM_META: + return t; + default: + fprintf(stderr,"Error: term_sel_int %d %d\n", t->type, i); + exit(1); + return NULL; + } +} + +extern Term *term_sel(Term *t1, Term *t2) { + switch (t2->type) { + case TERM_INTEGER: + return term_sel_int(t1, t2->value.integer_value); + case TERM_RECORD_PARAM: + return term_sel(t1,term_get_child(t2,0)); + case TERM_META: + return term_sel_int(t1,0); + default: + fprintf(stderr,"Error: term_sel %d %d\n", t1->type, t2->type); + exit(1); + return 0; + } +} + + + +static void term_print_sep(FILE *stream, Term *t, const char *sep) { + int n = t->value.size; + int i; + + for (i = 0; i < n; i++) { + term_print(stream, term_get_child(t,i)); + if (i < n-1) { + fputs(sep, stream); + } + } +} + +extern void term_print(FILE *stream, Term *t) { + switch (t->type) { + case TERM_ARRAY: + term_print(stream, term_get_child(t,0)); + break; + case TERM_SEQUENCE: + term_print_sep(stream, t, " "); + break; + case TERM_VARIANTS: + term_print_sep(stream, t, "/"); + break; + case TERM_GLUE: + term_print_sep(stream, t, ""); + break; + case TERM_RECORD_PARAM: + term_print(stream, term_get_child(t,0)); + break; + case TERM_SUFFIX_TABLE: + term_print(stream, term_get_child(t,0)); + term_print(stream, term_get_child(t,1)); + break; + case TERM_META: + fputs("?", stream); + break; + case TERM_STRING: + fputs(t->value.string_value, stream); + break; + case TERM_INTEGER: + fprintf(stream, "%d", t->value.integer_value); + break; + default: + fprintf(stderr,"Error: term_print %d\n", t->type); + exit(1); + } +} diff --git a/src/runtime/c/gfcc-term.h b/src/runtime/c/gfcc-term.h new file mode 100644 index 000000000..d1307259d --- /dev/null +++ b/src/runtime/c/gfcc-term.h @@ -0,0 +1,65 @@ +#ifndef GFCC_TERM_H +#define GFCC_TERM_H + +#include + +typedef enum { + /* size = variable */ + TERM_ARRAY, + TERM_SEQUENCE, + TERM_VARIANTS, + TERM_GLUE, + /* size = 2 */ + TERM_RECORD_PARAM, + TERM_SUFFIX_TABLE, + /* size = 0 */ + TERM_META, + TERM_STRING, + TERM_INTEGER +} TermType; + +struct Term_ { + TermType type; + union { + const char *string_value; + int integer_value; + int size; + } value; + struct Term_ *args[0]; +}; + +typedef struct Term_ Term; + + + +static inline Term *term_get_child(Term *t, int n) { + return t->args[n]; +} + +static inline void term_set_child(Term *t, int n, Term *c) { + t->args[n] = c; +} + +extern void term_alloc_pool(size_t size); +extern void term_free_pool(); +extern void *term_alloc(size_t size); + + +extern Term *term_array(int n, ...); +extern Term *term_seq(int n, ...); +extern Term *term_variants(int n, ...); +extern Term *term_glue(int n, ...); + +extern Term *term_rp(Term *t1, Term *t2); +extern Term *term_suffix(const char *pref, Term *suf); +extern Term *term_str(const char *s); +extern Term *term_int(int i); +extern Term *term_meta(); + +extern Term *term_sel_int(Term *t, int i); +extern Term *term_sel(Term *t1, Term *t2); + + +extern void term_print(FILE *stream, Term *t); + +#endif diff --git a/src/runtime/c/gfcc-tree.c b/src/runtime/c/gfcc-tree.c new file mode 100644 index 000000000..6cd8759be --- /dev/null +++ b/src/runtime/c/gfcc-tree.c @@ -0,0 +1,61 @@ +#include "gfcc-tree.h" + +#include + + +extern int arity(Tree *t) { + switch (t->type) { + case ATOM_STRING: + case ATOM_INTEGER: + case ATOM_DOUBLE: + case ATOM_META: + return 0; + default: + return t->value.size; + } +} + +static Tree *create_tree(atom_type c, int n) { + Tree *t = (Tree *)malloc(sizeof(Tree) + n * sizeof(Tree *)); + t->type = c; + return t; +} + +extern Tree *tree_string(const char *s) { + Tree *t = create_tree(ATOM_STRING, 0); + t->value.string_value = s; + return t; +} + +extern Tree *tree_integer(int i) { + Tree *t = create_tree(ATOM_INTEGER, 0); + t->value.integer_value = i; + return t; +} + +extern Tree *tree_double(double d) { + Tree *t = create_tree(ATOM_DOUBLE, 0); + t->value.double_value = d; + return t; +} + +extern Tree *tree_meta() { + return create_tree(ATOM_META, 0); +} + +extern Tree *tree_fun(atom_type f, int n) { + Tree *t = create_tree(f, n); + t->value.size = n; + return t; +} + + +extern void tree_free(Tree *t) { + int n = arity(t); + int i; + + for (i = 0; i < n; i++) { + tree_free(tree_get_child(t,i)); + } + free(t); +} diff --git a/src/runtime/c/gfcc-tree.h b/src/runtime/c/gfcc-tree.h new file mode 100644 index 000000000..cc8f0fcab --- /dev/null +++ b/src/runtime/c/gfcc-tree.h @@ -0,0 +1,49 @@ +#ifndef GFCC_TREE_H +#define GFCC_TREE_H + +typedef enum { + ATOM_STRING, + ATOM_INTEGER, + ATOM_DOUBLE, + ATOM_META, + ATOM_FIRST_FUN +} atom_type; + +struct Tree_{ + atom_type type; + union { + const char *string_value; + int integer_value; + double double_value; + int size; + } value; + struct Tree_ *args[0]; +}; + +typedef struct Tree_ Tree; + +static inline Tree *tree_get_child(Tree *t, int n) { + return t->args[n]; +} + +static inline void tree_set_child(Tree *t, int n, Tree *a) { + t->args[n] = a; +} + +extern int arity(Tree *t); + + +extern Tree *tree_string(const char *s); + +extern Tree *tree_integer(int i); + +extern Tree *tree_double(double d); + +extern Tree *tree_meta(); + +extern Tree *tree_fun(atom_type f, int n); + + +extern void tree_free(Tree *t); + +#endif diff --git a/src/runtime/haskell/Data/Binary.hs b/src/runtime/haskell/Data/Binary.hs new file mode 100644 index 000000000..786f5a09e --- /dev/null +++ b/src/runtime/haskell/Data/Binary.hs @@ -0,0 +1,791 @@ +{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary +-- Copyright : Lennart Kolmodin +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Lennart Kolmodin +-- Stability : unstable +-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances +-- +-- Binary serialisation of Haskell values to and from lazy ByteStrings. +-- The Binary library provides methods for encoding Haskell values as +-- streams of bytes directly in memory. The resulting @ByteString@ can +-- then be written to disk, sent over the network, or futher processed +-- (for example, compressed with gzip). +-- +-- The 'Binary' package is notable in that it provides both pure, and +-- high performance serialisation. +-- +-- Values are always encoded in network order (big endian) form, and +-- encoded data should be portable across machine endianess, word size, +-- or compiler version. For example, data encoded using the Binary class +-- could be written from GHC, and read back in Hugs. +-- +----------------------------------------------------------------------------- + +module Data.Binary ( + + -- * The Binary class + Binary(..) + + -- $example + + -- * The Get and Put monads + , Get + , Put + + -- * Useful helpers for writing instances + , putWord8 + , getWord8 + + -- * Binary serialisation + , encode -- :: Binary a => a -> ByteString + , decode -- :: Binary a => ByteString -> a + + -- * IO functions for serialisation + , encodeFile -- :: Binary a => FilePath -> a -> IO () + , decodeFile -- :: Binary a => FilePath -> IO a + +-- Lazy put and get +-- , lazyPut +-- , lazyGet + + , module Data.Word -- useful + + ) where + +#include "MachDeps.h" + +import Data.Word + +import Data.Binary.Put +import Data.Binary.Get + +import Control.Monad +import Control.Exception +import Foreign +import System.IO + +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as L + +import Data.Char (chr,ord) +import Data.List (unfoldr) + +-- And needed for the instances: +import qualified Data.ByteString as B +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Ratio as R + +import qualified Data.Tree as T + +import Data.Array.Unboxed + +-- +-- This isn't available in older Hugs or older GHC +-- +#if __GLASGOW_HASKELL__ >= 606 +import qualified Data.Sequence as Seq +import qualified Data.Foldable as Fold +#endif + +------------------------------------------------------------------------ + +-- | The @Binary@ class provides 'put' and 'get', methods to encode and +-- decode a Haskell value to a lazy ByteString. It mirrors the Read and +-- Show classes for textual representation of Haskell types, and is +-- suitable for serialising Haskell values to disk, over the network. +-- +-- For parsing and generating simple external binary formats (e.g. C +-- structures), Binary may be used, but in general is not suitable +-- for complex protocols. Instead use the Put and Get primitives +-- directly. +-- +-- Instances of Binary should satisfy the following property: +-- +-- > decode . encode == id +-- +-- That is, the 'get' and 'put' methods should be the inverse of each +-- other. A range of instances are provided for basic Haskell types. +-- +class Binary t where + -- | Encode a value in the Put monad. + put :: t -> Put + -- | Decode a value in the Get monad + get :: Get t + +-- $example +-- To serialise a custom type, an instance of Binary for that type is +-- required. For example, suppose we have a data structure: +-- +-- > data Exp = IntE Int +-- > | OpE String Exp Exp +-- > deriving Show +-- +-- We can encode values of this type into bytestrings using the +-- following instance, which proceeds by recursively breaking down the +-- structure to serialise: +-- +-- > instance Binary Exp where +-- > put (IntE i) = do put (0 :: Word8) +-- > put i +-- > put (OpE s e1 e2) = do put (1 :: Word8) +-- > put s +-- > put e1 +-- > put e2 +-- > +-- > get = do t <- get :: Get Word8 +-- > case t of +-- > 0 -> do i <- get +-- > return (IntE i) +-- > 1 -> do s <- get +-- > e1 <- get +-- > e2 <- get +-- > return (OpE s e1 e2) +-- +-- Note how we write an initial tag byte to indicate each variant of the +-- data type. +-- +-- We can simplify the writing of 'get' instances using monadic +-- combinators: +-- +-- > get = do tag <- getWord8 +-- > case tag of +-- > 0 -> liftM IntE get +-- > 1 -> liftM3 OpE get get get +-- +-- The generation of Binary instances has been automated by a script +-- using Scrap Your Boilerplate generics. Use the script here: +-- . +-- +-- To derive the instance for a type, load this script into GHCi, and +-- bring your type into scope. Your type can then have its Binary +-- instances derived as follows: +-- +-- > $ ghci -fglasgow-exts BinaryDerive.hs +-- > *BinaryDerive> :l Example.hs +-- > *Main> deriveM (undefined :: Drinks) +-- > +-- > instance Binary Main.Drinks where +-- > put (Beer a) = putWord8 0 >> put a +-- > put Coffee = putWord8 1 +-- > put Tea = putWord8 2 +-- > put EnergyDrink = putWord8 3 +-- > put Water = putWord8 4 +-- > put Wine = putWord8 5 +-- > put Whisky = putWord8 6 +-- > get = do +-- > tag_ <- getWord8 +-- > case tag_ of +-- > 0 -> get >>= \a -> return (Beer a) +-- > 1 -> return Coffee +-- > 2 -> return Tea +-- > 3 -> return EnergyDrink +-- > 4 -> return Water +-- > 5 -> return Wine +-- > 6 -> return Whisky +-- > +-- +-- To serialise this to a bytestring, we use 'encode', which packs the +-- data structure into a binary format, in a lazy bytestring +-- +-- > > let e = OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) +-- > > let v = encode e +-- +-- Where 'v' is a binary encoded data structure. To reconstruct the +-- original data, we use 'decode' +-- +-- > > decode v :: Exp +-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) +-- +-- The lazy ByteString that results from 'encode' can be written to +-- disk, and read from disk using Data.ByteString.Lazy IO functions, +-- such as hPutStr or writeFile: +-- +-- > > writeFile "/tmp/exp.txt" (encode e) +-- +-- And read back with: +-- +-- > > readFile "/tmp/exp.txt" >>= return . decode :: IO Exp +-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) +-- +-- We can also directly serialise a value to and from a Handle, or a file: +-- +-- > > v <- decodeFile "/tmp/exp.txt" :: IO Exp +-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) +-- +-- And write a value to disk +-- +-- > > encodeFile "/tmp/a.txt" v +-- + +------------------------------------------------------------------------ +-- Wrappers to run the underlying monad + +-- | Encode a value using binary serialisation to a lazy ByteString. +-- +encode :: Binary a => a -> ByteString +encode = runPut . put +{-# INLINE encode #-} + +-- | Decode a value from a lazy ByteString, reconstructing the original structure. +-- +decode :: Binary a => ByteString -> a +decode = runGet get + +------------------------------------------------------------------------ +-- Convenience IO operations + +-- | Lazily serialise a value to a file +-- +-- This is just a convenience function, it's defined simply as: +-- +-- > encodeFile f = B.writeFile f . encode +-- +-- So for example if you wanted to compress as well, you could use: +-- +-- > B.writeFile f . compress . encode +-- +encodeFile :: Binary a => FilePath -> a -> IO () +encodeFile f v = L.writeFile f (encode v) + +-- | Lazily reconstruct a value previously written to a file. +-- +-- This is just a convenience function, it's defined simply as: +-- +-- > decodeFile f = return . decode =<< B.readFile f +-- +-- So for example if you wanted to decompress as well, you could use: +-- +-- > return . decode . decompress =<< B.readFile f +-- +decodeFile :: Binary a => FilePath -> IO a +decodeFile f = bracket (openBinaryFile f ReadMode) hClose $ \h -> do + s <- L.hGetContents h + evaluate $ runGet get s + +-- needs bytestring 0.9.1.x to work + +------------------------------------------------------------------------ +-- Lazy put and get + +-- lazyPut :: (Binary a) => a -> Put +-- lazyPut a = put (encode a) + +-- lazyGet :: (Binary a) => Get a +-- lazyGet = fmap decode get + +------------------------------------------------------------------------ +-- Simple instances + +-- The () type need never be written to disk: values of singleton type +-- can be reconstructed from the type alone +instance Binary () where + put () = return () + get = return () + +-- Bools are encoded as a byte in the range 0 .. 1 +instance Binary Bool where + put = putWord8 . fromIntegral . fromEnum + get = liftM (toEnum . fromIntegral) getWord8 + +-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2 +instance Binary Ordering where + put = putWord8 . fromIntegral . fromEnum + get = liftM (toEnum . fromIntegral) getWord8 + +------------------------------------------------------------------------ +-- Words and Ints + +-- Words8s are written as bytes +instance Binary Word8 where + put = putWord8 + get = getWord8 + +-- Words16s are written as 2 bytes in big-endian (network) order +instance Binary Word16 where + put = putWord16be + get = getWord16be + +-- Words32s are written as 4 bytes in big-endian (network) order +instance Binary Word32 where + put = putWord32be + get = getWord32be + +-- Words64s are written as 8 bytes in big-endian (network) order +instance Binary Word64 where + put = putWord64be + get = getWord64be + +-- Int8s are written as a single byte. +instance Binary Int8 where + put i = put (fromIntegral i :: Word8) + get = liftM fromIntegral (get :: Get Word8) + +-- Int16s are written as a 2 bytes in big endian format +instance Binary Int16 where + put i = put (fromIntegral i :: Word16) + get = liftM fromIntegral (get :: Get Word16) + +-- Int32s are written as a 4 bytes in big endian format +instance Binary Int32 where + put i = put (fromIntegral i :: Word32) + get = liftM fromIntegral (get :: Get Word32) + +-- Int64s are written as a 4 bytes in big endian format +instance Binary Int64 where + put i = put (fromIntegral i :: Word64) + get = liftM fromIntegral (get :: Get Word64) + +------------------------------------------------------------------------ + +-- Words are written as sequence of bytes. The last bit of each +-- byte indicates whether there are more bytes to be read +instance Binary Word where + put i | i <= 0x7f = do put a + | i <= 0x3fff = do put (a .|. 0x80) + put b + | i <= 0x1fffff = do put (a .|. 0x80) + put (b .|. 0x80) + put c + | i <= 0xfffffff = do put (a .|. 0x80) + put (b .|. 0x80) + put (c .|. 0x80) + put d +#if WORD_SIZE_IN_BITS < 64 + | otherwise = do put (a .|. 0x80) + put (b .|. 0x80) + put (c .|. 0x80) + put (d .|. 0x80) + put e +#else + | i <= 0x7ffffffff = do put (a .|. 0x80) + put (b .|. 0x80) + put (c .|. 0x80) + put (d .|. 0x80) + put e + | i <= 0x3ffffffffff = do put (a .|. 0x80) + put (b .|. 0x80) + put (c .|. 0x80) + put (d .|. 0x80) + put (e .|. 0x80) + put f + | i <= 0x1ffffffffffff = do put (a .|. 0x80) + put (b .|. 0x80) + put (c .|. 0x80) + put (d .|. 0x80) + put (e .|. 0x80) + put (f .|. 0x80) + put g + | i <= 0xffffffffffffff = do put (a .|. 0x80) + put (b .|. 0x80) + put (c .|. 0x80) + put (d .|. 0x80) + put (e .|. 0x80) + put (f .|. 0x80) + put (g .|. 0x80) + put h + | i <= 0xffffffffffffff = do put (a .|. 0x80) + put (b .|. 0x80) + put (c .|. 0x80) + put (d .|. 0x80) + put (e .|. 0x80) + put (f .|. 0x80) + put (g .|. 0x80) + put h + | i <= 0x7fffffffffffffff = do put (a .|. 0x80) + put (b .|. 0x80) + put (c .|. 0x80) + put (d .|. 0x80) + put (e .|. 0x80) + put (f .|. 0x80) + put (g .|. 0x80) + put (h .|. 0x80) + put j + | otherwise = do put (a .|. 0x80) + put (b .|. 0x80) + put (c .|. 0x80) + put (d .|. 0x80) + put (e .|. 0x80) + put (f .|. 0x80) + put (g .|. 0x80) + put (h .|. 0x80) + put (j .|. 0x80) + put k +#endif + where + a = fromIntegral ( i .&. 0x7f) :: Word8 + b = fromIntegral (shiftR i 7 .&. 0x7f) :: Word8 + c = fromIntegral (shiftR i 14 .&. 0x7f) :: Word8 + d = fromIntegral (shiftR i 21 .&. 0x7f) :: Word8 + e = fromIntegral (shiftR i 28 .&. 0x7f) :: Word8 + f = fromIntegral (shiftR i 35 .&. 0x7f) :: Word8 + g = fromIntegral (shiftR i 42 .&. 0x7f) :: Word8 + h = fromIntegral (shiftR i 49 .&. 0x7f) :: Word8 + j = fromIntegral (shiftR i 56 .&. 0x7f) :: Word8 + k = fromIntegral (shiftR i 63 .&. 0x7f) :: Word8 + + get = do i <- getWord8 + (if i <= 0x7f + then return (fromIntegral i) + else do n <- get + return $ (n `shiftL` 7) .|. (fromIntegral (i .&. 0x7f))) + +-- Int has the same representation as Word +instance Binary Int where + put i = put (fromIntegral i :: Word) + get = liftM fromIntegral (get :: Get Word) + +------------------------------------------------------------------------ +-- +-- Portable, and pretty efficient, serialisation of Integer +-- + +-- Fixed-size type for a subset of Integer +type SmallInt = Int32 + +-- Integers are encoded in two ways: if they fit inside a SmallInt, +-- they're written as a byte tag, and that value. If the Integer value +-- is too large to fit in a SmallInt, it is written as a byte array, +-- along with a sign and length field. + +instance Binary Integer where + + {-# INLINE put #-} + put n | n >= lo && n <= hi = do + putWord8 0 + put (fromIntegral n :: SmallInt) -- fast path + where + lo = fromIntegral (minBound :: SmallInt) :: Integer + hi = fromIntegral (maxBound :: SmallInt) :: Integer + + put n = do + putWord8 1 + put sign + put (unroll (abs n)) -- unroll the bytes + where + sign = fromIntegral (signum n) :: Word8 + + {-# INLINE get #-} + get = do + tag <- get :: Get Word8 + case tag of + 0 -> liftM fromIntegral (get :: Get SmallInt) + _ -> do sign <- get + bytes <- get + let v = roll bytes + return $! if sign == (1 :: Word8) then v else - v + +-- +-- Fold and unfold an Integer to and from a list of its bytes +-- +unroll :: Integer -> [Word8] +unroll = unfoldr step + where + step 0 = Nothing + step i = Just (fromIntegral i, i `shiftR` 8) + +roll :: [Word8] -> Integer +roll = foldr unstep 0 + where + unstep b a = a `shiftL` 8 .|. fromIntegral b + +{- + +-- +-- An efficient, raw serialisation for Integer (GHC only) +-- + +-- TODO This instance is not architecture portable. GMP stores numbers as +-- arrays of machine sized words, so the byte format is not portable across +-- architectures with different endianess and word size. + +import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy) +import GHC.Base hiding (ord, chr) +import GHC.Prim +import GHC.Ptr (Ptr(..)) +import GHC.IOBase (IO(..)) + +instance Binary Integer where + put (S# i) = putWord8 0 >> put (I# i) + put (J# s ba) = do + putWord8 1 + put (I# s) + put (BA ba) + + get = do + b <- getWord8 + case b of + 0 -> do (I# i#) <- get + return (S# i#) + _ -> do (I# s#) <- get + (BA a#) <- get + return (J# s# a#) + +instance Binary ByteArray where + + -- Pretty safe. + put (BA ba) = + let sz = sizeofByteArray# ba -- (primitive) in *bytes* + addr = byteArrayContents# ba + bs = unsafePackAddress (I# sz) addr + in put bs -- write as a ByteString. easy, yay! + + -- Pretty scary. Should be quick though + get = do + (fp, off, n@(I# sz)) <- liftM toForeignPtr get -- so decode a ByteString + assert (off == 0) $ return $ unsafePerformIO $ do + (MBA arr) <- newByteArray sz -- and copy it into a ByteArray# + let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe? + withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n) + freezeByteArray arr + +-- wrapper for ByteArray# +data ByteArray = BA {-# UNPACK #-} !ByteArray# +data MBA = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld) + +newByteArray :: Int# -> IO MBA +newByteArray sz = IO $ \s -> + case newPinnedByteArray# sz s of { (# s', arr #) -> + (# s', MBA arr #) } + +freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray# arr s of { (# s', arr' #) -> + (# s', BA arr' #) } + +-} + +instance (Binary a,Integral a) => Binary (R.Ratio a) where + put r = put (R.numerator r) >> put (R.denominator r) + get = liftM2 (R.%) get get + +------------------------------------------------------------------------ + +-- Char is serialised as UTF-8 +instance Binary Char where + put a | c <= 0x7f = put (fromIntegral c :: Word8) + | c <= 0x7ff = do put (0xc0 .|. y) + put (0x80 .|. z) + | c <= 0xffff = do put (0xe0 .|. x) + put (0x80 .|. y) + put (0x80 .|. z) + | c <= 0x10ffff = do put (0xf0 .|. w) + put (0x80 .|. x) + put (0x80 .|. y) + put (0x80 .|. z) + | otherwise = error "Not a valid Unicode code point" + where + c = ord a + z, y, x, w :: Word8 + z = fromIntegral (c .&. 0x3f) + y = fromIntegral (shiftR c 6 .&. 0x3f) + x = fromIntegral (shiftR c 12 .&. 0x3f) + w = fromIntegral (shiftR c 18 .&. 0x7) + + get = do + let getByte = liftM (fromIntegral :: Word8 -> Int) get + shiftL6 = flip shiftL 6 :: Int -> Int + w <- getByte + r <- case () of + _ | w < 0x80 -> return w + | w < 0xe0 -> do + x <- liftM (xor 0x80) getByte + return (x .|. shiftL6 (xor 0xc0 w)) + | w < 0xf0 -> do + x <- liftM (xor 0x80) getByte + y <- liftM (xor 0x80) getByte + return (y .|. shiftL6 (x .|. shiftL6 + (xor 0xe0 w))) + | otherwise -> do + x <- liftM (xor 0x80) getByte + y <- liftM (xor 0x80) getByte + z <- liftM (xor 0x80) getByte + return (z .|. shiftL6 (y .|. shiftL6 + (x .|. shiftL6 (xor 0xf0 w)))) + return $! chr r + +------------------------------------------------------------------------ +-- Instances for the first few tuples + +instance (Binary a, Binary b) => Binary (a,b) where + put (a,b) = put a >> put b + get = liftM2 (,) get get + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + put (a,b,c) = put a >> put b >> put c + get = liftM3 (,,) get get get + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + put (a,b,c,d) = put a >> put b >> put c >> put d + get = liftM4 (,,,) get get get get + +instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where + put (a,b,c,d,e) = put a >> put b >> put c >> put d >> put e + get = liftM5 (,,,,) get get get get get + +-- +-- and now just recurse: +-- + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) + => Binary (a,b,c,d,e,f) where + put (a,b,c,d,e,f) = put (a,(b,c,d,e,f)) + get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) + => Binary (a,b,c,d,e,f,g) where + put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g)) + get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, + Binary f, Binary g, Binary h) + => Binary (a,b,c,d,e,f,g,h) where + put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h)) + get = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, + Binary f, Binary g, Binary h, Binary i) + => Binary (a,b,c,d,e,f,g,h,i) where + put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i)) + get = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, + Binary f, Binary g, Binary h, Binary i, Binary j) + => Binary (a,b,c,d,e,f,g,h,i,j) where + put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j)) + get = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j) + +------------------------------------------------------------------------ +-- Container types + +instance Binary a => Binary [a] where + put l = put (length l) >> mapM_ put l + get = do n <- get :: Get Int + xs <- replicateM n get + return xs + +instance (Binary a) => Binary (Maybe a) where + put Nothing = putWord8 0 + put (Just x) = putWord8 1 >> put x + get = do + w <- getWord8 + case w of + 0 -> return Nothing + _ -> liftM Just get + +instance (Binary a, Binary b) => Binary (Either a b) where + put (Left a) = putWord8 0 >> put a + put (Right b) = putWord8 1 >> put b + get = do + w <- getWord8 + case w of + 0 -> liftM Left get + _ -> liftM Right get + +------------------------------------------------------------------------ +-- ByteStrings (have specially efficient instances) + +instance Binary B.ByteString where + put bs = do put (B.length bs) + putByteString bs + get = get >>= getByteString + +-- +-- Using old versions of fps, this is a type synonym, and non portable +-- +-- Requires 'flexible instances' +-- +instance Binary ByteString where + put bs = do put (fromIntegral (L.length bs) :: Int) + putLazyByteString bs + get = get >>= getLazyByteString + +------------------------------------------------------------------------ +-- Maps and Sets + +instance (Ord a, Binary a) => Binary (Set.Set a) where + put s = put (Set.size s) >> mapM_ put (Set.toAscList s) + get = liftM Set.fromDistinctAscList get + +instance (Ord k, Binary k, Binary e) => Binary (Map.Map k e) where + put m = put (Map.size m) >> mapM_ put (Map.toAscList m) + get = liftM Map.fromDistinctAscList get + +instance Binary IntSet.IntSet where + put s = put (IntSet.size s) >> mapM_ put (IntSet.toAscList s) + get = liftM IntSet.fromDistinctAscList get + +instance (Binary e) => Binary (IntMap.IntMap e) where + put m = put (IntMap.size m) >> mapM_ put (IntMap.toAscList m) + get = liftM IntMap.fromDistinctAscList get + +------------------------------------------------------------------------ +-- Queues and Sequences + +#if __GLASGOW_HASKELL__ >= 606 +-- +-- This is valid Hugs, but you need the most recent Hugs +-- + +instance (Binary e) => Binary (Seq.Seq e) where + put s = put (Seq.length s) >> Fold.mapM_ put s + get = do n <- get :: Get Int + rep Seq.empty n get + where rep xs 0 _ = return $! xs + rep xs n g = xs `seq` n `seq` do + x <- g + rep (xs Seq.|> x) (n-1) g + +#endif + +------------------------------------------------------------------------ +-- Floating point + +instance Binary Double where + put d = put (decodeFloat d) + get = liftM2 encodeFloat get get + +instance Binary Float where + put f = put (decodeFloat f) + get = liftM2 encodeFloat get get + +------------------------------------------------------------------------ +-- Trees + +instance (Binary e) => Binary (T.Tree e) where + put (T.Node r s) = put r >> put s + get = liftM2 T.Node get get + +------------------------------------------------------------------------ +-- Arrays + +instance (Binary i, Ix i, Binary e) => Binary (Array i e) where + put a = do + put (bounds a) + put (rangeSize $ bounds a) -- write the length + mapM_ put (elems a) -- now the elems. + get = do + bs <- get + n <- get -- read the length + xs <- replicateM n get -- now the elems. + return (listArray bs xs) + +-- +-- The IArray UArray e constraint is non portable. Requires flexible instances +-- +instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where + put a = do + put (bounds a) + put (rangeSize $ bounds a) -- now write the length + mapM_ put (elems a) + get = do + bs <- get + n <- get + xs <- replicateM n get + return (listArray bs xs) diff --git a/src/runtime/haskell/Data/Binary/Builder.hs b/src/runtime/haskell/Data/Binary/Builder.hs new file mode 100644 index 000000000..cccbe6fa4 --- /dev/null +++ b/src/runtime/haskell/Data/Binary/Builder.hs @@ -0,0 +1,426 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fglasgow-exts #-} +-- for unboxed shifts + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Builder +-- Copyright : Lennart Kolmodin, Ross Paterson +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Lennart Kolmodin +-- Stability : experimental +-- Portability : portable to Hugs and GHC +-- +-- Efficient construction of lazy bytestrings. +-- +----------------------------------------------------------------------------- + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif + +module Data.Binary.Builder ( + + -- * The Builder type + Builder + , toLazyByteString + + -- * Constructing Builders + , empty + , singleton + , append + , fromByteString -- :: S.ByteString -> Builder + , fromLazyByteString -- :: L.ByteString -> Builder + + -- * Flushing the buffer state + , flush + + -- * Derived Builders + -- ** Big-endian writes + , putWord16be -- :: Word16 -> Builder + , putWord32be -- :: Word32 -> Builder + , putWord64be -- :: Word64 -> Builder + + -- ** Little-endian writes + , putWord16le -- :: Word16 -> Builder + , putWord32le -- :: Word32 -> Builder + , putWord64le -- :: Word64 -> Builder + + -- ** Host-endian, unaligned writes + , putWordhost -- :: Word -> Builder + , putWord16host -- :: Word16 -> Builder + , putWord32host -- :: Word32 -> Builder + , putWord64host -- :: Word64 -> Builder + + ) where + +import Foreign +import Data.Monoid +import Data.Word +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +#ifdef BYTESTRING_IN_BASE +import Data.ByteString.Base (inlinePerformIO) +import qualified Data.ByteString.Base as S +#else +import Data.ByteString.Internal (inlinePerformIO) +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L +#endif + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +import GHC.Base +import GHC.Word (Word32(..),Word16(..),Word64(..)) + +#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608 +import GHC.Word (uncheckedShiftRL64#) +#endif +#endif + +------------------------------------------------------------------------ + +-- | A 'Builder' is an efficient way to build lazy 'L.ByteString's. +-- There are several functions for constructing 'Builder's, but only one +-- to inspect them: to extract any data, you have to turn them into lazy +-- 'L.ByteString's using 'toLazyByteString'. +-- +-- Internally, a 'Builder' constructs a lazy 'L.Bytestring' by filling byte +-- arrays piece by piece. As each buffer is filled, it is \'popped\' +-- off, to become a new chunk of the resulting lazy 'L.ByteString'. +-- All this is hidden from the user of the 'Builder'. + +newtype Builder = Builder { + -- Invariant (from Data.ByteString.Lazy): + -- The lists include no null ByteStrings. + runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString] + } + +instance Monoid Builder where + mempty = empty + {-# INLINE mempty #-} + mappend = append + {-# INLINE mappend #-} + +------------------------------------------------------------------------ + +-- | /O(1)./ The empty Builder, satisfying +-- +-- * @'toLazyByteString' 'empty' = 'L.empty'@ +-- +empty :: Builder +empty = Builder id +{-# INLINE empty #-} + +-- | /O(1)./ A Builder taking a single byte, satisfying +-- +-- * @'toLazyByteString' ('singleton' b) = 'L.singleton' b@ +-- +singleton :: Word8 -> Builder +singleton = writeN 1 . flip poke +{-# INLINE singleton #-} + +------------------------------------------------------------------------ + +-- | /O(1)./ The concatenation of two Builders, an associative operation +-- with identity 'empty', satisfying +-- +-- * @'toLazyByteString' ('append' x y) = 'L.append' ('toLazyByteString' x) ('toLazyByteString' y)@ +-- +append :: Builder -> Builder -> Builder +append (Builder f) (Builder g) = Builder (f . g) +{-# INLINE append #-} + +-- | /O(1)./ A Builder taking a 'S.ByteString', satisfying +-- +-- * @'toLazyByteString' ('fromByteString' bs) = 'L.fromChunks' [bs]@ +-- +fromByteString :: S.ByteString -> Builder +fromByteString bs + | S.null bs = empty + | otherwise = flush `append` mapBuilder (bs :) +{-# INLINE fromByteString #-} + +-- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying +-- +-- * @'toLazyByteString' ('fromLazyByteString' bs) = bs@ +-- +fromLazyByteString :: L.ByteString -> Builder +fromLazyByteString bss = flush `append` mapBuilder (L.toChunks bss ++) +{-# INLINE fromLazyByteString #-} + +------------------------------------------------------------------------ + +-- Our internal buffer type +data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) + {-# UNPACK #-} !Int -- offset + {-# UNPACK #-} !Int -- used bytes + {-# UNPACK #-} !Int -- length left + +------------------------------------------------------------------------ + +-- | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'. +-- The construction work takes place if and when the relevant part of +-- the lazy 'L.ByteString' is demanded. +-- +toLazyByteString :: Builder -> L.ByteString +toLazyByteString m = L.fromChunks $ unsafePerformIO $ do + buf <- newBuffer defaultSize + return (runBuilder (m `append` flush) (const []) buf) + +-- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any, +-- yielding a new chunk in the result lazy 'L.ByteString'. +flush :: Builder +flush = Builder $ \ k buf@(Buffer p o u l) -> + if u == 0 + then k buf + else S.PS p o u : k (Buffer p (o+u) 0 l) + +------------------------------------------------------------------------ + +-- +-- copied from Data.ByteString.Lazy +-- +defaultSize :: Int +defaultSize = 32 * k - overhead + where k = 1024 + overhead = 2 * sizeOf (undefined :: Int) + +------------------------------------------------------------------------ + +-- | Sequence an IO operation on the buffer +unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder +unsafeLiftIO f = Builder $ \ k buf -> inlinePerformIO $ do + buf' <- f buf + return (k buf') +{-# INLINE unsafeLiftIO #-} + +-- | Get the size of the buffer +withSize :: (Int -> Builder) -> Builder +withSize f = Builder $ \ k buf@(Buffer _ _ _ l) -> + runBuilder (f l) k buf + +-- | Map the resulting list of bytestrings. +mapBuilder :: ([S.ByteString] -> [S.ByteString]) -> Builder +mapBuilder f = Builder (f .) + +------------------------------------------------------------------------ + +-- | Ensure that there are at least @n@ many bytes available. +ensureFree :: Int -> Builder +ensureFree n = n `seq` withSize $ \ l -> + if n <= l then empty else + flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize))) +{-# INLINE ensureFree #-} + +-- | Ensure that @n@ many bytes are available, and then use @f@ to write some +-- bytes into the memory. +writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder +writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f) +{-# INLINE writeN #-} + +writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer +writeNBuffer n f (Buffer fp o u l) = do + withForeignPtr fp (\p -> f (p `plusPtr` (o+u))) + return (Buffer fp o (u+n) (l-n)) +{-# INLINE writeNBuffer #-} + +newBuffer :: Int -> IO Buffer +newBuffer size = do + fp <- S.mallocByteString size + return $! Buffer fp 0 0 size +{-# INLINE newBuffer #-} + +------------------------------------------------------------------------ +-- Aligned, host order writes of storable values + +-- | Ensure that @n@ many bytes are available, and then use @f@ to write some +-- storable values into the memory. +writeNbytes :: Storable a => Int -> (Ptr a -> IO ()) -> Builder +writeNbytes n f = ensureFree n `append` unsafeLiftIO (writeNBufferBytes n f) +{-# INLINE writeNbytes #-} + +writeNBufferBytes :: Storable a => Int -> (Ptr a -> IO ()) -> Buffer -> IO Buffer +writeNBufferBytes n f (Buffer fp o u l) = do + withForeignPtr fp (\p -> f (p `plusPtr` (o+u))) + return (Buffer fp o (u+n) (l-n)) +{-# INLINE writeNBufferBytes #-} + +------------------------------------------------------------------------ + +-- +-- We rely on the fromIntegral to do the right masking for us. +-- The inlining here is critical, and can be worth 4x performance +-- + +-- | Write a Word16 in big endian format +putWord16be :: Word16 -> Builder +putWord16be w = writeN 2 $ \p -> do + poke p (fromIntegral (shiftr_w16 w 8) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (w) :: Word8) +{-# INLINE putWord16be #-} + +-- | Write a Word16 in little endian format +putWord16le :: Word16 -> Builder +putWord16le w = writeN 2 $ \p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8) +{-# INLINE putWord16le #-} + +-- putWord16le w16 = writeN 2 (\p -> poke (castPtr p) w16) + +-- | Write a Word32 in big endian format +putWord32be :: Word32 -> Builder +putWord32be w = writeN 4 $ \p -> do + poke p (fromIntegral (shiftr_w32 w 24) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (w) :: Word8) +{-# INLINE putWord32be #-} + +-- +-- a data type to tag Put/Check. writes construct these which are then +-- inlined and flattened. matching Checks will be more robust with rules. +-- + +-- | Write a Word32 in little endian format +putWord32le :: Word32 -> Builder +putWord32le w = writeN 4 $ \p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 w 24) :: Word8) +{-# INLINE putWord32le #-} + +-- on a little endian machine: +-- putWord32le w32 = writeN 4 (\p -> poke (castPtr p) w32) + +-- | Write a Word64 in big endian format +putWord64be :: Word64 -> Builder +#if WORD_SIZE_IN_BITS < 64 +-- +-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to +-- Word32, and write that +-- +putWord64be w = + let a = fromIntegral (shiftr_w64 w 32) :: Word32 + b = fromIntegral w :: Word32 + in writeN 8 $ \p -> do + poke p (fromIntegral (shiftr_w32 a 24) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (a) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (b) :: Word8) +#else +putWord64be w = writeN 8 $ \p -> do + poke p (fromIntegral (shiftr_w64 w 56) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 8) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (w) :: Word8) +#endif +{-# INLINE putWord64be #-} + +-- | Write a Word64 in little endian format +putWord64le :: Word64 -> Builder + +#if WORD_SIZE_IN_BITS < 64 +putWord64le w = + let b = fromIntegral (shiftr_w64 w 32) :: Word32 + a = fromIntegral w :: Word32 + in writeN 8 $ \p -> do + poke (p) (fromIntegral (a) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (b) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 8) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8) +#else +putWord64le w = writeN 8 $ \p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 24) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 32) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 40) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 48) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (shiftr_w64 w 56) :: Word8) +#endif +{-# INLINE putWord64le #-} + +-- on a little endian machine: +-- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64) + +------------------------------------------------------------------------ +-- Unaligned, word size ops + +-- | /O(1)./ A Builder taking a single native machine word. The word is +-- written in host order, host endian form, for the machine you're on. +-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine, +-- 4 bytes. Values written this way are not portable to +-- different endian or word sized machines, without conversion. +-- +putWordhost :: Word -> Builder +putWordhost w = writeNbytes (sizeOf (undefined :: Word)) (\p -> poke p w) +{-# INLINE putWordhost #-} + +-- | Write a Word16 in native host order and host endianness. +-- 2 bytes will be written, unaligned. +putWord16host :: Word16 -> Builder +putWord16host w16 = writeNbytes (sizeOf (undefined :: Word16)) (\p -> poke p w16) +{-# INLINE putWord16host #-} + +-- | Write a Word32 in native host order and host endianness. +-- 4 bytes will be written, unaligned. +putWord32host :: Word32 -> Builder +putWord32host w32 = writeNbytes (sizeOf (undefined :: Word32)) (\p -> poke p w32) +{-# INLINE putWord32host #-} + +-- | Write a Word64 in native host order. +-- On a 32 bit machine we write two host order Word32s, in big endian form. +-- 8 bytes will be written, unaligned. +putWord64host :: Word64 -> Builder +putWord64host w = writeNbytes (sizeOf (undefined :: Word64)) (\p -> poke p w) +{-# INLINE putWord64host #-} + +------------------------------------------------------------------------ +-- Unchecked shifts + +{-# INLINE shiftr_w16 #-} +shiftr_w16 :: Word16 -> Int -> Word16 +{-# INLINE shiftr_w32 #-} +shiftr_w32 :: Word32 -> Int -> Word32 +{-# INLINE shiftr_w64 #-} +shiftr_w64 :: Word64 -> Int -> Word64 + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i) +shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) + +#if WORD_SIZE_IN_BITS < 64 +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i) + +#if __GLASGOW_HASKELL__ <= 606 +-- Exported by GHC.Word in GHC 6.8 and higher +foreign import ccall unsafe "stg_uncheckedShiftRL64" + uncheckedShiftRL64# :: Word64# -> Int# -> Word64# +#endif + +#else +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i) +#endif + +#else +shiftr_w16 = shiftR +shiftr_w32 = shiftR +shiftr_w64 = shiftR +#endif diff --git a/src/runtime/haskell/Data/Binary/Get.hs b/src/runtime/haskell/Data/Binary/Get.hs new file mode 100644 index 000000000..51062ad31 --- /dev/null +++ b/src/runtime/haskell/Data/Binary/Get.hs @@ -0,0 +1,544 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fglasgow-exts #-} +-- for unboxed shifts + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Get +-- Copyright : Lennart Kolmodin +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Lennart Kolmodin +-- Stability : experimental +-- Portability : portable to Hugs and GHC. +-- +-- The Get monad. A monad for efficiently building structures from +-- encoded lazy ByteStrings +-- +----------------------------------------------------------------------------- + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif + +module Data.Binary.Get ( + + -- * The Get type + Get + , runGet + , runGetState + + -- * Parsing + , skip + , uncheckedSkip + , lookAhead + , lookAheadM + , lookAheadE + , uncheckedLookAhead + + -- * Utility + , bytesRead + , getBytes + , remaining + , isEmpty + + -- * Parsing particular types + , getWord8 + + -- ** ByteStrings + , getByteString + , getLazyByteString + , getLazyByteStringNul + , getRemainingLazyByteString + + -- ** Big-endian reads + , getWord16be + , getWord32be + , getWord64be + + -- ** Little-endian reads + , getWord16le + , getWord32le + , getWord64le + + -- ** Host-endian, unaligned reads + , getWordhost + , getWord16host + , getWord32host + , getWord64host + + ) where + +import Control.Monad (when,liftM,ap) +import Control.Monad.Fix +import Data.Maybe (isNothing) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +#ifdef BYTESTRING_IN_BASE +import qualified Data.ByteString.Base as B +#else +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Lazy.Internal as L +#endif + +#ifdef APPLICATIVE_IN_BASE +import Control.Applicative (Applicative(..)) +#endif + +import Foreign + +-- used by splitAtST +import Control.Monad.ST +import Data.STRef + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +import GHC.Base +import GHC.Word +import GHC.Int +#endif + +-- | The parse state +data S = S {-# UNPACK #-} !B.ByteString -- current chunk + L.ByteString -- the rest of the input + {-# UNPACK #-} !Int64 -- bytes read + +-- | The Get monad is just a State monad carrying around the input ByteString +newtype Get a = Get { unGet :: S -> (a, S) } + +instance Functor Get where + fmap f m = Get (\s -> case unGet m s of + (a, s') -> (f a, s')) + {-# INLINE fmap #-} + +#ifdef APPLICATIVE_IN_BASE +instance Applicative Get where + pure = return + (<*>) = ap +#endif + +instance Monad Get where + return a = Get (\s -> (a, s)) + {-# INLINE return #-} + + m >>= k = Get (\s -> case unGet m s of + (a, s') -> unGet (k a) s') + {-# INLINE (>>=) #-} + + fail = failDesc + +instance MonadFix Get where + mfix f = Get (\s -> let (a,s') = unGet (f a) s + in (a,s')) + +------------------------------------------------------------------------ + +get :: Get S +get = Get (\s -> (s, s)) + +put :: S -> Get () +put s = Get (\_ -> ((), s)) + +------------------------------------------------------------------------ +-- +-- dons, GHC 6.10: explicit inlining disabled, was killing performance. +-- Without it, GHC seems to do just fine. And we get similar +-- performance with 6.8.2 anyway. +-- + +initState :: L.ByteString -> S +initState xs = mkState xs 0 +{- INLINE initState -} + +{- +initState (B.LPS xs) = + case xs of + [] -> S B.empty L.empty 0 + (x:xs') -> S x (B.LPS xs') 0 +-} + +#ifndef BYTESTRING_IN_BASE +mkState :: L.ByteString -> Int64 -> S +mkState l = case l of + L.Empty -> S B.empty L.empty + L.Chunk x xs -> S x xs +{- INLINE mkState -} + +#else +mkState :: L.ByteString -> Int64 -> S +mkState (B.LPS xs) = + case xs of + [] -> S B.empty L.empty + (x:xs') -> S x (B.LPS xs') +#endif + +-- | Run the Get monad applies a 'get'-based parser on the input ByteString +runGet :: Get a -> L.ByteString -> a +runGet m str = case unGet m (initState str) of (a, _) -> a + +-- | Run the Get monad applies a 'get'-based parser on the input +-- ByteString. Additional to the result of get it returns the number of +-- consumed bytes and the rest of the input. +runGetState :: Get a -> L.ByteString -> Int64 -> (a, L.ByteString, Int64) +runGetState m str off = + case unGet m (mkState str off) of + (a, ~(S s ss newOff)) -> (a, s `join` ss, newOff) + +------------------------------------------------------------------------ + +failDesc :: String -> Get a +failDesc err = do + S _ _ bytes <- get + Get (error (err ++ ". Failed reading at byte position " ++ show bytes)) + +-- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. +skip :: Int -> Get () +skip n = readN (fromIntegral n) (const ()) + +-- | Skip ahead @n@ bytes. No error if there isn't enough bytes. +uncheckedSkip :: Int64 -> Get () +uncheckedSkip n = do + S s ss bytes <- get + if fromIntegral (B.length s) >= n + then put (S (B.drop (fromIntegral n) s) ss (bytes + n)) + else do + let rest = L.drop (n - fromIntegral (B.length s)) ss + put $! mkState rest (bytes + n) + +-- | Run @ga@, but return without consuming its input. +-- Fails if @ga@ fails. +lookAhead :: Get a -> Get a +lookAhead ga = do + s <- get + a <- ga + put s + return a + +-- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'. +-- Fails if @gma@ fails. +lookAheadM :: Get (Maybe a) -> Get (Maybe a) +lookAheadM gma = do + s <- get + ma <- gma + when (isNothing ma) $ + put s + return ma + +-- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'. +-- Fails if @gea@ fails. +lookAheadE :: Get (Either a b) -> Get (Either a b) +lookAheadE gea = do + s <- get + ea <- gea + case ea of + Left _ -> put s + _ -> return () + return ea + +-- | Get the next up to @n@ bytes as a lazy ByteString, without consuming them. +uncheckedLookAhead :: Int64 -> Get L.ByteString +uncheckedLookAhead n = do + S s ss _ <- get + if n <= fromIntegral (B.length s) + then return (L.fromChunks [B.take (fromIntegral n) s]) + else return $ L.take n (s `join` ss) + +------------------------------------------------------------------------ +-- Utility + +-- | Get the total number of bytes read to this point. +bytesRead :: Get Int64 +bytesRead = do + S _ _ b <- get + return b + +-- | Get the number of remaining unparsed bytes. +-- Useful for checking whether all input has been consumed. +-- Note that this forces the rest of the input. +remaining :: Get Int64 +remaining = do + S s ss _ <- get + return (fromIntegral (B.length s) + L.length ss) + +-- | Test whether all input has been consumed, +-- i.e. there are no remaining unparsed bytes. +isEmpty :: Get Bool +isEmpty = do + S s ss _ <- get + return (B.null s && L.null ss) + +------------------------------------------------------------------------ +-- Utility with ByteStrings + +-- | An efficient 'get' method for strict ByteStrings. Fails if fewer +-- than @n@ bytes are left in the input. +getByteString :: Int -> Get B.ByteString +getByteString n = readN n id +{-# INLINE getByteString #-} + +-- | An efficient 'get' method for lazy ByteStrings. Does not fail if fewer than +-- @n@ bytes are left in the input. +getLazyByteString :: Int64 -> Get L.ByteString +getLazyByteString n = do + S s ss bytes <- get + let big = s `join` ss + case splitAtST n big of + (consume, rest) -> do put $ mkState rest (bytes + n) + return consume +{-# INLINE getLazyByteString #-} + +-- | Get a lazy ByteString that is terminated with a NUL byte. Fails +-- if it reaches the end of input without hitting a NUL. +getLazyByteStringNul :: Get L.ByteString +getLazyByteStringNul = do + S s ss bytes <- get + let big = s `join` ss + (consume, t) = L.break (== 0) big + (h, rest) = L.splitAt 1 t + if L.null h + then fail "too few bytes" + else do + put $ mkState rest (bytes + L.length consume + 1) + return consume +{-# INLINE getLazyByteStringNul #-} + +-- | Get the remaining bytes as a lazy ByteString +getRemainingLazyByteString :: Get L.ByteString +getRemainingLazyByteString = do + S s ss _ <- get + return (s `join` ss) + +------------------------------------------------------------------------ +-- Helpers + +-- | Pull @n@ bytes from the input, as a strict ByteString. +getBytes :: Int -> Get B.ByteString +getBytes n = do + S s ss bytes <- get + if n <= B.length s + then do let (consume,rest) = B.splitAt n s + put $! S rest ss (bytes + fromIntegral n) + return $! consume + else + case L.splitAt (fromIntegral n) (s `join` ss) of + (consuming, rest) -> + do let now = B.concat . L.toChunks $ consuming + put $! mkState rest (bytes + fromIntegral n) + -- forces the next chunk before this one is returned + if (B.length now < n) + then + fail "too few bytes" + else + return now +{- INLINE getBytes -} +-- ^ important + +#ifndef BYTESTRING_IN_BASE +join :: B.ByteString -> L.ByteString -> L.ByteString +join bb lb + | B.null bb = lb + | otherwise = L.Chunk bb lb + +#else +join :: B.ByteString -> L.ByteString -> L.ByteString +join bb (B.LPS lb) + | B.null bb = B.LPS lb + | otherwise = B.LPS (bb:lb) +#endif + -- don't use L.append, it's strict in it's second argument :/ +{- INLINE join -} + +-- | Split a ByteString. If the first result is consumed before the -- +-- second, this runs in constant heap space. +-- +-- You must force the returned tuple for that to work, e.g. +-- +-- > case splitAtST n xs of +-- > (ys,zs) -> consume ys ... consume zs +-- +splitAtST :: Int64 -> L.ByteString -> (L.ByteString, L.ByteString) +splitAtST i ps | i <= 0 = (L.empty, ps) +#ifndef BYTESTRING_IN_BASE +splitAtST i ps = runST ( + do r <- newSTRef undefined + xs <- first r i ps + ys <- unsafeInterleaveST (readSTRef r) + return (xs, ys)) + + where + first r 0 xs@(L.Chunk _ _) = writeSTRef r xs >> return L.Empty + first r _ L.Empty = writeSTRef r L.Empty >> return L.Empty + + first r n (L.Chunk x xs) + | n < l = do writeSTRef r (L.Chunk (B.drop (fromIntegral n) x) xs) + return $ L.Chunk (B.take (fromIntegral n) x) L.Empty + | otherwise = do writeSTRef r (L.drop (n - l) xs) + liftM (L.Chunk x) $ unsafeInterleaveST (first r (n - l) xs) + + where l = fromIntegral (B.length x) +#else +splitAtST i (B.LPS ps) = runST ( + do r <- newSTRef undefined + xs <- first r i ps + ys <- unsafeInterleaveST (readSTRef r) + return (B.LPS xs, B.LPS ys)) + + where first r 0 xs = writeSTRef r xs >> return [] + first r _ [] = writeSTRef r [] >> return [] + first r n (x:xs) + | n < l = do writeSTRef r (B.drop (fromIntegral n) x : xs) + return [B.take (fromIntegral n) x] + | otherwise = do writeSTRef r (L.toChunks (L.drop (n - l) (B.LPS xs))) + fmap (x:) $ unsafeInterleaveST (first r (n - l) xs) + + where l = fromIntegral (B.length x) +#endif +{- INLINE splitAtST -} + +-- Pull n bytes from the input, and apply a parser to those bytes, +-- yielding a value. If less than @n@ bytes are available, fail with an +-- error. This wraps @getBytes@. +readN :: Int -> (B.ByteString -> a) -> Get a +readN n f = fmap f $ getBytes n +{- INLINE readN -} +-- ^ important + +------------------------------------------------------------------------ +-- Primtives + +-- helper, get a raw Ptr onto a strict ByteString copied out of the +-- underlying lazy byteString. So many indirections from the raw parser +-- state that my head hurts... + +getPtr :: Storable a => Int -> Get a +getPtr n = do + (fp,o,_) <- readN n B.toForeignPtr + return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o) +{- INLINE getPtr -} + +------------------------------------------------------------------------ + +-- | Read a Word8 from the monad state +getWord8 :: Get Word8 +getWord8 = getPtr (sizeOf (undefined :: Word8)) +{- INLINE getWord8 -} + +-- | Read a Word16 in big endian format +getWord16be :: Get Word16 +getWord16be = do + s <- readN 2 id + return $! (fromIntegral (s `B.index` 0) `shiftl_w16` 8) .|. + (fromIntegral (s `B.index` 1)) +{- INLINE getWord16be -} + +-- | Read a Word16 in little endian format +getWord16le :: Get Word16 +getWord16le = do + s <- readN 2 id + return $! (fromIntegral (s `B.index` 1) `shiftl_w16` 8) .|. + (fromIntegral (s `B.index` 0) ) +{- INLINE getWord16le -} + +-- | Read a Word32 in big endian format +getWord32be :: Get Word32 +getWord32be = do + s <- readN 4 id + return $! (fromIntegral (s `B.index` 0) `shiftl_w32` 24) .|. + (fromIntegral (s `B.index` 1) `shiftl_w32` 16) .|. + (fromIntegral (s `B.index` 2) `shiftl_w32` 8) .|. + (fromIntegral (s `B.index` 3) ) +{- INLINE getWord32be -} + +-- | Read a Word32 in little endian format +getWord32le :: Get Word32 +getWord32le = do + s <- readN 4 id + return $! (fromIntegral (s `B.index` 3) `shiftl_w32` 24) .|. + (fromIntegral (s `B.index` 2) `shiftl_w32` 16) .|. + (fromIntegral (s `B.index` 1) `shiftl_w32` 8) .|. + (fromIntegral (s `B.index` 0) ) +{- INLINE getWord32le -} + +-- | Read a Word64 in big endian format +getWord64be :: Get Word64 +getWord64be = do + s <- readN 8 id + return $! (fromIntegral (s `B.index` 0) `shiftl_w64` 56) .|. + (fromIntegral (s `B.index` 1) `shiftl_w64` 48) .|. + (fromIntegral (s `B.index` 2) `shiftl_w64` 40) .|. + (fromIntegral (s `B.index` 3) `shiftl_w64` 32) .|. + (fromIntegral (s `B.index` 4) `shiftl_w64` 24) .|. + (fromIntegral (s `B.index` 5) `shiftl_w64` 16) .|. + (fromIntegral (s `B.index` 6) `shiftl_w64` 8) .|. + (fromIntegral (s `B.index` 7) ) +{- INLINE getWord64be -} + +-- | Read a Word64 in little endian format +getWord64le :: Get Word64 +getWord64le = do + s <- readN 8 id + return $! (fromIntegral (s `B.index` 7) `shiftl_w64` 56) .|. + (fromIntegral (s `B.index` 6) `shiftl_w64` 48) .|. + (fromIntegral (s `B.index` 5) `shiftl_w64` 40) .|. + (fromIntegral (s `B.index` 4) `shiftl_w64` 32) .|. + (fromIntegral (s `B.index` 3) `shiftl_w64` 24) .|. + (fromIntegral (s `B.index` 2) `shiftl_w64` 16) .|. + (fromIntegral (s `B.index` 1) `shiftl_w64` 8) .|. + (fromIntegral (s `B.index` 0) ) +{- INLINE getWord64le -} + +------------------------------------------------------------------------ +-- Host-endian reads + +-- | /O(1)./ Read a single native machine word. The word is read in +-- host order, host endian form, for the machine you're on. On a 64 bit +-- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes. +getWordhost :: Get Word +getWordhost = getPtr (sizeOf (undefined :: Word)) +{- INLINE getWordhost -} + +-- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness. +getWord16host :: Get Word16 +getWord16host = getPtr (sizeOf (undefined :: Word16)) +{- INLINE getWord16host -} + +-- | /O(1)./ Read a Word32 in native host order and host endianness. +getWord32host :: Get Word32 +getWord32host = getPtr (sizeOf (undefined :: Word32)) +{- INLINE getWord32host -} + +-- | /O(1)./ Read a Word64 in native host order and host endianess. +getWord64host :: Get Word64 +getWord64host = getPtr (sizeOf (undefined :: Word64)) +{- INLINE getWord64host -} + +------------------------------------------------------------------------ +-- Unchecked shifts + +shiftl_w16 :: Word16 -> Int -> Word16 +shiftl_w32 :: Word32 -> Int -> Word32 +shiftl_w64 :: Word64 -> Int -> Word64 + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i) +shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i) + +#if WORD_SIZE_IN_BITS < 64 +shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i) + +#if __GLASGOW_HASKELL__ <= 606 +-- Exported by GHC.Word in GHC 6.8 and higher +foreign import ccall unsafe "stg_uncheckedShiftL64" + uncheckedShiftL64# :: Word64# -> Int# -> Word64# +#endif + +#else +shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i) +#endif + +#else +shiftl_w16 = shiftL +shiftl_w32 = shiftL +shiftl_w64 = shiftL +#endif diff --git a/src/runtime/haskell/Data/Binary/Put.hs b/src/runtime/haskell/Data/Binary/Put.hs new file mode 100644 index 000000000..a1f78dfba --- /dev/null +++ b/src/runtime/haskell/Data/Binary/Put.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Put +-- Copyright : Lennart Kolmodin +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Lennart Kolmodin +-- Stability : stable +-- Portability : Portable to Hugs and GHC. Requires MPTCs +-- +-- The Put monad. A monad for efficiently constructing lazy bytestrings. +-- +----------------------------------------------------------------------------- + +module Data.Binary.Put ( + + -- * The Put type + Put + , PutM(..) + , runPut + , runPutM + , putBuilder + , execPut + + -- * Flushing the implicit parse state + , flush + + -- * Primitives + , putWord8 + , putByteString + , putLazyByteString + + -- * Big-endian primitives + , putWord16be + , putWord32be + , putWord64be + + -- * Little-endian primitives + , putWord16le + , putWord32le + , putWord64le + + -- * Host-endian, unaligned writes + , putWordhost -- :: Word -> Put + , putWord16host -- :: Word16 -> Put + , putWord32host -- :: Word32 -> Put + , putWord64host -- :: Word64 -> Put + + ) where + +import Data.Monoid +import Data.Binary.Builder (Builder, toLazyByteString) +import qualified Data.Binary.Builder as B + +import Data.Word +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +#ifdef APPLICATIVE_IN_BASE +import Control.Applicative +#endif + + +------------------------------------------------------------------------ + +-- XXX Strict in buffer only. +data PairS a = PairS a {-# UNPACK #-}!Builder + +sndS :: PairS a -> Builder +sndS (PairS _ b) = b + +-- | The PutM type. A Writer monad over the efficient Builder monoid. +newtype PutM a = Put { unPut :: PairS a } + +-- | Put merely lifts Builder into a Writer monad, applied to (). +type Put = PutM () + +instance Functor PutM where + fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w + {-# INLINE fmap #-} + +#ifdef APPLICATIVE_IN_BASE +instance Applicative PutM where + pure = return + m <*> k = Put $ + let PairS f w = unPut m + PairS x w' = unPut k + in PairS (f x) (w `mappend` w') +#endif + +-- Standard Writer monad, with aggressive inlining +instance Monad PutM where + return a = Put $ PairS a mempty + {-# INLINE return #-} + + m >>= k = Put $ + let PairS a w = unPut m + PairS b w' = unPut (k a) + in PairS b (w `mappend` w') + {-# INLINE (>>=) #-} + + m >> k = Put $ + let PairS _ w = unPut m + PairS b w' = unPut k + in PairS b (w `mappend` w') + {-# INLINE (>>) #-} + +tell :: Builder -> Put +tell b = Put $ PairS () b +{-# INLINE tell #-} + +putBuilder :: Builder -> Put +putBuilder = tell +{-# INLINE putBuilder #-} + +-- | Run the 'Put' monad +execPut :: PutM a -> Builder +execPut = sndS . unPut +{-# INLINE execPut #-} + +-- | Run the 'Put' monad with a serialiser +runPut :: Put -> L.ByteString +runPut = toLazyByteString . sndS . unPut +{-# INLINE runPut #-} + +-- | Run the 'Put' monad with a serialiser and get its result +runPutM :: PutM a -> (a, L.ByteString) +runPutM (Put (PairS f s)) = (f, toLazyByteString s) +{-# INLINE runPutM #-} + +------------------------------------------------------------------------ + +-- | Pop the ByteString we have constructed so far, if any, yielding a +-- new chunk in the result ByteString. +flush :: Put +flush = tell B.flush +{-# INLINE flush #-} + +-- | Efficiently write a byte into the output buffer +putWord8 :: Word8 -> Put +putWord8 = tell . B.singleton +{-# INLINE putWord8 #-} + +-- | An efficient primitive to write a strict ByteString into the output buffer. +-- It flushes the current buffer, and writes the argument into a new chunk. +putByteString :: S.ByteString -> Put +putByteString = tell . B.fromByteString +{-# INLINE putByteString #-} + +-- | Write a lazy ByteString efficiently, simply appending the lazy +-- ByteString chunks to the output buffer +putLazyByteString :: L.ByteString -> Put +putLazyByteString = tell . B.fromLazyByteString +{-# INLINE putLazyByteString #-} + +-- | Write a Word16 in big endian format +putWord16be :: Word16 -> Put +putWord16be = tell . B.putWord16be +{-# INLINE putWord16be #-} + +-- | Write a Word16 in little endian format +putWord16le :: Word16 -> Put +putWord16le = tell . B.putWord16le +{-# INLINE putWord16le #-} + +-- | Write a Word32 in big endian format +putWord32be :: Word32 -> Put +putWord32be = tell . B.putWord32be +{-# INLINE putWord32be #-} + +-- | Write a Word32 in little endian format +putWord32le :: Word32 -> Put +putWord32le = tell . B.putWord32le +{-# INLINE putWord32le #-} + +-- | Write a Word64 in big endian format +putWord64be :: Word64 -> Put +putWord64be = tell . B.putWord64be +{-# INLINE putWord64be #-} + +-- | Write a Word64 in little endian format +putWord64le :: Word64 -> Put +putWord64le = tell . B.putWord64le +{-# INLINE putWord64le #-} + +------------------------------------------------------------------------ + +-- | /O(1)./ Write a single native machine word. The word is +-- written in host order, host endian form, for the machine you're on. +-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine, +-- 4 bytes. Values written this way are not portable to +-- different endian or word sized machines, without conversion. +-- +putWordhost :: Word -> Put +putWordhost = tell . B.putWordhost +{-# INLINE putWordhost #-} + +-- | /O(1)./ Write a Word16 in native host order and host endianness. +-- For portability issues see @putWordhost@. +putWord16host :: Word16 -> Put +putWord16host = tell . B.putWord16host +{-# INLINE putWord16host #-} + +-- | /O(1)./ Write a Word32 in native host order and host endianness. +-- For portability issues see @putWordhost@. +putWord32host :: Word32 -> Put +putWord32host = tell . B.putWord32host +{-# INLINE putWord32host #-} + +-- | /O(1)./ Write a Word64 in native host order +-- On a 32 bit machine we write two host order Word32s, in big endian form. +-- For portability issues see @putWordhost@. +putWord64host :: Word64 -> Put +putWord64host = tell . B.putWord64host +{-# INLINE putWord64host #-} diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs new file mode 100644 index 000000000..6c192095d --- /dev/null +++ b/src/runtime/haskell/PGF.hs @@ -0,0 +1,352 @@ +------------------------------------------------- +-- | +-- Module : PGF +-- Maintainer : Aarne Ranta +-- Stability : stable +-- Portability : portable +-- +-- This module is an Application Programming Interface to +-- load and interpret grammars compiled in Portable Grammar Format (PGF). +-- The PGF format is produced as a final output from the GF compiler. +-- The API is meant to be used for embedding GF grammars in Haskell +-- programs +------------------------------------------------- + +module PGF( + -- * PGF + PGF, + readPGF, + + -- * Identifiers + CId, mkCId, wildCId, + showCId, readCId, + + -- * Languages + Language, + showLanguage, readLanguage, + languages, abstractName, languageCode, + + -- * Types + Type, Hypo, + showType, readType, + mkType, mkHypo, mkDepHypo, mkImplHypo, + categories, startCat, + + -- * Functions + functions, functionType, + + -- * Expressions & Trees + -- ** Tree + Tree, + + -- ** Expr + Expr, + showExpr, readExpr, + mkApp, unApp, + mkStr, unStr, + mkInt, unInt, + mkDouble, unDouble, + mkMeta, isMeta, + + -- * Operations + -- ** Linearization + linearize, linearizeAllLang, linearizeAll, + showPrintName, + + -- ** Parsing + parse, parseWithRecovery, canParse, parseAllLang, parseAll, + + -- ** Evaluation + PGF.compute, paraphrase, + + -- ** Type Checking + -- | The type checker in PGF does both type checking and renaming + -- i.e. it verifies that all identifiers are declared and it + -- distinguishes between global function or type indentifiers and + -- variable names. The type checker should always be applied on + -- expressions entered by the user i.e. those produced via functions + -- like 'readType' and 'readExpr' because otherwise unexpected results + -- could appear. All typechecking functions returns updated versions + -- of the input types or expressions because the typechecking could + -- also lead to metavariables instantiations. + checkType, checkExpr, inferExpr, + TcError(..), ppTcError, + + -- ** Word Completion (Incremental Parsing) + complete, + Incremental.ParseState, + Incremental.initState, Incremental.nextState, Incremental.getCompletions, Incremental.recoveryStates, Incremental.extractTrees, + + -- ** Generation + generateRandom, generateAll, generateAllDepth, + + -- ** Morphological Analysis + Lemma, Analysis, Morpho, + lookupMorpho, buildMorpho, + + -- ** Visualizations + graphvizAbstractTree, + graphvizParseTree, + graphvizDependencyTree, + graphvizAlignment, + + -- * Browsing + browse + ) where + +import PGF.CId +import PGF.Linearize +import PGF.Generate +import PGF.TypeCheck +import PGF.Paraphrase +import PGF.VisualizeTree +import PGF.Macros +import PGF.Expr (Tree) +import PGF.Morphology +import PGF.Data hiding (functions) +import PGF.Binary +import qualified PGF.Parsing.FCFG.Active as Active +import qualified PGF.Parsing.FCFG.Incremental as Incremental +import qualified GF.Compile.GeneratePMCFG as PMCFG + +import GF.Infra.Option +import GF.Data.Utilities (replace) + +import Data.Char +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import Data.Maybe +import Data.Binary +import Data.List(mapAccumL) +import System.Random (newStdGen) +import Control.Monad +import Text.PrettyPrint + +--------------------------------------------------- +-- Interface +--------------------------------------------------- + +-- | Reads file in Portable Grammar Format and produces +-- 'PGF' structure. The file is usually produced with: +-- +-- > $ gf -make +readPGF :: FilePath -> IO PGF + +-- | Linearizes given expression as string in the language +linearize :: PGF -> Language -> Tree -> String + +-- | Tries to parse the given string in the specified language +-- and to produce abstract syntax expression. An empty +-- list is returned if the parsing is not successful. The list may also +-- contain more than one element if the grammar is ambiguous. +-- Throws an exception if the given language cannot be used +-- for parsing, see 'canParse'. +parse :: PGF -> Language -> Type -> String -> [Tree] + +parseWithRecovery :: PGF -> Language -> Type -> [Type] -> String -> [Tree] + +-- | Checks whether the given language can be used for parsing. +canParse :: PGF -> Language -> Bool + +-- | The same as 'linearizeAllLang' but does not return +-- the language. +linearizeAll :: PGF -> Tree -> [String] + +-- | Linearizes given expression as string in all languages +-- available in the grammar. +linearizeAllLang :: PGF -> Tree -> [(Language,String)] + +-- | Show the printname of a type +showPrintName :: PGF -> Language -> Type -> String + +-- | The same as 'parseAllLang' but does not return +-- the language. +parseAll :: PGF -> Type -> String -> [[Tree]] + +-- | Tries to parse the given string with all available languages. +-- Languages which cannot be used for parsing (see 'canParse') +-- are ignored. +-- The returned list contains pairs of language +-- and list of abstract syntax expressions +-- (this is a list, since grammars can be ambiguous). +-- Only those languages +-- for which at least one parsing is possible are listed. +parseAllLang :: PGF -> Type -> String -> [(Language,[Tree])] + +-- | The same as 'generateAllDepth' but does not limit +-- the depth in the generation. +generateAll :: PGF -> Type -> [Expr] + +-- | Generates an infinite list of random abstract syntax expressions. +-- This is usefull for tree bank generation which after that can be used +-- for grammar testing. +generateRandom :: PGF -> Type -> IO [Expr] + +-- | Generates an exhaustive possibly infinite list of +-- abstract syntax expressions. A depth can be specified +-- to limit the search space. +generateAllDepth :: PGF -> Type -> Maybe Int -> [Expr] + +-- | List of all languages available in the given grammar. +languages :: PGF -> [Language] + +-- | Gets the RFC 4646 language tag +-- of the language which the given concrete syntax implements, +-- if this is listed in the source grammar. +-- Example language tags include @\"en\"@ for English, +-- and @\"en-UK\"@ for British English. +languageCode :: PGF -> Language -> Maybe String + +-- | The abstract language name is the name of the top-level +-- abstract module +abstractName :: PGF -> Language + +-- | List of all categories defined in the given grammar. +-- The categories are defined in the abstract syntax +-- with the \'cat\' keyword. +categories :: PGF -> [CId] + +-- | The start category is defined in the grammar with +-- the \'startcat\' flag. This is usually the sentence category +-- but it is not necessary. Despite that there is a start category +-- defined you can parse with any category. The start category +-- definition is just for convenience. +startCat :: PGF -> Type + +-- | List of all functions defined in the abstract syntax +functions :: PGF -> [CId] + +-- | The type of a given function +functionType :: PGF -> CId -> Maybe Type + +-- | Complete the last word in the given string. If the input +-- is empty or ends in whitespace, the last word is considred +-- to be the empty string. This means that the completions +-- will be all possible next words. +complete :: PGF -> Language -> Type -> String + -> [String] -- ^ Possible completions, + -- including the given input. + + +--------------------------------------------------- +-- Implementation +--------------------------------------------------- + +readPGF f = decodeFile f >>= addParsers + +-- Adds parsers for all concretes that don't have a parser and that have parser=ondemand. +addParsers :: PGF -> IO PGF +addParsers pgf = do cncs <- sequence [if wantsParser cnc then addParser lang cnc else return (lang,cnc) + | (lang,cnc) <- Map.toList (concretes pgf)] + return pgf { concretes = Map.fromList cncs } + where + wantsParser cnc = isNothing (parser cnc) && Map.lookup (mkCId "parser") (cflags cnc) == Just "ondemand" + addParser lang cnc = do pinfo <- PMCFG.convertConcrete noOptions (abstract pgf) lang cnc + return (lang,cnc { parser = Just pinfo }) + +linearize pgf lang = concat . take 1 . PGF.Linearize.linearizes pgf lang + +parse pgf lang typ s = + case Map.lookup lang (concretes pgf) of + Just cnc -> case parser cnc of + Just pinfo -> if Map.lookup (mkCId "erasing") (cflags cnc) == Just "on" + then Incremental.parse pgf lang typ (words s) + else Active.parse "t" pinfo typ (words s) + Nothing -> error ("No parser built for language: " ++ showCId lang) + Nothing -> error ("Unknown language: " ++ showCId lang) + +parseWithRecovery pgf lang typ open_typs s = Incremental.parseWithRecovery pgf lang typ open_typs (words s) + +canParse pgf cnc = isJust (lookParser pgf cnc) + +linearizeAll mgr = map snd . linearizeAllLang mgr +linearizeAllLang mgr t = + [(lang,PGF.linearize mgr lang t) | lang <- languages mgr] + +showPrintName pgf lang (DTyp _ c _) = realize $ lookPrintName pgf lang c + +parseAll mgr typ = map snd . parseAllLang mgr typ + +parseAllLang mgr typ s = + [(lang,ts) | lang <- languages mgr, canParse mgr lang, let ts = parse mgr lang typ s, not (null ts)] + +generateRandom pgf cat = do + gen <- newStdGen + return $ genRandom gen pgf cat + +generateAll pgf cat = generate pgf cat Nothing +generateAllDepth pgf cat = generate pgf cat + +abstractName pgf = absname pgf + +languages pgf = cncnames pgf + +languageCode pgf lang = + fmap (replace '_' '-') $ lookConcrFlag pgf lang (mkCId "language") + +categories pgf = [c | (c,hs) <- Map.toList (cats (abstract pgf))] + +startCat pgf = DTyp [] (lookStartCat pgf) [] + +functions pgf = Map.keys (funs (abstract pgf)) + +functionType pgf fun = + case Map.lookup fun (funs (abstract pgf)) of + Just (ty,_,_) -> Just ty + Nothing -> Nothing + +complete pgf from typ input = + let (ws,prefix) = tokensAndPrefix input + state0 = Incremental.initState pgf from typ + in case loop state0 ws of + Nothing -> [] + Just state -> + (if null prefix && not (null (Incremental.extractTrees state typ)) then [unwords ws ++ " "] else []) + ++ [unwords (ws++[c]) ++ " " | c <- Map.keys (Incremental.getCompletions state prefix)] + where + tokensAndPrefix :: String -> ([String],String) + tokensAndPrefix s | not (null s) && isSpace (last s) = (ws, "") + | null ws = ([],"") + | otherwise = (init ws, last ws) + where ws = words s + + loop ps [] = Just ps + loop ps (t:ts) = case Incremental.nextState ps t of + Left es -> Nothing + Right ps -> loop ps ts + +-- | Converts an expression to normal form +compute :: PGF -> Expr -> Expr +compute pgf = PGF.Data.normalForm (funs (abstract pgf)) 0 [] + +browse :: PGF -> CId -> Maybe (String,[CId],[CId]) +browse pgf id = fmap (\def -> (def,producers,consumers)) definition + where + definition = case Map.lookup id (funs (abstract pgf)) of + Just (ty,_,eqs) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$ + if null eqs + then empty + else text "def" <+> vcat [let (scope,ds) = mapAccumL (ppPatt 9) [] patts + in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs]) + Nothing -> case Map.lookup id (cats (abstract pgf)) of + Just hyps -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL ppHypo [] hyps))) + Nothing -> Nothing + + (producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf)) + where + accum f (ty,_,_) (plist,clist) = + let !plist' = if id `elem` ps then f : plist else plist + !clist' = if id `elem` cs then f : clist else clist + in (plist',clist') + where + (ps,cs) = tyIds ty + + tyIds (DTyp hyps cat es) = (foldr expIds (cat:concat css) es,concat pss) + where + (pss,css) = unzip [tyIds ty | (_,_,ty) <- hyps] + + expIds (EAbs _ _ e) ids = expIds e ids + expIds (EApp e1 e2) ids = expIds e1 (expIds e2 ids) + expIds (EFun id) ids = id : ids + expIds (ETyped e _) ids = expIds e ids + expIds _ ids = ids diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs new file mode 100644 index 000000000..e4ed98424 --- /dev/null +++ b/src/runtime/haskell/PGF/Binary.hs @@ -0,0 +1,199 @@ +module PGF.Binary where + +import PGF.CId +import PGF.Data +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get +import qualified Data.ByteString as BS +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import qualified Data.Set as Set +import Control.Monad + +pgfMajorVersion, pgfMinorVersion :: Word16 +(pgfMajorVersion, pgfMinorVersion) = (1,0) + +instance Binary PGF where + put pgf = putWord16be pgfMajorVersion >> + putWord16be pgfMinorVersion >> + put ( absname pgf, cncnames pgf + , gflags pgf + , abstract pgf, concretes pgf + ) + get = do v1 <- getWord16be + v2 <- getWord16be + absname <- get + cncnames <- get + gflags <- get + abstract <- get + concretes <- get + return (PGF{ absname=absname, cncnames=cncnames + , gflags=gflags + , abstract=abstract, concretes=concretes + }) + +instance Binary CId where + put (CId bs) = put bs + get = liftM CId get + +instance Binary Abstr where + put abs = put (aflags abs, funs abs, cats abs) + get = do aflags <- get + funs <- get + cats <- get + let catfuns = Map.mapWithKey (\cat _ -> [f | (f, (DTyp _ c _,_,_)) <- Map.toList funs, c==cat]) cats + return (Abstr{ aflags=aflags + , funs=funs, cats=cats + , catfuns=catfuns + }) + +instance Binary Concr where + put cnc = put ( cflags cnc, lins cnc, opers cnc + , lincats cnc, lindefs cnc + , printnames cnc, paramlincats cnc + , parser cnc + ) + get = do cflags <- get + lins <- get + opers <- get + lincats <- get + lindefs <- get + printnames <- get + paramlincats <- get + parser <- get + return (Concr{ cflags=cflags, lins=lins, opers=opers + , lincats=lincats, lindefs=lindefs + , printnames=printnames + , paramlincats=paramlincats + , parser=parser + }) + +instance Binary Alternative where + put (Alt v x) = put v >> put x + get = liftM2 Alt get get + +instance Binary Term where + put (R es) = putWord8 0 >> put es + put (S es) = putWord8 1 >> put es + put (FV es) = putWord8 2 >> put es + put (P e v) = putWord8 3 >> put (e,v) + put (W e v) = putWord8 4 >> put (e,v) + put (C i ) = putWord8 5 >> put i + put (TM i ) = putWord8 6 >> put i + put (F f) = putWord8 7 >> put f + put (V i) = putWord8 8 >> put i + put (K (KS s)) = putWord8 9 >> put s + put (K (KP d vs)) = putWord8 10 >> put (d,vs) + + get = do tag <- getWord8 + case tag of + 0 -> liftM R get + 1 -> liftM S get + 2 -> liftM FV get + 3 -> liftM2 P get get + 4 -> liftM2 W get get + 5 -> liftM C get + 6 -> liftM TM get + 7 -> liftM F get + 8 -> liftM V get + 9 -> liftM (K . KS) get + 10 -> liftM2 (\d vs -> K (KP d vs)) get get + _ -> decodingError + +instance Binary Expr where + put (EAbs b x exp) = putWord8 0 >> put (b,x,exp) + put (EApp e1 e2) = putWord8 1 >> put (e1,e2) + put (ELit (LStr s)) = putWord8 2 >> put s + put (ELit (LFlt d)) = putWord8 3 >> put d + put (ELit (LInt i)) = putWord8 4 >> put i + put (EMeta i) = putWord8 5 >> put i + put (EFun f) = putWord8 6 >> put f + put (EVar i) = putWord8 7 >> put i + put (ETyped e ty) = putWord8 8 >> put (e,ty) + get = do tag <- getWord8 + case tag of + 0 -> liftM3 EAbs get get get + 1 -> liftM2 EApp get get + 2 -> liftM (ELit . LStr) get + 3 -> liftM (ELit . LFlt) get + 4 -> liftM (ELit . LInt) get + 5 -> liftM EMeta get + 6 -> liftM EFun get + 7 -> liftM EVar get + 8 -> liftM2 ETyped get get + _ -> decodingError + +instance Binary Patt where + put (PApp f ps) = putWord8 0 >> put (f,ps) + put (PVar x) = putWord8 1 >> put x + put PWild = putWord8 2 + put (PLit (LStr s)) = putWord8 3 >> put s + put (PLit (LFlt d)) = putWord8 4 >> put d + put (PLit (LInt i)) = putWord8 5 >> put i + get = do tag <- getWord8 + case tag of + 0 -> liftM2 PApp get get + 1 -> liftM PVar get + 2 -> return PWild + 3 -> liftM (PLit . LStr) get + 4 -> liftM (PLit . LFlt) get + 5 -> liftM (PLit . LInt) get + _ -> decodingError + +instance Binary Equation where + put (Equ ps e) = put (ps,e) + get = liftM2 Equ get get + +instance Binary Type where + put (DTyp hypos cat exps) = put (hypos,cat,exps) + get = liftM3 DTyp get get get + +instance Binary BindType where + put Explicit = putWord8 0 + put Implicit = putWord8 1 + get = do tag <- getWord8 + case tag of + 0 -> return Explicit + 1 -> return Implicit + _ -> decodingError + +instance Binary FFun where + put (FFun fun prof lins) = put (fun,prof,lins) + get = liftM3 FFun get get get + +instance Binary FSymbol where + put (FSymCat n l) = putWord8 0 >> put (n,l) + put (FSymLit n l) = putWord8 1 >> put (n,l) + put (FSymKS ts) = putWord8 2 >> put ts + put (FSymKP d vs) = putWord8 3 >> put (d,vs) + get = do tag <- getWord8 + case tag of + 0 -> liftM2 FSymCat get get + 1 -> liftM2 FSymLit get get + 2 -> liftM FSymKS get + 3 -> liftM2 (\d vs -> FSymKP d vs) get get + _ -> decodingError + +instance Binary Production where + put (FApply ruleid args) = putWord8 0 >> put (ruleid,args) + put (FCoerce fcat) = putWord8 1 >> put fcat + get = do tag <- getWord8 + case tag of + 0 -> liftM2 FApply get get + 1 -> liftM FCoerce get + _ -> decodingError + +instance Binary ParserInfo where + put p = put (functions p, sequences p, productions0 p, totalCats p, startCats p) + get = do functions <- get + sequences <- get + productions0<- get + totalCats <- get + startCats <- get + return (ParserInfo{functions=functions,sequences=sequences + ,productions0=productions0 + ,productions =filterProductions productions0 + ,totalCats=totalCats,startCats=startCats}) + +decodingError = fail "This PGF file was compiled with different version of GF" diff --git a/src/runtime/haskell/PGF/BuildParser.hs b/src/runtime/haskell/PGF/BuildParser.hs new file mode 100644 index 000000000..23e0725c6 --- /dev/null +++ b/src/runtime/haskell/PGF/BuildParser.hs @@ -0,0 +1,76 @@ +--------------------------------------------------------------------- +-- | +-- Maintainer : Krasimir Angelov +-- Stability : (stable) +-- Portability : (portable) +-- +-- FCFG parsing, parser information +----------------------------------------------------------------------------- + +module PGF.BuildParser where + +import GF.Data.SortedList +import GF.Data.Assoc +import PGF.CId +import PGF.Data +import PGF.Parsing.FCFG.Utilities + +import Data.Array.IArray +import Data.Maybe +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import qualified Data.Set as Set +import Debug.Trace + + +data ParserInfoEx + = ParserInfoEx { epsilonRules :: [(FunId,[FCat],FCat)] + , leftcornerCats :: Assoc FCat [(FunId,[FCat],FCat)] + , leftcornerTokens :: Assoc String [(FunId,[FCat],FCat)] + , grammarToks :: [String] + } + +------------------------------------------------------------ +-- parser information + +getLeftCornerTok pinfo (FFun _ _ lins) + | inRange (bounds syms) 0 = case syms ! 0 of + FSymKS [tok] -> [tok] + _ -> [] + | otherwise = [] + where + syms = (sequences pinfo) ! (lins ! 0) + +getLeftCornerCat pinfo args (FFun _ _ lins) + | inRange (bounds syms) 0 = case syms ! 0 of + FSymCat d _ -> let cat = args !! d + in case IntMap.lookup cat (productions pinfo) of + Just set -> cat : [cat' | FCoerce cat' <- Set.toList set] + Nothing -> [cat] + _ -> [] + | otherwise = [] + where + syms = (sequences pinfo) ! (lins ! 0) + +buildParserInfo :: ParserInfo -> ParserInfoEx +buildParserInfo pinfo = + ParserInfoEx { epsilonRules = epsilonrules + , leftcornerCats = leftcorncats + , leftcornerTokens = leftcorntoks + , grammarToks = grammartoks + } + + where epsilonrules = [ (ruleid,args,cat) + | (cat,set) <- IntMap.toList (productions pinfo) + , (FApply ruleid args) <- Set.toList set + , let (FFun _ _ lins) = (functions pinfo) ! ruleid + , not (inRange (bounds ((sequences pinfo) ! (lins ! 0))) 0) ] + leftcorncats = accumAssoc id [ (cat', (ruleid, args, cat)) + | (cat,set) <- IntMap.toList (productions pinfo) + , (FApply ruleid args) <- Set.toList set + , cat' <- getLeftCornerCat pinfo args ((functions pinfo) ! ruleid) ] + leftcorntoks = accumAssoc id [ (tok, (ruleid, args, cat)) + | (cat,set) <- IntMap.toList (productions pinfo) + , (FApply ruleid args) <- Set.toList set + , tok <- getLeftCornerTok pinfo ((functions pinfo) ! ruleid) ] + grammartoks = nubsort [t | lin <- elems (sequences pinfo), FSymKS [t] <- elems lin] diff --git a/src/runtime/haskell/PGF/CId.hs b/src/runtime/haskell/PGF/CId.hs new file mode 100644 index 000000000..fea304d9d --- /dev/null +++ b/src/runtime/haskell/PGF/CId.hs @@ -0,0 +1,55 @@ +module PGF.CId (CId(..), + mkCId, wildCId, + readCId, showCId, + + -- utils + pCId, pIdent, ppCId) where + +import Control.Monad +import qualified Data.ByteString.Char8 as BS +import Data.Char +import qualified Text.ParserCombinators.ReadP as RP +import qualified Text.PrettyPrint as PP + + +-- | An abstract data type that represents +-- identifiers for functions and categories in PGF. +newtype CId = CId BS.ByteString deriving (Eq,Ord) + +wildCId :: CId +wildCId = CId (BS.singleton '_') + +-- | Creates a new identifier from 'String' +mkCId :: String -> CId +mkCId s = CId (BS.pack s) + +-- | Reads an identifier from 'String'. The function returns 'Nothing' if the string is not valid identifier. +readCId :: String -> Maybe CId +readCId s = case [x | (x,cs) <- RP.readP_to_S pCId s, all isSpace cs] of + [x] -> Just x + _ -> Nothing + +-- | Renders the identifier as 'String' +showCId :: CId -> String +showCId (CId x) = BS.unpack x + +instance Show CId where + showsPrec _ = showString . showCId + +instance Read CId where + readsPrec _ = RP.readP_to_S pCId + +pCId :: RP.ReadP CId +pCId = do s <- pIdent + if s == "_" + then RP.pfail + else return (mkCId s) + +pIdent :: RP.ReadP String +pIdent = liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest) + where + isIdentFirst c = c == '_' || isLetter c + isIdentRest c = c == '_' || c == '\'' || isAlphaNum c + +ppCId :: CId -> PP.Doc +ppCId = PP.text . showCId diff --git a/src/runtime/haskell/PGF/Check.hs b/src/runtime/haskell/PGF/Check.hs new file mode 100644 index 000000000..58b66cfe4 --- /dev/null +++ b/src/runtime/haskell/PGF/Check.hs @@ -0,0 +1,173 @@ +module PGF.Check (checkPGF) where + +import PGF.CId +import PGF.Data +import PGF.Macros +import GF.Data.ErrM + +import qualified Data.Map as Map +import Control.Monad +import Debug.Trace + +checkPGF :: PGF -> Err (PGF,Bool) +checkPGF pgf = do + (cs,bs) <- mapM (checkConcrete pgf) + (Map.assocs (concretes pgf)) >>= return . unzip + return (pgf {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 :: PGF -> (CId,Concr) -> Err ((CId,Concr),Bool) +checkConcrete pgf (lang,cnc) = + labelBoolErr ("happened in language " ++ showCId lang) $ do + (rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip + return ((lang,cnc{lins = Map.fromAscList rs}),and bs) + where + checkl = checkLin pgf lang + +checkLin :: PGF -> CId -> (CId,Term) -> Err ((CId,Term),Bool) +checkLin pgf lang (f,t) = + labelBoolErr ("happened in function " ++ showCId f) $ do + (t',b) <- checkTerm (lintype pgf lang f) t --- $ inline pgf 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 True 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 False 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) + +-- symmetry in (Ints m == Ints n) is all we can use in variants + +eqType :: Bool -> CType -> CType -> Bool +eqType symm inf exp = case (inf,exp) of + (C k, C n) -> if symm then True else k <= n -- only run-time corr. + (R rs,R ts) -> length rs == length ts && and [eqType symm 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 :: PGF -> CId -> CId -> LinType +lintype pgf lang fun = case typeSkeleton (lookType pgf fun) of + (cs,c) -> (map vlinc cs, linc c) ---- HOAS + where + linc = lookLincat pgf lang + vlinc (0,c) = linc c + vlinc (i,c) = case linc c of + R ts -> R (ts ++ replicate i str) + +inline :: PGF -> CId -> Term -> Term +inline pgf lang t = case t of + F c -> inl $ look c + _ -> composSafeOp inl t + where + inl = inline pgf lang + look = lookLin pgf 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/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs new file mode 100644 index 000000000..38027e96e --- /dev/null +++ b/src/runtime/haskell/PGF/Data.hs @@ -0,0 +1,95 @@ +module PGF.Data (module PGF.Data, module PGF.Expr, module PGF.Type, module PGF.PMCFG) where + +import PGF.CId +import PGF.Expr hiding (Value, Env, Tree) +import PGF.Type +import PGF.PMCFG + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import Data.List + +-- internal datatypes for PGF + +-- | An abstract data type representing multilingual grammar +-- in Portable Grammar Format. +data PGF = PGF { + absname :: CId , + cncnames :: [CId] , + gflags :: Map.Map CId String, -- value of a global flag + abstract :: Abstr , + concretes :: Map.Map CId Concr + } + +data Abstr = Abstr { + aflags :: Map.Map CId String, -- value of a flag + funs :: Map.Map CId (Type,Int,[Equation]), -- type, arrity and definition of function + cats :: Map.Map CId [Hypo], -- context of a cat + catfuns :: Map.Map CId [CId] -- funs to a cat (redundant, for fast lookup) + } + +data Concr = Concr { + cflags :: Map.Map CId String, -- value of a flag + lins :: Map.Map CId Term, -- lin of a fun + opers :: Map.Map CId Term, -- oper generated by subex elim + lincats :: Map.Map CId Term, -- lin type of a cat + lindefs :: Map.Map CId Term, -- lin default of a cat + printnames :: Map.Map CId Term, -- printname of a cat or a fun + paramlincats :: Map.Map CId Term, -- lin type of cat, with printable param names + parser :: Maybe ParserInfo -- parser + } + +data Term = + R [Term] + | P Term Term + | S [Term] + | K Tokn + | V Int + | C Int + | F CId + | FV [Term] + | W String Term + | TM String + deriving (Eq,Ord,Show) + +data Tokn = + KS String + | KP [String] [Alternative] + deriving (Eq,Ord,Show) + + +-- merge two GFCCs; fails is differens absnames; priority to second arg + +unionPGF :: PGF -> PGF -> PGF +unionPGF one two = case absname one of + n | n == wildCId -> two -- extending empty grammar + | n == absname two -> one { -- extending grammar with same abstract + concretes = Map.union (concretes two) (concretes one), + cncnames = union (cncnames one) (cncnames two) + } + _ -> one -- abstracts don't match ---- print error msg + +emptyPGF :: PGF +emptyPGF = PGF { + absname = wildCId, + cncnames = [] , + gflags = Map.empty, + abstract = error "empty grammar, no abstract", + concretes = Map.empty + } + +-- | This is just a 'CId' with the language name. +-- A language name is the identifier that you write in the +-- top concrete or abstract module in GF after the +-- concrete/abstract keyword. Example: +-- +-- > abstract Lang = ... +-- > concrete LangEng of Lang = ... +type Language = CId + +readLanguage :: String -> Maybe Language +readLanguage = readCId + +showLanguage :: Language -> String +showLanguage = showCId diff --git a/src/runtime/haskell/PGF/Editor.hs b/src/runtime/haskell/PGF/Editor.hs new file mode 100644 index 000000000..3f69da170 --- /dev/null +++ b/src/runtime/haskell/PGF/Editor.hs @@ -0,0 +1,241 @@ +module PGF.Editor ( + State, -- datatype -- type-annotated possibly open tree with a focus + Dict, -- datatype -- abstract syntax information optimized for editing + Position, -- datatype -- path from top to focus + new, -- :: Type -> State -- create new State + refine, -- :: Dict -> CId -> State -> State -- refine focus with CId + replace, -- :: Dict -> Tree -> State -> State -- replace focus with Tree + delete, -- :: State -> State -- replace focus with ? + goNextMeta, -- :: State -> State -- move focus to next ? node + goNext, -- :: State -> State -- move to next node + goTop, -- :: State -> State -- move focus to the top (=root) + goPosition, -- :: Position -> State -> State -- move focus to given position + mkPosition, -- :: [Int] -> Position -- list of choices (top = []) + showPosition,-- :: Position -> [Int] -- readable position + focusType, -- :: State -> Type -- get the type of focus + stateTree, -- :: State -> Tree -- get the current tree + isMetaFocus, -- :: State -> Bool -- whether focus is ? + allMetas, -- :: State -> [(Position,Type)] -- all ?s and their positions + prState, -- :: State -> String -- print state, focus marked * + refineMenu, -- :: Dict -> State -> [CId] -- get refinement menu + pgf2dict -- :: PGF -> Dict -- create editing Dict from PGF + ) where + +import PGF.Data +import PGF.CId +import qualified Data.Map as M +import Debug.Trace ---- + +-- API + +new :: Type -> State +new (DTyp _ t _) = etree2state (uETree t) + +refine :: Dict -> CId -> State -> State +refine dict f = replaceInState (mkRefinement dict f) + +replace :: Dict -> Tree -> State -> State +replace dict t = replaceInState (tree2etree dict t) + +delete :: State -> State +delete s = replaceInState (uETree (typ (tree s))) s + +goNextMeta :: State -> State +goNextMeta s = + if isComplete s then s + else let s1 = goNext s in if isMetaFocus s1 + then s1 else goNextMeta s1 + +isComplete :: State -> Bool +isComplete s = isc (tree s) where + isc t = case atom t of + AMeta _ -> False + ACon _ -> all isc (children t) + +goTop :: State -> State +goTop = navigate (const top) + +goPosition :: [Int] -> State -> State +goPosition p s = s{position = p} + +mkPosition :: [Int] -> Position +mkPosition = id + +refineMenu :: Dict -> State -> [CId] +refineMenu dict s = maybe [] (map fst) $ M.lookup (focusBType s) (refines dict) + +focusType :: State -> Type +focusType s = btype2type (focusBType s) + +stateTree :: State -> Tree +stateTree = etree2tree . tree + +pgf2dict :: PGF -> Dict +pgf2dict pgf = Dict (M.fromAscList fus) refs where + fus = [(f,mkFType ty) | (f,(ty,_)) <- M.toList (funs abs)] + refs = M.fromAscList [(c, fusTo c) | (c,_) <- M.toList (cats abs)] + fusTo c = [(f,ty) | (f,ty@(_,k)) <- fus, k==c] ---- quadratic + mkFType (DTyp hyps c _) = ([k | Hyp _ (DTyp _ k _) <- hyps],c) ----dep types + abs = abstract pgf + +etree2tree :: ETree -> Tree +etree2tree t = case atom t of + ACon f -> Fun f (map etree2tree (children t)) + AMeta i -> Meta i + +tree2etree :: Dict -> Tree -> ETree +tree2etree dict t = case t of + Fun f _ -> annot (look f) t + where + annot (tys,ty) tr = case tr of + Fun f trs -> ETree (ACon f) ty [annt t tr | (t,tr) <- zip tys trs] + Meta i -> ETree (AMeta i) ty [] + annt ty tr = case tr of + Fun _ _ -> tree2etree dict tr + Meta _ -> annot ([],ty) tr + look f = maybe undefined id $ M.lookup f (functs dict) + +prState :: State -> String +prState s = unlines [replicate i ' ' ++ f | (i,f) <- pr [] (tree s)] where + pr i t = + (ind i,prAtom i (atom t)) : concat [pr (sub j i) c | (j,c) <- zip [0..] (children t)] + prAtom i a = prFocus i ++ case a of + ACon f -> prCId f + AMeta i -> "?" ++ show i + prFocus i = if i == position s then "*" else "" + ind i = 2 * length i + sub j i = i ++ [j] + +showPosition :: Position -> [Int] +showPosition = id + +allMetas :: State -> [(Position,Type)] +allMetas s = [(reverse p, btype2type ty) | (p,ty) <- metas [] (tree s)] where + metas p t = + (if isMetaAtom (atom t) then [(p,typ t)] else []) ++ + concat [metas (i:p) u | (i,u) <- zip [0..] (children t)] + +---- Trees and navigation + +data ETree = ETree { + atom :: Atom, + typ :: BType, + children :: [ETree] + } + deriving Show + +data Atom = + ACon CId + | AMeta Int + deriving Show + +btype2type :: BType -> Type +btype2type t = DTyp [] t [] + +uETree :: BType -> ETree +uETree ty = ETree (AMeta 0) ty [] + +data State = State { + position :: Position, + tree :: ETree + } + deriving Show + +type Position = [Int] + +top :: Position +top = [] + +up :: Position -> Position +up p = case p of + _:_ -> init p + _ -> p + +down :: Position -> Position +down = (++[0]) + +left :: Position -> Position +left p = case p of + _:_ | last p > 0 -> init p ++ [last p - 1] + _ -> top + +right :: Position -> Position +right p = case p of + _:_ -> init p ++ [last p + 1] + _ -> top + +etree2state :: ETree -> State +etree2state = State top + +doInState :: (ETree -> ETree) -> State -> State +doInState f s = s{tree = change (position s) (tree s)} where + change p t = case p of + [] -> f t + n:ns -> let (ts1,t0:ts2) = splitAt n (children t) in + t{children = ts1 ++ [change ns t0] ++ ts2} + +subtree :: Position -> ETree -> ETree +subtree p t = case p of + [] -> t + n:ns -> subtree ns (children t !! n) + +focus :: State -> ETree +focus s = subtree (position s) (tree s) + +focusBType :: State -> BType +focusBType s = typ (focus s) + +navigate :: (Position -> Position) -> State -> State +navigate p s = s{position = p (position s)} + +-- p is a fix-point aspect of state change +untilFix :: Eq a => (State -> a) -> (State -> Bool) -> (State -> State) -> State -> State +untilFix p b f s = + if b s + then s + else let fs = f s in if p fs == p s + then s + else untilFix p b f fs + +untilPosition :: (State -> Bool) -> (State -> State) -> State -> State +untilPosition = untilFix position + +goNext :: State -> State +goNext s = case focus s of + st | not (null (children st)) -> navigate down s + _ -> findSister s + where + findSister s = case s of + s' | null (position s') -> s' + s' | hasYoungerSisters s' -> navigate right s' + s' -> findSister (navigate up s') + hasYoungerSisters s = case position s of + p@(_:_) -> length (children (focus (navigate up s))) > last p + 1 + _ -> False + +isMetaFocus :: State -> Bool +isMetaFocus s = isMetaAtom (atom (focus s)) + +isMetaAtom :: Atom -> Bool +isMetaAtom a = case a of + AMeta _ -> True + _ -> False + +replaceInState :: ETree -> State -> State +replaceInState t = doInState (const t) + + +------- + +type BType = CId ----dep types +type FType = ([BType],BType) ----dep types + +data Dict = Dict { + functs :: M.Map CId FType, + refines :: M.Map BType [(CId,FType)] + } + +mkRefinement :: Dict -> CId -> ETree +mkRefinement dict f = ETree (ACon f) val (map uETree args) where + (args,val) = maybe undefined id $ M.lookup f (functs dict) + diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs new file mode 100644 index 000000000..cf0cb79aa --- /dev/null +++ b/src/runtime/haskell/PGF/Expr.hs @@ -0,0 +1,355 @@ +module PGF.Expr(Tree, BindType(..), Expr(..), Literal(..), Patt(..), Equation(..), + readExpr, showExpr, pExpr, pBinds, ppExpr, ppPatt, + + mkApp, unApp, + mkStr, unStr, + mkInt, unInt, + mkDouble, unDouble, + mkMeta, isMeta, + + normalForm, + + -- needed in the typechecker + Value(..), Env, Funs, eval, apply, + + MetaId, + + -- helpers + pMeta,pStr,pArg,pLit,freshName,ppMeta,ppLit,ppParens + ) where + +import PGF.CId +import PGF.Type + +import Data.Char +import Data.Maybe +import Data.List as List +import Data.Map as Map hiding (showTree) +import Control.Monad +import qualified Text.PrettyPrint as PP +import qualified Text.ParserCombinators.ReadP as RP + +data Literal = + LStr String -- ^ string constant + | LInt Integer -- ^ integer constant + | LFlt Double -- ^ floating point constant + deriving (Eq,Ord,Show) + +type MetaId = Int + +data BindType = + Explicit + | Implicit + deriving (Eq,Ord,Show) + +-- | Tree is the abstract syntax representation of a given sentence +-- in some concrete syntax. Technically 'Tree' is a type synonym +-- of 'Expr'. +type Tree = Expr + +-- | An expression in the abstract syntax of the grammar. It could be +-- both parameter of a dependent type or an abstract syntax tree for +-- for some sentence. +data Expr = + EAbs BindType CId Expr -- ^ lambda abstraction + | EApp Expr Expr -- ^ application + | ELit Literal -- ^ literal + | EMeta {-# UNPACK #-} !MetaId -- ^ meta variable + | EFun CId -- ^ function or data constructor + | EVar {-# UNPACK #-} !Int -- ^ variable with de Bruijn index + | ETyped Expr Type -- ^ local type signature + | EImplArg Expr -- ^ implicit argument in expression + deriving (Eq,Ord,Show) + +-- | The pattern is used to define equations in the abstract syntax of the grammar. +data Patt = + PApp CId [Patt] -- ^ application. The identifier should be constructor i.e. defined with 'data' + | PLit Literal -- ^ literal + | PVar CId -- ^ variable + | PWild -- ^ wildcard + | PImplArg Patt -- ^ implicit argument in pattern + deriving (Eq,Ord) + +-- | The equation is used to define lambda function as a sequence +-- of equations with pattern matching. The list of 'Expr' represents +-- the patterns and the second 'Expr' is the function body for this +-- equation. +data Equation = + Equ [Patt] Expr + deriving (Eq,Ord) + +-- | parses 'String' as an expression +readExpr :: String -> Maybe Expr +readExpr s = case [x | (x,cs) <- RP.readP_to_S pExpr s, all isSpace cs] of + [x] -> Just x + _ -> Nothing + +-- | renders expression as 'String'. The list +-- of identifiers is the list of all free variables +-- in the expression in order reverse to the order +-- of binding. +showExpr :: [CId] -> Expr -> String +showExpr vars = PP.render . ppExpr 0 vars + +instance Read Expr where + readsPrec _ = RP.readP_to_S pExpr + +-- | Constructs an expression by applying a function to a list of expressions +mkApp :: CId -> [Expr] -> Expr +mkApp f es = foldl EApp (EFun f) es + +-- | Decomposes an expression into application of function +unApp :: Expr -> Maybe (CId,[Expr]) +unApp = extract [] + where + extract es (EFun f) = Just (f,es) + extract es (EApp e1 e2) = extract (e2:es) e1 + extract es _ = Nothing + +-- | Constructs an expression from string literal +mkStr :: String -> Expr +mkStr s = ELit (LStr s) + +-- | Decomposes an expression into string literal +unStr :: Expr -> Maybe String +unStr (ELit (LStr s)) = Just s +unStr _ = Nothing + +-- | Constructs an expression from integer literal +mkInt :: Integer -> Expr +mkInt i = ELit (LInt i) + +-- | Decomposes an expression into integer literal +unInt :: Expr -> Maybe Integer +unInt (ELit (LInt i)) = Just i +unInt _ = Nothing + +-- | Constructs an expression from real number literal +mkDouble :: Double -> Expr +mkDouble f = ELit (LFlt f) + +-- | Decomposes an expression into real number literal +unDouble :: Expr -> Maybe Double +unDouble (ELit (LFlt f)) = Just f +unDouble _ = Nothing + +-- | Constructs an expression which is meta variable +mkMeta :: Expr +mkMeta = EMeta 0 + +-- | Checks whether an expression is a meta variable +isMeta :: Expr -> Bool +isMeta (EMeta _) = True +isMeta _ = False + +----------------------------------------------------- +-- Parsing +----------------------------------------------------- + +pExpr :: RP.ReadP Expr +pExpr = RP.skipSpaces >> (pAbs RP.<++ pTerm) + where + pTerm = do f <- pFactor + RP.skipSpaces + as <- RP.sepBy pArg RP.skipSpaces + return (foldl EApp f as) + + pAbs = do xs <- RP.between (RP.char '\\') (RP.skipSpaces >> RP.string "->") pBinds + e <- pExpr + return (foldr (\(b,x) e -> EAbs b x e) e xs) + +pBinds :: RP.ReadP [(BindType,CId)] +pBinds = do xss <- RP.sepBy1 (RP.skipSpaces >> pBind) (RP.skipSpaces >> RP.char ',') + return (concat xss) + where + pCIdOrWild = pCId `mplus` (RP.char '_' >> return wildCId) + + pBind = + do x <- pCIdOrWild + return [(Explicit,x)] + `mplus` + RP.between (RP.char '{') + (RP.skipSpaces >> RP.char '}') + (RP.sepBy1 (RP.skipSpaces >> pCIdOrWild >>= \id -> return (Implicit,id)) (RP.skipSpaces >> RP.char ',')) + +pArg = fmap EImplArg (RP.between (RP.char '{') (RP.char '}') pExpr) + RP.<++ + pFactor + +pFactor = fmap EFun pCId + RP.<++ fmap ELit pLit + RP.<++ fmap EMeta pMeta + RP.<++ RP.between (RP.char '(') (RP.char ')') pExpr + RP.<++ RP.between (RP.char '<') (RP.char '>') pTyped + +pTyped = do RP.skipSpaces + e <- pExpr + RP.skipSpaces + RP.char ':' + RP.skipSpaces + ty <- pType + return (ETyped e ty) + +pMeta = do RP.char '?' + return 0 + +pLit :: RP.ReadP Literal +pLit = pNum RP.<++ liftM LStr pStr + +pNum = do x <- RP.munch1 isDigit + ((RP.char '.' >> RP.munch1 isDigit >>= \y -> return (LFlt (read (x++"."++y)))) + RP.<++ + (return (LInt (read x)))) + +pStr = RP.char '"' >> (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"')) + where + pEsc = RP.char '\\' >> RP.get + + +----------------------------------------------------- +-- Printing +----------------------------------------------------- + +ppExpr :: Int -> [CId] -> Expr -> PP.Doc +ppExpr d scope (EAbs b x e) = let (bs,xs,e1) = getVars [] [] (EAbs b x e) + in ppParens (d > 1) (PP.char '\\' PP.<> + PP.hsep (PP.punctuate PP.comma (reverse (List.zipWith ppBind bs xs))) PP.<+> + PP.text "->" PP.<+> + ppExpr 1 (xs++scope) e1) + where + getVars bs xs (EAbs b x e) = getVars (b:bs) ((freshName x xs):xs) e + getVars bs xs e = (bs,xs,e) +ppExpr d scope (EApp e1 e2) = ppParens (d > 3) ((ppExpr 3 scope e1) PP.<+> (ppExpr 4 scope e2)) +ppExpr d scope (ELit l) = ppLit l +ppExpr d scope (EMeta n) = ppMeta n +ppExpr d scope (EFun f) = ppCId f +ppExpr d scope (EVar i) = ppCId (scope !! i) +ppExpr d scope (ETyped e ty)= PP.char '<' PP.<> ppExpr 0 scope e PP.<+> PP.colon PP.<+> ppType 0 scope ty PP.<> PP.char '>' +ppExpr d scope (EImplArg e) = PP.braces (ppExpr 0 scope e) + +ppPatt :: Int -> [CId] -> Patt -> ([CId],PP.Doc) +ppPatt d scope (PApp f ps) = let (scope',ds) = mapAccumL (ppPatt 2) scope ps + in (scope',ppParens (not (List.null ps) && d > 1) (ppCId f PP.<+> PP.hsep ds)) +ppPatt d scope (PLit l) = (scope,ppLit l) +ppPatt d scope (PVar f) = (f:scope,ppCId f) +ppPatt d scope PWild = (scope,PP.char '_') +ppPatt d scope (PImplArg p) = let (scope',d) = ppPatt 0 scope p + in (scope',PP.braces d) + +ppBind Explicit x = ppCId x +ppBind Implicit x = PP.braces (ppCId x) + +ppLit (LStr s) = PP.text (show s) +ppLit (LInt n) = PP.integer n +ppLit (LFlt d) = PP.double d + +ppMeta :: MetaId -> PP.Doc +ppMeta n + | n == 0 = PP.char '?' + | otherwise = PP.char '?' PP.<> PP.int n + +ppParens True = PP.parens +ppParens False = id + +freshName :: CId -> [CId] -> CId +freshName x xs0 = loop 1 x + where + xs = wildCId : xs0 + + loop i y + | elem y xs = loop (i+1) (mkCId (show x++show i)) + | otherwise = y + + +----------------------------------------------------- +-- Computation +----------------------------------------------------- + +-- | Compute an expression to normal form +normalForm :: Funs -> Int -> Env -> Expr -> Expr +normalForm funs k env e = value2expr k (eval funs env e) + where + value2expr i (VApp f vs) = foldl EApp (EFun f) (List.map (value2expr i) vs) + value2expr i (VGen j vs) = foldl EApp (EVar (i-j-1)) (List.map (value2expr i) vs) + value2expr i (VMeta j env vs) = foldl EApp (EMeta j) (List.map (value2expr i) vs) + value2expr i (VSusp j env vs k) = value2expr i (k (VGen j vs)) + value2expr i (VLit l) = ELit l + value2expr i (VClosure env (EAbs b x e)) = EAbs b x (value2expr (i+1) (eval funs ((VGen i []):env) e)) + value2expr i (VImplArg v) = EImplArg (value2expr i v) + +data Value + = VApp CId [Value] + | VLit Literal + | VMeta {-# UNPACK #-} !MetaId Env [Value] + | VSusp {-# UNPACK #-} !MetaId Env [Value] (Value -> Value) + | VGen {-# UNPACK #-} !Int [Value] + | VClosure Env Expr + | VImplArg Value + +type Funs = Map.Map CId (Type,Int,[Equation]) -- type and def of a fun +type Env = [Value] + +eval :: Funs -> Env -> Expr -> Value +eval funs env (EVar i) = env !! i +eval funs env (EFun f) = case Map.lookup f funs of + Just (_,a,eqs) -> if a == 0 + then case eqs of + Equ [] e : _ -> eval funs [] e + _ -> VApp f [] + else VApp f [] + Nothing -> error ("unknown function "++showCId f) +eval funs env (EApp e1 e2) = apply funs env e1 [eval funs env e2] +eval funs env (EAbs b x e) = VClosure env (EAbs b x e) +eval funs env (EMeta i) = VMeta i env [] +eval funs env (ELit l) = VLit l +eval funs env (ETyped e _) = eval funs env e +eval funs env (EImplArg e) = VImplArg (eval funs env e) + +apply :: Funs -> Env -> Expr -> [Value] -> Value +apply funs env e [] = eval funs env e +apply funs env (EVar i) vs = applyValue funs (env !! i) vs +apply funs env (EFun f) vs = case Map.lookup f funs of + Just (_,a,eqs) -> if a <= length vs + then let (as,vs') = splitAt a vs + in match funs f eqs as vs' + else VApp f vs + Nothing -> error ("unknown function "++showCId f) +apply funs env (EApp e1 e2) vs = apply funs env e1 (eval funs env e2 : vs) +apply funs env (EAbs _ x e) (v:vs) = apply funs (v:env) e vs +apply funs env (EMeta i) vs = VMeta i env vs +apply funs env (ELit l) vs = error "literal of function type" +apply funs env (ETyped e _) vs = apply funs env e vs +apply funs env (EImplArg _) vs = error "implicit argument in function position" + +applyValue funs v [] = v +applyValue funs (VApp f vs0) vs = apply funs [] (EFun f) (vs0++vs) +applyValue funs (VLit _) vs = error "literal of function type" +applyValue funs (VMeta i env vs0) vs = VMeta i env (vs0++vs) +applyValue funs (VGen i vs0) vs = VGen i (vs0++vs) +applyValue funs (VSusp i env vs0 k) vs = VSusp i env vs0 (\v -> applyValue funs (k v) vs) +applyValue funs (VClosure env (EAbs b x e)) (v:vs) = apply funs (v:env) e vs +applyValue funs (VImplArg _) vs = error "implicit argument in function position" + +----------------------------------------------------- +-- Pattern matching +----------------------------------------------------- + +match :: Funs -> CId -> [Equation] -> [Value] -> [Value] -> Value +match funs f eqs as0 vs0 = + case eqs of + [] -> VApp f (as0++vs0) + (Equ ps res):eqs -> tryMatches eqs ps as0 res [] + where + tryMatches eqs [] [] res env = apply funs env res vs0 + tryMatches eqs (p:ps) (a:as) res env = tryMatch p a env + where + tryMatch (PVar x ) (v ) env = tryMatches eqs ps as res (v:env) + tryMatch (PWild ) (_ ) env = tryMatches eqs ps as res env + tryMatch (p ) (VMeta i envi vs ) env = VSusp i envi vs (\v -> tryMatch p v env) + tryMatch (p ) (VGen i vs ) env = VApp f (as0++vs0) + tryMatch (p ) (VSusp i envi vs k) env = VSusp i envi vs (\v -> tryMatch p (k v) env) + tryMatch (PApp f1 ps1) (VApp f2 vs2 ) env | f1 == f2 = tryMatches eqs (ps1++ps) (vs2++as) res env + tryMatch (PLit l1 ) (VLit l2 ) env | l1 == l2 = tryMatches eqs ps as res env + tryMatch (PImplArg p ) (VImplArg v ) env = tryMatch p v env + tryMatch _ _ env = match funs f eqs as0 vs0 + diff --git a/src/runtime/haskell/PGF/Expr.hs-boot b/src/runtime/haskell/PGF/Expr.hs-boot new file mode 100644 index 000000000..34a62a410 --- /dev/null +++ b/src/runtime/haskell/PGF/Expr.hs-boot @@ -0,0 +1,28 @@ +module PGF.Expr where + +import PGF.CId +import qualified Text.PrettyPrint as PP +import qualified Text.ParserCombinators.ReadP as RP + +data Expr + +instance Eq Expr +instance Ord Expr +instance Show Expr + + +data BindType = Explicit | Implicit + +instance Eq BindType +instance Ord BindType +instance Show BindType + + +pArg :: RP.ReadP Expr +pBinds :: RP.ReadP [(BindType,CId)] + +ppExpr :: Int -> [CId] -> Expr -> PP.Doc + +freshName :: CId -> [CId] -> CId + +ppParens :: Bool -> PP.Doc -> PP.Doc diff --git a/src/runtime/haskell/PGF/Generate.hs b/src/runtime/haskell/PGF/Generate.hs new file mode 100644 index 000000000..5add00a78 --- /dev/null +++ b/src/runtime/haskell/PGF/Generate.hs @@ -0,0 +1,66 @@ +module PGF.Generate where + +import PGF.CId +import PGF.Data +import PGF.Macros +import PGF.TypeCheck + +import qualified Data.Map as M +import System.Random + +-- generate an infinite list of trees exhaustively +generate :: PGF -> Type -> Maybe Int -> [Expr] +generate pgf ty@(DTyp _ cat _) dp = filter (\e -> case checkExpr pgf e ty of + Left _ -> False + Right _ -> True ) + (concatMap (\i -> gener i cat) depths) + where + gener 0 c = [EFun f | (f, ([],_)) <- fns c] + gener i c = [ + tr | + (f, (cs,_)) <- fns c, + let alts = map (gener (i-1)) cs, + ts <- combinations alts, + let tr = foldl EApp (EFun f) ts, + depth tr >= i + ] + fns c = [(f,catSkeleton ty) | (f,ty) <- functionsToCat pgf c] + depths = maybe [0 ..] (\d -> [0..d]) dp + +-- generate an infinite list of trees randomly +genRandom :: StdGen -> PGF -> Type -> [Expr] +genRandom gen pgf ty@(DTyp _ cat _) = filter (\e -> case checkExpr pgf e ty of + Left _ -> False + Right _ -> True ) + (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 | cid == cidString = (ELit (LStr "foo"), 1) + gett ds cid | cid == cidInt = (ELit (LInt 12345), 1) + gett ds cid | cid == cidFloat = (ELit (LFlt 12345), 1) + gett [] _ = (ELit (LStr "TIMEOUT"), 1) ---- + gett ds cat = case fns cat of + [] -> (EMeta 0,1) + fs -> let + d:ds2 = ds + (f,args) = getf d fs + (ts,k) = getts ds2 args + in (foldl EApp (EFun 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 pgf cat] diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs new file mode 100644 index 000000000..fdd4cecb5 --- /dev/null +++ b/src/runtime/haskell/PGF/Linearize.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE ParallelListComp #-} +module PGF.Linearize + (linearizes,realize,realizes,linTree, linTreeMark,linearizesMark) where + +import PGF.CId +import PGF.Data +import PGF.Macros +import PGF.Tree + +import Control.Monad +import qualified Data.Map as Map +import Data.List + +import Debug.Trace + +-- linearization and computation of concrete PGF Terms + +linearizes :: PGF -> CId -> Expr -> [String] +linearizes pgf lang = realizes . linTree pgf lang + +realize :: Term -> String +realize = concat . take 1 . realizes + +realizes :: Term -> [String] +realizes = map (unwords . untokn) . realizest + +realizest :: Term -> [[Tokn]] +realizest trm = case trm of + R ts -> realizest (ts !! 0) + S ss -> map concat $ combinations $ map realizest ss + K t -> [[t]] + W s t -> [[KS (s ++ r)] | [KS r] <- realizest t] + FV ts -> concatMap realizest ts + TM s -> [[KS s]] + _ -> [[KS $ "REALIZE_ERROR " ++ show trm]] ---- debug + +untokn :: [Tokn] -> [String] +untokn ts = case ts of + KP d _ : [] -> d + KP d vs : ws -> let ss@(s:_) = untokn ws in sel d vs s ++ ss + KS s : ws -> s : untokn ws + [] -> [] + where + sel d vs w = case [v | Alt v cs <- vs, any (\c -> isPrefixOf c w) cs] of + v:_ -> v + _ -> d + +-- Lifts all variants to the top level (except those in macros). +liftVariants :: Term -> [Term] +liftVariants = f + where + f (R ts) = liftM R $ mapM f ts + f (P t1 t2) = liftM2 P (f t1) (f t2) + f (S ts) = liftM S $ mapM f ts + f (FV ts) = ts >>= f + f (W s t) = liftM (W s) $ f t + f t = return t + +linTree :: PGF -> CId -> Expr -> Term +linTree pgf lang e = lin (expr2tree e) Nothing + where + cnc = lookMap (error "no lang") lang (concretes pgf) + + lin (Abs xs e ) mty = case lin e Nothing of + R ts -> R $ ts ++ (Data.List.map (kks . showCId . snd) xs) + TM s -> R $ (TM s) : (Data.List.map (kks . showCId . snd) xs) + lin (Fun fun es) mty = case Map.lookup fun (funs (abstract pgf)) of + Just (DTyp hyps _ _,_,_) -> let argVariants = sequence [liftVariants (lin e (Just ty)) | e <- es | (_,_,ty) <- hyps] + in variants [compute pgf lang args $ lookMap tm0 fun (lins cnc) | args <- argVariants] + Nothing -> tm0 + lin (Lit (LStr s)) mty = R [kks (show s)] -- quoted + lin (Lit (LInt i)) mty = R [kks (show i)] + lin (Lit (LFlt d)) mty = R [kks (show d)] + lin (Var x) mty = case mty of + Just (DTyp _ cat _) -> compute pgf lang [K (KS (showCId x))] (lookMap tm0 cat (lindefs cnc)) + Nothing -> TM (showCId x) + lin (Meta i) mty = case mty of + Just (DTyp _ cat _) -> compute pgf lang [K (KS (show i))] (lookMap tm0 cat (lindefs cnc)) + Nothing -> TM (show i) + +variants :: [Term] -> Term +variants ts = case ts of + [t] -> t + _ -> FV ts + +unvariants :: Term -> [Term] +unvariants t = case t of + FV ts -> ts + _ -> [t] + +compute :: PGF -> CId -> [Term] -> Term -> Term +compute pgf 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 i -- already computed + F c -> comp $ look c -- not computed (if contains argvar) + FV ts -> FV $ map comp ts + S ts -> S $ filter (/= S []) $ map comp ts + _ -> trm + + look = lookOper pgf lang + + idx xs i = if i > length xs - 1 + then trace + ("too large " ++ show i ++ " for\n" ++ unlines (map show xs) ++ "\n") tm0 + else xs !! i + + proj r p = case (r,p) of + (_, FV ts) -> FV $ map (proj r) ts + (FV ts, _ ) -> FV $ 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 + _ -> error ("ERROR in grammar compiler: string from "++ show t) "ERR" + + getIndex t = case t of + C i -> i + 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 + TM s -> TM s + _ -> error ("ERROR in grammar compiler: field from " ++ show t) t + +--------- +-- markup with tree positions + +linearizesMark :: PGF -> CId -> Expr -> [String] +linearizesMark pgf lang = realizes . linTreeMark pgf lang + +linTreeMark :: PGF -> CId -> Expr -> Term +linTreeMark pgf lang = lin [] . expr2tree + where + lin p (Abs xs e ) = case lin p e of + R ts -> R $ ts ++ (Data.List.map (kks . showCId . snd) xs) + TM s -> R $ (TM s) : (Data.List.map (kks . showCId . snd) xs) + lin p (Fun fun es) = + let argVariants = + mapM (\ (i,e) -> liftVariants $ lin (sub p i) e) (zip [0..] es) + in variants [mark (fun,p) $ compute pgf lang args $ look fun | + args <- argVariants] + lin p (Lit (LStr s)) = mark p $ R [kks (show s)] -- quoted + lin p (Lit (LInt i)) = mark p $ R [kks (show i)] + lin p (Lit (LFlt d)) = mark p $ R [kks (show d)] + lin p (Var x) = mark p $ TM (showCId x) + lin p (Meta i) = mark p $ TM (show i) + + look = lookLin pgf lang + + mark :: Show a => a -> Term -> Term + mark p t = case t of + R ts -> R $ map (mark p) ts + FV ts -> R $ map (mark p) ts + S ts -> S $ bracket p ts + K s -> S $ bracket p [t] + W s (R ts) -> R [mark p $ kks (s ++ u) | K (KS u) <- ts] + _ -> t + -- otherwise in normal form + + bracket p ts = [kks ("("++show p)] ++ ts ++ [kks ")"] + sub p i = p ++ [i] diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs new file mode 100644 index 000000000..af25de025 --- /dev/null +++ b/src/runtime/haskell/PGF/Macros.hs @@ -0,0 +1,154 @@ +module PGF.Macros where + +import PGF.CId +import PGF.Data +import Control.Monad +import qualified Data.Map as Map +import qualified Data.Array as Array +import Data.Maybe +import Data.List + +-- operations for manipulating PGF grammars and objects + +mapConcretes :: (Concr -> Concr) -> PGF -> PGF +mapConcretes f pgf = pgf { concretes = Map.map f (concretes pgf) } + +lookLin :: PGF -> CId -> CId -> Term +lookLin pgf lang fun = + lookMap tm0 fun $ lins $ lookMap (error "no lang") lang $ concretes pgf + +lookOper :: PGF -> CId -> CId -> Term +lookOper pgf lang fun = + lookMap tm0 fun $ opers $ lookMap (error "no lang") lang $ concretes pgf + +lookLincat :: PGF -> CId -> CId -> Term +lookLincat pgf lang fun = + lookMap tm0 fun $ lincats $ lookMap (error "no lang") lang $ concretes pgf + +lookParamLincat :: PGF -> CId -> CId -> Term +lookParamLincat pgf lang fun = + lookMap tm0 fun $ paramlincats $ lookMap (error "no lang") lang $ concretes pgf + +lookPrintName :: PGF -> CId -> CId -> Term +lookPrintName pgf lang fun = + lookMap tm0 fun $ printnames $ lookMap (error "no lang") lang $ concretes pgf + +lookType :: PGF -> CId -> Type +lookType pgf f = + case lookMap (error $ "lookType " ++ show f) f (funs (abstract pgf)) of + (ty,_,_) -> ty + +lookDef :: PGF -> CId -> [Equation] +lookDef pgf f = + case lookMap (error $ "lookDef " ++ show f) f (funs (abstract pgf)) of + (_,a,eqs) -> eqs + +isData :: PGF -> CId -> Bool +isData pgf f = + case Map.lookup f (funs (abstract pgf)) of + Just (_,_,[]) -> True -- the encoding of data constrs + _ -> False + +lookValCat :: PGF -> CId -> CId +lookValCat pgf = valCat . lookType pgf + +lookParser :: PGF -> CId -> Maybe ParserInfo +lookParser pgf lang = Map.lookup lang (concretes pgf) >>= parser + +lookStartCat :: PGF -> CId +lookStartCat pgf = mkCId $ fromMaybe "S" $ msum $ Data.List.map (Map.lookup (mkCId "startcat")) + [gflags pgf, aflags (abstract pgf)] + +lookGlobalFlag :: PGF -> CId -> String +lookGlobalFlag pgf f = + lookMap "?" f (gflags pgf) + +lookAbsFlag :: PGF -> CId -> String +lookAbsFlag pgf f = + lookMap "?" f (aflags (abstract pgf)) + +lookConcr :: PGF -> CId -> Concr +lookConcr pgf cnc = + lookMap (error $ "Missing concrete syntax: " ++ showCId cnc) cnc $ concretes pgf + +lookConcrFlag :: PGF -> CId -> CId -> Maybe String +lookConcrFlag pgf lang f = Map.lookup f $ cflags $ lookConcr pgf lang + +functionsToCat :: PGF -> CId -> [(CId,Type)] +functionsToCat pgf cat = + [(f,ty) | f <- fs, Just (ty,_,_) <- [Map.lookup f $ funs $ abstract pgf]] + where + fs = lookMap [] cat $ catfuns $ abstract pgf + +missingLins :: PGF -> CId -> [CId] +missingLins pgf lang = [c | c <- fs, not (hasl c)] where + fs = Map.keys $ funs $ abstract pgf + hasl = hasLin pgf lang + +hasLin :: PGF -> CId -> CId -> Bool +hasLin pgf lang f = Map.member f $ lins $ lookConcr pgf lang + +restrictPGF :: (CId -> Bool) -> PGF -> PGF +restrictPGF cond pgf = pgf { + abstract = abstr { + funs = restrict $ funs $ abstr, + cats = restrict $ cats $ abstr + } + } ---- restrict concrs also, might be needed + where + restrict = Map.filterWithKey (\c _ -> cond c) + abstr = abstract pgf + +depth :: Expr -> Int +depth (EAbs _ _ t) = depth t +depth (EApp e1 e2) = max (depth e1) (depth e2) + 1 +depth _ = 1 + +cftype :: [CId] -> CId -> Type +cftype args val = DTyp [(Explicit,wildCId,cftype [] arg) | arg <- args] val [] + +typeOfHypo :: Hypo -> Type +typeOfHypo (_,_,ty) = ty + +catSkeleton :: Type -> ([CId],CId) +catSkeleton ty = case ty of + DTyp hyps val _ -> ([valCat (typeOfHypo h) | h <- hyps],val) + +typeSkeleton :: Type -> ([(Int,CId)],CId) +typeSkeleton ty = case ty of + DTyp hyps val _ -> ([(contextLength ty, valCat ty) | h <- hyps, let ty = typeOfHypo h],val) + +valCat :: Type -> CId +valCat ty = case ty of + DTyp _ val _ -> val + +contextLength :: Type -> Int +contextLength ty = case ty of + DTyp hyps _ _ -> length hyps + +term0 :: CId -> Term +term0 = TM . showCId + +tm0 :: Term +tm0 = TM "?" + +kks :: String -> Term +kks = K . KS + +-- lookup with default value +lookMap :: (Show i, Ord i) => a -> i -> Map.Map i a -> a +lookMap d c m = Map.findWithDefault d c m + +--- from Operations +combinations :: [[a]] -> [[a]] +combinations t = case t of + [] -> [[]] + aa:uu -> [a:u | a <- aa, u <- combinations uu] + +isLiteralCat :: CId -> Bool +isLiteralCat = (`elem` [cidString, cidFloat, cidInt, cidVar]) + +cidString = mkCId "String" +cidInt = mkCId "Int" +cidFloat = mkCId "Float" +cidVar = mkCId "__gfVar" diff --git a/src/runtime/haskell/PGF/Morphology.hs b/src/runtime/haskell/PGF/Morphology.hs new file mode 100644 index 000000000..9eee71a97 --- /dev/null +++ b/src/runtime/haskell/PGF/Morphology.hs @@ -0,0 +1,26 @@ +module PGF.Morphology(Lemma,Analysis,Morpho, + buildMorpho, + lookupMorpho,fullFormLexicon) where + +import PGF.ShowLinearize (collectWords) +import PGF.Data +import PGF.CId + +import qualified Data.Map as Map +import Data.List (intersperse) + +-- these 4 definitions depend on the datastructure used + +type Lemma = CId +type Analysis = String + +newtype Morpho = Morpho (Map.Map String [(Lemma,Analysis)]) + +buildMorpho :: PGF -> Language -> Morpho +buildMorpho pgf lang = Morpho (Map.fromListWith (++) (collectWords pgf lang)) + +lookupMorpho :: Morpho -> String -> [(Lemma,Analysis)] +lookupMorpho (Morpho mo) s = maybe [] id $ Map.lookup s mo + +fullFormLexicon :: Morpho -> [(String,[(Lemma,Analysis)])] +fullFormLexicon (Morpho mo) = Map.toList mo diff --git a/src/runtime/haskell/PGF/PMCFG.hs b/src/runtime/haskell/PGF/PMCFG.hs new file mode 100644 index 000000000..c657e3d17 --- /dev/null +++ b/src/runtime/haskell/PGF/PMCFG.hs @@ -0,0 +1,119 @@ +module PGF.PMCFG where + +import PGF.CId +import PGF.Expr + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import Data.Array.IArray +import Data.Array.Unboxed +import Text.PrettyPrint + +type FCat = Int +type FIndex = Int +type FPointPos = Int +data FSymbol + = FSymCat {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex + | FSymLit {-# UNPACK #-} !Int {-# UNPACK #-} !FIndex + | FSymKS [String] + | FSymKP [String] [Alternative] + deriving (Eq,Ord,Show) +type Profile = [Int] +data Production + = FApply {-# UNPACK #-} !FunId [FCat] + | FCoerce {-# UNPACK #-} !FCat + | FConst Expr [String] + deriving (Eq,Ord,Show) +data FFun = FFun CId [Profile] {-# UNPACK #-} !(UArray FIndex SeqId) deriving (Eq,Ord,Show) +type FSeq = Array FPointPos FSymbol +type FunId = Int +type SeqId = Int + +data Alternative = + Alt [String] [String] + deriving (Eq,Ord,Show) + +data ParserInfo + = ParserInfo { functions :: Array FunId FFun + , sequences :: Array SeqId FSeq + , productions0:: IntMap.IntMap (Set.Set Production) -- this are the original productions as they are loaded from the PGF file + , productions :: IntMap.IntMap (Set.Set Production) -- this are the productions after the filtering for useless productions + , startCats :: Map.Map CId [FCat] + , totalCats :: {-# UNPACK #-} !FCat + } + + +fcatString, fcatInt, fcatFloat, fcatVar :: Int +fcatString = (-1) +fcatInt = (-2) +fcatFloat = (-3) +fcatVar = (-4) + +isLiteralFCat :: FCat -> Bool +isLiteralFCat = (`elem` [fcatString, fcatInt, fcatFloat, fcatVar]) + +ppPMCFG :: ParserInfo -> Doc +ppPMCFG pinfo = + text "productions" $$ + nest 2 (vcat [ppProduction (fcat,prod) | (fcat,set) <- IntMap.toList (productions pinfo), prod <- Set.toList set]) $$ + text "functions" $$ + nest 2 (vcat (map ppFun (assocs (functions pinfo)))) $$ + text "sequences" $$ + nest 2 (vcat (map ppSeq (assocs (sequences pinfo)))) $$ + text "startcats" $$ + nest 2 (vcat (map ppStartCat (Map.toList (startCats pinfo)))) + +ppProduction (fcat,FApply funid args) = + ppFCat fcat <+> text "->" <+> ppFunId funid <> brackets (hcat (punctuate comma (map ppFCat args))) +ppProduction (fcat,FCoerce arg) = + ppFCat fcat <+> text "->" <+> char '_' <> brackets (ppFCat arg) +ppProduction (fcat,FConst _ ss) = + ppFCat fcat <+> text "->" <+> ppStrs ss + +ppFun (funid,FFun fun _ arr) = + ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (ppCId fun) + +ppSeq (seqid,seq) = + ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol (elems seq)) + +ppStartCat (id,fcats) = + ppCId id <+> text ":=" <+> brackets (hcat (punctuate comma (map ppFCat fcats))) + +ppSymbol (FSymCat d r) = char '<' <> int d <> comma <> int r <> char '>' +ppSymbol (FSymLit d r) = char '<' <> int d <> comma <> int r <> char '>' +ppSymbol (FSymKS ts) = ppStrs ts +ppSymbol (FSymKP ts alts) = text "pre" <+> braces (hsep (punctuate semi (ppStrs ts : map ppAlt alts))) + +ppAlt (Alt ts ps) = ppStrs ts <+> char '/' <+> hsep (map (doubleQuotes . text) ps) + +ppStrs ss = doubleQuotes (hsep (map text ss)) + +ppFCat fcat + | fcat == fcatString = text "CString" + | fcat == fcatInt = text "CInt" + | fcat == fcatFloat = text "CFloat" + | fcat == fcatVar = text "CVar" + | otherwise = char 'C' <> int fcat + +ppFunId funid = char 'F' <> int funid +ppSeqId seqid = char 'S' <> int seqid + + +filterProductions = closure + where + closure prods0 + | IntMap.size prods == IntMap.size prods0 = prods + | otherwise = closure prods + where + prods = IntMap.mapMaybe (filterProdSet prods0) prods0 + + filterProdSet prods set0 + | Set.null set = Nothing + | otherwise = Just set + where + set = Set.filter (filterRule prods) set0 + + filterRule prods (FApply funid args) = all (\fcat -> isLiteralFCat fcat || IntMap.member fcat prods) args + filterRule prods (FCoerce fcat) = isLiteralFCat fcat || IntMap.member fcat prods + filterRule prods _ = True diff --git a/src/runtime/haskell/PGF/Paraphrase.hs b/src/runtime/haskell/PGF/Paraphrase.hs new file mode 100644 index 000000000..58d15b2e8 --- /dev/null +++ b/src/runtime/haskell/PGF/Paraphrase.hs @@ -0,0 +1,112 @@ +---------------------------------------------------------------------- +-- | +-- Module : Paraphrase +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- Generate parapharases with def definitions. +----------------------------------------------------------------------------- + +module PGF.Paraphrase ( + paraphrase, + paraphraseN + ) where + +import PGF.Data +import PGF.Tree +import PGF.Macros (lookDef,isData) +import PGF.CId + +import Data.List (nub,sort,group) +import qualified Data.Map as Map + +import Debug.Trace ---- + +paraphrase :: PGF -> Expr -> [Expr] +paraphrase pgf = nub . paraphraseN 2 pgf + +paraphraseN :: Int -> PGF -> Expr -> [Expr] +paraphraseN i pgf = map tree2expr . paraphraseN' i pgf . expr2tree + +paraphraseN' :: Int -> PGF -> Tree -> [Tree] +paraphraseN' 0 _ t = [t] +paraphraseN' i pgf t = + step i t ++ [Fun g ts' | Fun g ts <- step (i-1) t, ts' <- sequence (map par ts)] + where + par = paraphraseN' (i-1) pgf + step 0 t = [t] + step i t = let stept = step (i-1) t in stept ++ concat [def u | u <- stept] + def = fromDef pgf + +fromDef :: PGF -> Tree -> [Tree] +fromDef pgf t@(Fun f ts) = defDown t ++ defUp t where + defDown t = [subst g u | let equ = equsFrom f, (u,g) <- match equ ts, trequ "U" f equ] + defUp t = [subst g u | equ <- equsTo f, (u,g) <- match [equ] ts, trequ "D" f equ] + + equsFrom f = [(ps,d) | Just equs <- [lookup f equss], (Fun _ ps,d) <- equs] + + equsTo f = [c | (_,equs) <- equss, c <- casesTo f equs] + + casesTo f equs = + [(ps,p) | (p,d@(Fun g ps)) <- equs, g==f, + isClosed d || (length equs == 1 && isLinear d)] + + equss = [(f,[(Fun f (map patt2tree ps), expr2tree d) | (Equ ps d) <- eqs]) | + (f,(_,_,eqs)) <- Map.assocs (funs (abstract pgf)), not (null eqs)] + + trequ s f e = True ----trace (s ++ ": " ++ show f ++ " " ++ show e) True + +subst :: Subst -> Tree -> Tree +subst g e = case e of + Fun f ts -> Fun f (map substg ts) + Var x -> maybe e id $ lookup x g + _ -> e + where + substg = subst g + +type Subst = [(CId,Tree)] + +-- this applies to pattern, hence don't need to consider abstractions +isClosed :: Tree -> Bool +isClosed t = case t of + Fun _ ts -> all isClosed ts + Var _ -> False + _ -> True + +-- this applies to pattern, hence don't need to consider abstractions +isLinear :: Tree -> Bool +isLinear = nodup . vars where + vars t = case t of + Fun _ ts -> concatMap vars ts + Var x -> [x] + _ -> [] + nodup = all ((<2) . length) . group . sort + + +match :: [([Tree],Tree)] -> [Tree] -> [(Tree, Subst)] +match cases terms = case cases of + [] -> [] + (patts,_):_ | length patts /= length terms -> [] + (patts,val):cc -> case mapM tryMatch (zip patts terms) of + Just substs -> return (val, concat substs) + _ -> match cc terms + where + tryMatch (p,t) = case (p, t) of + (Var x, _) | notMeta t -> return [(x,t)] + (Fun p pp, Fun f tt) | p == f && length pp == length tt -> do + matches <- mapM tryMatch (zip pp tt) + return (concat matches) + _ -> if p==t then return [] else Nothing + + notMeta e = case e of + Meta _ -> False + Fun f ts -> all notMeta ts + _ -> True + +-- | Converts a pattern to tree. +patt2tree :: Patt -> Tree +patt2tree (PApp f ps) = Fun f (map patt2tree ps) +patt2tree (PLit l) = Lit l +patt2tree (PVar x) = Var x +patt2tree PWild = Meta 0 diff --git a/src/runtime/haskell/PGF/Parsing/FCFG/Active.hs b/src/runtime/haskell/PGF/Parsing/FCFG/Active.hs new file mode 100644 index 000000000..e88926f6e --- /dev/null +++ b/src/runtime/haskell/PGF/Parsing/FCFG/Active.hs @@ -0,0 +1,205 @@ +---------------------------------------------------------------------- +-- | +-- Maintainer : Krasimir Angelov +-- Stability : (stable) +-- Portability : (portable) +-- +-- MCFG parsing, the active algorithm +----------------------------------------------------------------------------- + +module PGF.Parsing.FCFG.Active (parse) where + +import GF.Data.Assoc +import GF.Data.SortedList +import GF.Data.Utilities +import qualified GF.Data.MultiMap as MM + +import PGF.CId +import PGF.Data +import PGF.Tree +import PGF.Parsing.FCFG.Utilities +import PGF.BuildParser + +import Control.Monad (guard) + +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import qualified Data.Set as Set +import Data.Array.IArray +import Debug.Trace + +---------------------------------------------------------------------- +-- * parsing + +type FToken = String + +makeFinalEdge cat 0 0 = (cat, [EmptyRange]) +makeFinalEdge cat i j = (cat, [makeRange i j]) + +-- | the list of categories = possible starting categories +parse :: String -> ParserInfo -> Type -> [FToken] -> [Expr] +parse strategy pinfo (DTyp _ start _) toks = map (tree2expr) . nubsort $ filteredForests >>= forest2trees + where + inTokens = input toks + starts = Map.findWithDefault [] start (startCats pinfo) + schart = xchart2syntaxchart chart pinfo + (i,j) = inputBounds inTokens + finalEdges = [makeFinalEdge cat i j | cat <- starts] + forests = chart2forests schart (const False) finalEdges + filteredForests = forests >>= applyProfileToForest + + pinfoex = buildParserInfo pinfo + + chart = process strategy pinfo pinfoex inTokens axioms emptyXChart + axioms | isBU strategy = literals pinfoex inTokens ++ initialBU pinfo pinfoex inTokens + | isTD strategy = literals pinfoex inTokens ++ initialTD pinfo starts inTokens + +isBU s = s=="b" +isTD s = s=="t" + +-- used in prediction +emptyChildren :: FunId -> [FCat] -> SyntaxNode FunId RangeRec +emptyChildren ruleid args = SNode ruleid (replicate (length args) []) + + +process :: String -> ParserInfo -> ParserInfoEx -> Input FToken -> [Item] -> XChart FCat -> XChart FCat +process strategy pinfo pinfoex toks [] chart = chart +process strategy pinfo pinfoex toks (item:items) chart = process strategy pinfo pinfoex toks items $! univRule item chart + where + univRule item@(Active found rng lbl ppos node@(SNode ruleid recs) args cat) chart + | inRange (bounds lin) ppos = + case lin ! ppos of + FSymCat d r -> let c = args !! d + in 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 (Active found rng lbl (ppos+1) (SNode ruleid (updateNth (const found') d recs)) args cat) + ++ + do guard (isTD strategy) + (ruleid,args) <- topdownRules pinfo c + return (Active [] EmptyRange 0 0 (emptyChildren ruleid args) args c) + in process strategy pinfo pinfoex toks items chart + found' -> let items = do rng <- concatRange rng (found' !! r) + return (Active found rng lbl (ppos+1) node args cat) + in process strategy pinfo pinfoex toks items chart + FSymKS [tok] + -> let items = do t_rng <- inputToken toks ? tok + rng' <- concatRange rng t_rng + return (Active found rng' lbl (ppos+1) node args cat) + in process strategy pinfo pinfoex toks items chart + | otherwise = + if inRange (bounds lins) (lbl+1) + then univRule (Active (rng:found) EmptyRange (lbl+1) 0 node args cat) chart + else univRule (Final (reverse (rng:found)) node args cat) chart + where + (FFun _ _ lins) = functions pinfo ! ruleid + lin = sequences pinfo ! (lins ! lbl) + univRule item@(Final found' node args cat) chart = + case insertXChart chart item cat of + Nothing -> chart + Just chart -> let items = do (Active found rng l ppos node@(SNode ruleid _) args c) <- lookupXChartAct chart cat + let FFun _ _ lins = functions pinfo ! ruleid + FSymCat d r = (sequences pinfo ! (lins ! l)) ! ppos + rng <- concatRange rng (found' !! r) + return (Active found rng l (ppos+1) (updateChildren node d found') args c) + ++ + do guard (isBU strategy) + (ruleid,args,c) <- leftcornerCats pinfoex ? cat + let FFun _ _ lins = functions pinfo ! ruleid + FSymCat d r = (sequences pinfo ! (lins ! 0)) ! 0 + return (Active [] (found' !! r) 0 1 (updateChildren (emptyChildren ruleid args) d found') args c) + + updateChildren :: SyntaxNode FunId RangeRec -> Int -> RangeRec -> SyntaxNode FunId RangeRec + updateChildren (SNode ruleid recs) i rec = SNode ruleid $! updateNth (const rec) i recs + in process strategy pinfo pinfoex toks items chart + +---------------------------------------------------------------------- +-- * XChart + +data Item + = Active RangeRec + Range + {-# UNPACK #-} !FIndex + {-# UNPACK #-} !FPointPos + (SyntaxNode FunId RangeRec) + [FCat] + FCat + | Final RangeRec (SyntaxNode FunId RangeRec) [FCat] FCat + deriving (Eq, Ord, Show) + +data XChart c = XChart !(MM.MultiMap c Item) !(MM.MultiMap c Item) + +emptyXChart :: Ord c => XChart c +emptyXChart = XChart MM.empty MM.empty + +insertXChart (XChart actives finals) item@(Active _ _ _ _ _ _ _) c = + case MM.insert' c item actives of + Nothing -> Nothing + Just actives -> Just (XChart actives finals) + +insertXChart (XChart actives finals) item@(Final _ _ _ _) c = + case MM.insert' c item finals of + Nothing -> Nothing + Just finals -> Just (XChart actives finals) + +lookupXChartAct (XChart actives finals) c = actives MM.! c +lookupXChartFinal (XChart actives finals) c = finals MM.! c + +xchart2syntaxchart :: XChart FCat -> ParserInfo -> SyntaxChart (CId,[Profile]) (FCat,RangeRec) +xchart2syntaxchart (XChart actives finals) pinfo = + accumAssoc groupSyntaxNodes $ + [ case node of + SNode ruleid rrecs -> let FFun fun prof _ = functions pinfo ! ruleid + in ((cat,found), SNode (fun,prof) (zip rhs rrecs)) + SString s -> ((cat,found), SString s) + SInt n -> ((cat,found), SInt n) + SFloat f -> ((cat,found), SFloat f) + | (Final found node rhs cat) <- MM.elems finals + ] + +literals :: ParserInfoEx -> Input FToken -> [Item] +literals pinfoex toks = + [let (c,node) = lexer t in (Final [rng] node [] c) | (t,rngs) <- aAssocs (inputToken toks), rng <- rngs, not (t `elem` grammarToks pinfoex)] + 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 :: ParserInfo -> [FCat] -> Input FToken -> [Item] +initialTD pinfo starts toks = + do cat <- starts + (ruleid,args) <- topdownRules pinfo cat + return (Active [] (Range 0 0) 0 0 (emptyChildren ruleid args) args cat) + +topdownRules pinfo cat = f cat [] + where + f cat rules = maybe rules (Set.fold g rules) (IntMap.lookup cat (productions pinfo)) + + g (FApply ruleid args) rules = (ruleid,args) : rules + g (FCoerce cat) rules = f cat rules + + +---------------------------------------------------------------------- +-- Kilbury -- + +initialBU :: ParserInfo -> ParserInfoEx -> Input FToken -> [Item] +initialBU pinfo pinfoex toks = + do (tok,rngs) <- aAssocs (inputToken toks) + (ruleid,args,cat) <- leftcornerTokens pinfoex ? tok + rng <- rngs + return (Active [] rng 0 1 (emptyChildren ruleid args) args cat) + ++ + do (ruleid,args,cat) <- epsilonRules pinfoex + let FFun _ _ _ = functions pinfo ! ruleid + return (Active [] EmptyRange 0 0 (emptyChildren ruleid args) args cat) diff --git a/src/runtime/haskell/PGF/Parsing/FCFG/Incremental.hs b/src/runtime/haskell/PGF/Parsing/FCFG/Incremental.hs new file mode 100644 index 000000000..296a0d33b --- /dev/null +++ b/src/runtime/haskell/PGF/Parsing/FCFG/Incremental.hs @@ -0,0 +1,371 @@ +{-# LANGUAGE BangPatterns #-} +module PGF.Parsing.FCFG.Incremental + ( ParseState + , ErrorState + , initState + , nextState + , getCompletions + , recoveryStates + , extractTrees + , parse + , parseWithRecovery + ) where + +import Data.Array.IArray +import Data.Array.Base (unsafeAt) +import Data.List (isPrefixOf, foldl') +import Data.Maybe (fromMaybe, maybe) +import qualified Data.Map as Map +import qualified GF.Data.TrieMap as TMap +import qualified Data.IntMap as IntMap +import qualified Data.Set as Set +import Control.Monad + +import GF.Data.SortedList +import PGF.CId +import PGF.Data +import PGF.Expr(Tree) +import PGF.Macros +import PGF.TypeCheck +import Debug.Trace + +parse :: PGF -> Language -> Type -> [String] -> [Tree] +parse pgf lang typ toks = loop (initState pgf lang typ) toks + where + loop ps [] = extractTrees ps typ + loop ps (t:ts) = case nextState ps t of + Left es -> [] + Right ps -> loop ps ts + +parseWithRecovery :: PGF -> Language -> Type -> [Type] -> [String] -> [Tree] +parseWithRecovery pgf lang typ open_typs toks = accept (initState pgf lang typ) toks + where + accept ps [] = extractTrees ps typ + accept ps (t:ts) = + case nextState ps t of + Right ps -> accept ps ts + Left es -> skip (recoveryStates open_typs es) ts + + skip ps_map [] = extractTrees (fst ps_map) typ + skip ps_map (t:ts) = + case Map.lookup t (snd ps_map) of + Just ps -> accept ps ts + Nothing -> skip ps_map ts + +-- | Creates an initial parsing state for a given language and +-- startup category. +initState :: PGF -> Language -> Type -> ParseState +initState pgf lang (DTyp _ start _) = + let items = do + cat <- fromMaybe [] (Map.lookup start (startCats pinfo)) + (funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args) + [] cat (productions pinfo) + let FFun fn _ lins = functions pinfo ! funid + (lbl,seqid) <- assocs lins + return (Active 0 0 funid seqid args (AK cat lbl)) + + pinfo = + case lookParser pgf lang of + Just pinfo -> pinfo + _ -> error ("Unknown language: " ++ showCId lang) + + in PState pgf + pinfo + (Chart emptyAC [] emptyPC (productions pinfo) (totalCats pinfo) 0) + (TMap.singleton [] (Set.fromList items)) + +-- | From the current state and the next token +-- 'nextState' computes a new state, where the token +-- is consumed and the current position is shifted by one. +-- If the new token cannot be accepted then an error state +-- is returned. +nextState :: ParseState -> String -> Either ErrorState ParseState +nextState (PState pgf pinfo chart items) t = + let (mb_agenda,map_items) = TMap.decompose items + agenda = maybe [] Set.toList mb_agenda + acc = fromMaybe TMap.empty (Map.lookup t map_items) + (acc1,chart1) = process (Just t) add (sequences pinfo) (functions pinfo) agenda acc chart + chart2 = chart1{ active =emptyAC + , actives=active chart1 : actives chart1 + , passive=emptyPC + , offset =offset chart1+1 + } + in if TMap.null acc1 + then Left (EState pgf pinfo chart2) + else Right (PState pgf pinfo chart2 acc1) + where + add (tok:toks) item acc + | tok == t = TMap.insertWith Set.union toks (Set.singleton item) acc + add _ item acc = acc + +-- | If the next token is not known but only its prefix (possible empty prefix) +-- then the 'getCompletions' function can be used to calculate the possible +-- next words and the consequent states. This is used for word completions in +-- the GF interpreter. +getCompletions :: ParseState -> String -> Map.Map String ParseState +getCompletions (PState pgf pinfo chart items) w = + let (mb_agenda,map_items) = TMap.decompose items + agenda = maybe [] Set.toList mb_agenda + acc = Map.filterWithKey (\tok _ -> isPrefixOf w tok) map_items + (acc',chart1) = process Nothing add (sequences pinfo) (functions pinfo) agenda acc chart + chart2 = chart1{ active =emptyAC + , actives=active chart1 : actives chart1 + , passive=emptyPC + , offset =offset chart1+1 + } + in fmap (PState pgf pinfo chart2) acc' + where + add (tok:toks) item acc + | isPrefixOf w tok = Map.insertWith (TMap.unionWith Set.union) tok (TMap.singleton toks (Set.singleton item)) acc + add _ item acc = acc + +recoveryStates :: [Type] -> ErrorState -> (ParseState, Map.Map String ParseState) +recoveryStates open_types (EState pgf pinfo chart) = + let open_fcats = concatMap type2fcats open_types + agenda = foldl (complete open_fcats) [] (actives chart) + (acc,chart1) = process Nothing add (sequences pinfo) (functions pinfo) agenda Map.empty chart + chart2 = chart1{ active =emptyAC + , actives=active chart1 : actives chart1 + , passive=emptyPC + , offset =offset chart1+1 + } + in (PState pgf pinfo chart (TMap.singleton [] (Set.fromList agenda)), fmap (PState pgf pinfo chart2) acc) + where + type2fcats (DTyp _ cat _) = fromMaybe [] (Map.lookup cat (startCats pinfo)) + + complete open_fcats items ac = + foldl (Set.fold (\(Active j' ppos funid seqid args keyc) -> + (:) (Active j' (ppos+1) funid seqid args keyc))) + items + [set | fcat <- open_fcats, set <- lookupACByFCat fcat ac] + + add (tok:toks) item acc = Map.insertWith (TMap.unionWith Set.union) tok (TMap.singleton toks (Set.singleton item)) acc + +-- | This function extracts the list of all completed parse trees +-- that spans the whole input consumed so far. The trees are also +-- limited by the category specified, which is usually +-- the same as the startup category. +extractTrees :: ParseState -> Type -> [Tree] +extractTrees (PState pgf pinfo chart items) ty@(DTyp _ start _) = + nubsort [e1 | e <- exps, Right e1 <- [checkExpr pgf e ty]] + where + (mb_agenda,acc) = TMap.decompose items + agenda = maybe [] Set.toList mb_agenda + (_,st) = process Nothing (\_ _ -> id) (sequences pinfo) (functions pinfo) agenda () chart + + exps = do + cat <- fromMaybe [] (Map.lookup start (startCats pinfo)) + (funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args) + [] cat (productions pinfo) + let FFun fn _ lins = functions pinfo ! funid + lbl <- indices lins + Just fid <- [lookupPC (PK cat lbl 0) (passive st)] + (fvs,tree) <- go Set.empty 0 (0,fid) + guard (Set.null fvs) + return tree + + go rec fcat' (d,fcat) + | fcat < totalCats pinfo = return (Set.empty,EMeta (fcat'*10+d)) -- FIXME: here we assume that every rule has at most 10 arguments + | Set.member fcat rec = mzero + | otherwise = foldForest (\funid args trees -> + do let FFun fn _ lins = functions pinfo ! funid + args <- mapM (go (Set.insert fcat rec) fcat) (zip [0..] args) + check_ho_fun fn args + `mplus` + trees) + (\const _ trees -> + return (freeVar const,const) + `mplus` + trees) + [] fcat (forest st) + + check_ho_fun fun args + | fun == _V = return (head args) + | fun == _B = return (foldl1 Set.difference (map fst args), foldr (\x e -> EAbs Explicit (mkVar (snd x)) e) (snd (head args)) (tail args)) + | otherwise = return (Set.unions (map fst args),foldl (\e x -> EApp e (snd x)) (EFun fun) args) + + mkVar (EFun v) = v + mkVar (EMeta _) = wildCId + + freeVar (EFun v) = Set.singleton v + freeVar _ = Set.empty + +_B = mkCId "_B" +_V = mkCId "_V" + +process mbt fn !seqs !funs [] acc chart = (acc,chart) +process mbt fn !seqs !funs (item@(Active j ppos funid seqid args key0):items) acc chart + | inRange (bounds lin) ppos = + case unsafeAt lin ppos of + FSymCat d r -> let !fid = args !! d + key = AK fid r + + items2 = case lookupPC (mkPK key k) (passive chart) of + Nothing -> items + Just id -> (Active j (ppos+1) funid seqid (updateAt d id args) key0) : items + items3 = foldForest (\funid args items -> Active k 0 funid (rhs funid r) args key : items) + (\_ _ items -> items) + items2 fid (forest chart) + in case lookupAC key (active chart) of + Nothing -> process mbt fn seqs funs items3 acc chart{active=insertAC key (Set.singleton item) (active chart)} + Just set | Set.member item set -> process mbt fn seqs funs items acc chart + | otherwise -> process mbt fn seqs funs items2 acc chart{active=insertAC key (Set.insert item set) (active chart)} + FSymKS toks -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc + in process mbt fn seqs funs items acc' chart + FSymKP strs vars + -> let !acc' = foldl (\acc toks -> fn toks (Active j (ppos+1) funid seqid args key0) acc) acc + (strs:[strs' | Alt strs' _ <- vars]) + in process mbt fn seqs funs items acc' chart + FSymLit d r -> let !fid = args !! d + in case [ts | FConst _ ts <- maybe [] Set.toList (IntMap.lookup fid (forest chart))] of + (toks:_) -> let !acc' = fn toks (Active j (ppos+1) funid seqid args key0) acc + in process mbt fn seqs funs items acc' chart + [] -> case litCatMatch fid mbt of + Just (toks,lit) -> let fid' = nextId chart + !acc' = fn toks (Active j (ppos+1) funid seqid (updateAt d fid' args) key0) acc + in process mbt fn seqs funs items acc' chart{forest=IntMap.insert fid' (Set.singleton (FConst lit toks)) (forest chart) + ,nextId=nextId chart+1 + } + Nothing -> process mbt fn seqs funs items acc chart + | otherwise = + case lookupPC (mkPK key0 j) (passive chart) of + Nothing -> let fid = nextId chart + + items2 = case lookupAC key0 ((active chart:actives chart) !! (k-j)) of + Nothing -> items + Just set -> Set.fold (\(Active j' ppos funid seqid args keyc) -> + let FSymCat d _ = unsafeAt (unsafeAt seqs seqid) ppos + in (:) (Active j' (ppos+1) funid seqid (updateAt d fid args) keyc)) items set + in process mbt fn seqs funs items2 acc chart{passive=insertPC (mkPK key0 j) fid (passive chart) + ,forest =IntMap.insert fid (Set.singleton (FApply funid args)) (forest chart) + ,nextId =nextId chart+1 + } + Just id -> let items2 = [Active k 0 funid (rhs funid r) args (AK id r) | r <- labelsAC id (active chart)] ++ items + in process mbt fn seqs funs items2 acc chart{forest = IntMap.insertWith Set.union id (Set.singleton (FApply funid args)) (forest chart)} + where + !lin = unsafeAt seqs seqid + !k = offset chart + + mkPK (AK fid lbl) j = PK fid lbl j + + rhs funid lbl = unsafeAt lins lbl + where + FFun _ _ lins = unsafeAt funs funid + + +updateAt :: Int -> a -> [a] -> [a] +updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs] + +litCatMatch fcat (Just t) + | fcat == fcatString = Just ([t],ELit (LStr t)) + | fcat == fcatInt = case reads t of {[(n,"")] -> Just ([t],ELit (LInt n)); + _ -> Nothing } + | fcat == fcatFloat = case reads t of {[(d,"")] -> Just ([t],ELit (LFlt d)); + _ -> Nothing } + | fcat == fcatVar = Just ([t],EFun (mkCId t)) +litCatMatch _ _ = Nothing + + +---------------------------------------------------------------- +-- Active Chart +---------------------------------------------------------------- + +data Active + = Active {-# UNPACK #-} !Int + {-# UNPACK #-} !FPointPos + {-# UNPACK #-} !FunId + {-# UNPACK #-} !SeqId + [FCat] + {-# UNPACK #-} !ActiveKey + deriving (Eq,Show,Ord) +data ActiveKey + = AK {-# UNPACK #-} !FCat + {-# UNPACK #-} !FIndex + deriving (Eq,Ord,Show) +type ActiveChart = IntMap.IntMap (IntMap.IntMap (Set.Set Active)) + +emptyAC :: ActiveChart +emptyAC = IntMap.empty + +lookupAC :: ActiveKey -> ActiveChart -> Maybe (Set.Set Active) +lookupAC (AK fcat l) chart = IntMap.lookup fcat chart >>= IntMap.lookup l + +lookupACByFCat :: FCat -> ActiveChart -> [Set.Set Active] +lookupACByFCat fcat chart = + case IntMap.lookup fcat chart of + Nothing -> [] + Just map -> IntMap.elems map + +labelsAC :: FCat -> ActiveChart -> [FIndex] +labelsAC fcat chart = + case IntMap.lookup fcat chart of + Nothing -> [] + Just map -> IntMap.keys map + +insertAC :: ActiveKey -> Set.Set Active -> ActiveChart -> ActiveChart +insertAC (AK fcat l) set chart = IntMap.insertWith IntMap.union fcat (IntMap.singleton l set) chart + + +---------------------------------------------------------------- +-- Passive Chart +---------------------------------------------------------------- + +data PassiveKey + = PK {-# UNPACK #-} !FCat + {-# UNPACK #-} !FIndex + {-# UNPACK #-} !Int + deriving (Eq,Ord,Show) + +type PassiveChart = Map.Map PassiveKey FCat + +emptyPC :: PassiveChart +emptyPC = Map.empty + +lookupPC :: PassiveKey -> PassiveChart -> Maybe FCat +lookupPC key chart = Map.lookup key chart + +insertPC :: PassiveKey -> FCat -> PassiveChart -> PassiveChart +insertPC key fcat chart = Map.insert key fcat chart + + +---------------------------------------------------------------- +-- Forest +---------------------------------------------------------------- + +foldForest :: (FunId -> [FCat] -> b -> b) -> (Expr -> [String] -> b -> b) -> b -> FCat -> IntMap.IntMap (Set.Set Production) -> b +foldForest f g b fcat forest = + case IntMap.lookup fcat forest of + Nothing -> b + Just set -> Set.fold foldProd b set + where + foldProd (FCoerce fcat) b = foldForest f g b fcat forest + foldProd (FApply funid args) b = f funid args b + foldProd (FConst const toks) b = g const toks b + + +---------------------------------------------------------------- +-- Parse State +---------------------------------------------------------------- + +-- | An abstract data type whose values represent +-- the current state in an incremental parser. +data ParseState = PState PGF ParserInfo Chart (TMap.TrieMap String (Set.Set Active)) + +data Chart + = Chart + { active :: ActiveChart + , actives :: [ActiveChart] + , passive :: PassiveChart + , forest :: IntMap.IntMap (Set.Set Production) + , nextId :: {-# UNPACK #-} !FCat + , offset :: {-# UNPACK #-} !Int + } + deriving Show + +---------------------------------------------------------------- +-- Error State +---------------------------------------------------------------- + +-- | An abstract data type whose values represent +-- the state in an incremental parser after an error. +data ErrorState = EState PGF ParserInfo Chart diff --git a/src/runtime/haskell/PGF/Parsing/FCFG/Utilities.hs b/src/runtime/haskell/PGF/Parsing/FCFG/Utilities.hs new file mode 100644 index 000000000..dc0b2dc4a --- /dev/null +++ b/src/runtime/haskell/PGF/Parsing/FCFG/Utilities.hs @@ -0,0 +1,188 @@ +---------------------------------------------------------------------- +-- | +-- 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 PGF.Parsing.FCFG.Utilities where + +import Control.Monad +import Data.Array +import Data.List (groupBy) + +import PGF.CId +import PGF.Data +import PGF.Tree +import GF.Data.Assoc +import GF.Data.Utilities (sameLength, foldMerge, splitBy) + + +------------------------------------------------------------ +-- ranges as single pairs + +type RangeRec = [Range] + +data Range = Range {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | EmptyRange + deriving (Eq, Ord, Show) + +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'] + +minRange :: Range -> Int +minRange (Range i j) = i + +maxRange :: Range -> Int +maxRange (Range i j) = j + + +------------------------------------------------------------ +-- * representaions of input tokens + +data Input t = MkInput { inputBounds :: (Int, Int), + inputToken :: Assoc t [Range] + } + +input :: Ord t => [t] -> Input t +input toks = MkInput inBounds inToken + where + inBounds = (0, length toks) + inToken = accumAssoc id [ (tok, makeRange i j) | (i,j,tok) <- zip3 [0..] [1..] toks ] + +inputMany :: Ord t => [[t]] -> Input t +inputMany toks = MkInput inBounds inToken + where + inBounds = (0, length toks) + inToken = accumAssoc id [ (tok, makeRange i j) | (i,j,ts) <- zip3 [0..] [1..] toks, tok <- ts ] + + +------------------------------------------------------------ +-- * 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,Show) + +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 + +-- ** 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" + + +-- ** 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 + -> [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 +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 + + +applyProfileToForest :: SyntaxForest (CId,[Profile]) -> [SyntaxForest CId] +applyProfileToForest (FNode (fun,profiles) children) + | fun == wildCId = concat chForests + | otherwise = [ FNode fun chForests | not (null chForests) ] + where chForests = concat [ mapM (unifyManyForests . map (forests !!)) profiles | + forests0 <- children, + forests <- mapM applyProfileToForest forests0 ] +applyProfileToForest (FString s) = [FString s] +applyProfileToForest (FInt n) = [FInt n] +applyProfileToForest (FFloat f) = [FFloat f] +applyProfileToForest (FMeta) = [FMeta] + + +forest2trees :: SyntaxForest CId -> [Tree] +forest2trees (FNode n forests) = map (Fun n) $ forests >>= mapM forest2trees +forest2trees (FString s) = [Lit (LStr s)] +forest2trees (FInt n) = [Lit (LInt n)] +forest2trees (FFloat f) = [Lit (LFlt f)] +forest2trees (FMeta) = [Meta 0] diff --git a/src/runtime/haskell/PGF/ShowLinearize.hs b/src/runtime/haskell/PGF/ShowLinearize.hs new file mode 100644 index 000000000..dd3b997a6 --- /dev/null +++ b/src/runtime/haskell/PGF/ShowLinearize.hs @@ -0,0 +1,113 @@ +module PGF.ShowLinearize ( + collectWords, + tableLinearize, + recordLinearize, + termLinearize, + tabularLinearize, + allLinearize, + markLinearize + ) where + +import PGF.CId +import PGF.Data +import PGF.Tree +import PGF.Macros +import PGF.Linearize + +import GF.Data.Operations +import Data.List +import qualified Data.Map as Map + +-- 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 PGF.paramlincat +mkRecord :: Term -> Term -> Record +mkRecord typ trm = case (typ,trm) of + (_, FV ts) -> RFV $ map (mkRecord typ) ts + (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 [], _) -> case realizes trm of + [s] -> RS s + ss -> RFV $ map RS ss + _ -> RS $ show trm ---- printTree trm + where + str = realize + +-- show all branches, without labels and params +allLinearize :: (String -> String) -> PGF -> CId -> Expr -> String +allLinearize unlex pgf lang = concat . map (unlex . pr) . tabularLinearize pgf lang where + pr (p,vs) = unlines vs + +-- show all branches, with labels and params +tableLinearize :: (String -> String) -> PGF -> CId -> Expr -> String +tableLinearize unlex pgf lang = unlines . map pr . tabularLinearize pgf lang where + pr (p,vs) = p +++ ":" +++ unwords (intersperse "|" (map unlex vs)) + +-- create a table from labels+params to variants +tabularLinearize :: PGF -> CId -> Expr -> [(String,[String])] +tabularLinearize pgf lang = branches . recLinearize pgf 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 -> concatMap branches rs + RS s -> [([], [s])] + RCon _ -> [] + +-- show record in GF-source-like syntax +recordLinearize :: PGF -> CId -> Expr -> String +recordLinearize pgf lang = prRecord . recLinearize pgf lang + +-- create a GF-like record, forming the basis of all functions above +recLinearize :: PGF -> CId -> Expr -> Record +recLinearize pgf lang tree = mkRecord typ $ linTree pgf lang tree where + typ = case expr2tree tree of + Fun f _ -> lookParamLincat pgf lang $ valCat $ lookType pgf f + +-- show PGF term +termLinearize :: PGF -> CId -> Expr -> String +termLinearize pgf lang = show . linTree pgf lang + +-- show bracketed markup with references to tree structure +markLinearize :: PGF -> CId -> Expr -> String +markLinearize pgf lang = concat . take 1 . linearizesMark pgf lang + + +-- for Morphology: word, lemma, tags +collectWords :: PGF -> Language -> [(String, [(CId,String)])] +collectWords pgf lang = + concatMap collOne + [(f,c,0) | (f,(DTyp [] c _,_,_)) <- Map.toList $ funs $ abstract pgf] + where + collOne (f,c,i) = + fromRec f [showCId c] (recLinearize pgf lang (foldl EApp (EFun f) (replicate i (EMeta 888)))) + fromRec f v r = case r of + RR rs -> concat [fromRec f v t | (_,t) <- rs] + RT rs -> concat [fromRec f (p:v) t | (p,t) <- rs] + RFV rs -> concatMap (fromRec f v) rs + RS s -> [(s,[(f,unwords (reverse v))])] + RCon c -> [] ---- inherent + diff --git a/src/runtime/haskell/PGF/Tree.hs b/src/runtime/haskell/PGF/Tree.hs new file mode 100644 index 000000000..cb2052cd7 --- /dev/null +++ b/src/runtime/haskell/PGF/Tree.hs @@ -0,0 +1,71 @@ +module PGF.Tree + ( Tree(..), + tree2expr, expr2tree, + prTree + ) where + +import PGF.CId +import PGF.Expr hiding (Tree) + +import Data.Char +import Data.List as List +import Control.Monad +import qualified Text.PrettyPrint as PP +import qualified Text.ParserCombinators.ReadP as RP + +-- | The tree is an evaluated expression in the abstract syntax +-- of the grammar. The type is especially restricted to not +-- allow unapplied lambda abstractions. The tree is used directly +-- from the linearizer and is produced directly from the parser. +data Tree = + Abs [(BindType,CId)] Tree -- ^ lambda abstraction. The list of variables is non-empty + | Var CId -- ^ variable + | Fun CId [Tree] -- ^ function application + | Lit Literal -- ^ literal + | Meta {-# UNPACK #-} !MetaId -- ^ meta variable + deriving (Eq, Ord) + +----------------------------------------------------- +-- Conversion Expr <-> Tree +----------------------------------------------------- + +-- | Converts a tree to expression. The conversion +-- is always total, every tree is a valid expression. +tree2expr :: Tree -> Expr +tree2expr = tree2expr [] + where + tree2expr ys (Fun x ts) = foldl EApp (EFun x) (List.map (tree2expr ys) ts) + tree2expr ys (Lit l) = ELit l + tree2expr ys (Meta n) = EMeta n + tree2expr ys (Abs xs t) = foldr (\(b,x) e -> EAbs b x e) (tree2expr (List.map snd (reverse xs)++ys) t) xs + tree2expr ys (Var x) = case List.lookup x (zip ys [0..]) of + Just i -> EVar i + Nothing -> error "unknown variable" + +-- | Converts an expression to tree. The conversion is only partial. +-- Variables and meta variables of function type and beta redexes are not allowed. +expr2tree :: Expr -> Tree +expr2tree e = abs [] [] e + where + abs ys xs (EAbs b x e) = abs ys ((b,x):xs) e + abs ys xs (ETyped e _) = abs ys xs e + abs ys xs e = case xs of + [] -> app ys [] e + xs -> Abs (reverse xs) (app (map snd xs++ys) [] e) + + app xs as (EApp e1 e2) = app xs ((abs xs [] e2) : as) e1 + app xs as (ELit l) + | List.null as = Lit l + | otherwise = error "literal of function type encountered" + app xs as (EMeta n) + | List.null as = Meta n + | otherwise = error "meta variables of function type are not allowed in trees" + app xs as (EAbs _ x e) = error "beta redexes are not allowed in trees" + app xs as (EVar i) = Var (xs !! i) + app xs as (EFun f) = Fun f as + app xs as (ETyped e _) = app xs as e + + +prTree :: Tree -> String +prTree = showExpr [] . tree2expr + diff --git a/src/runtime/haskell/PGF/Type.hs b/src/runtime/haskell/PGF/Type.hs new file mode 100644 index 000000000..013754a45 --- /dev/null +++ b/src/runtime/haskell/PGF/Type.hs @@ -0,0 +1,103 @@ +module PGF.Type ( Type(..), Hypo, + readType, showType, + mkType, mkHypo, mkDepHypo, mkImplHypo, + pType, ppType, ppHypo ) where + +import PGF.CId +import {-# SOURCE #-} PGF.Expr +import Data.Char +import Data.List +import qualified Text.PrettyPrint as PP +import qualified Text.ParserCombinators.ReadP as RP +import Control.Monad + +-- | To read a type from a 'String', use 'readType'. +data Type = + DTyp [Hypo] CId [Expr] + deriving (Eq,Ord,Show) + +-- | 'Hypo' represents a hypothesis in a type i.e. in the type A -> B, A is the hypothesis +type Hypo = (BindType,CId,Type) + +-- | Reads a 'Type' from a 'String'. +readType :: String -> Maybe Type +readType s = case [x | (x,cs) <- RP.readP_to_S pType s, all isSpace cs] of + [x] -> Just x + _ -> Nothing + +-- | renders type as 'String'. The list +-- of identifiers is the list of all free variables +-- in the expression in order reverse to the order +-- of binding. +showType :: [CId] -> Type -> String +showType vars = PP.render . ppType 0 vars + +-- | creates a type from list of hypothesises, category and +-- list of arguments for the category. The operation +-- @mkType [h_1,...,h_n] C [e_1,...,e_m]@ will create +-- @h_1 -> ... -> h_n -> C e_1 ... e_m@ +mkType :: [Hypo] -> CId -> [Expr] -> Type +mkType hyps cat args = DTyp hyps cat args + +-- | creates hypothesis for non-dependent type i.e. A +mkHypo :: Type -> Hypo +mkHypo ty = (Explicit,wildCId,ty) + +-- | creates hypothesis for dependent type i.e. (x : A) +mkDepHypo :: CId -> Type -> Hypo +mkDepHypo x ty = (Explicit,x,ty) + +-- | creates hypothesis for dependent type with implicit argument i.e. ({x} : A) +mkImplHypo :: CId -> Type -> Hypo +mkImplHypo x ty = (Implicit,x,ty) + +pType :: RP.ReadP Type +pType = do + RP.skipSpaces + hyps <- RP.sepBy (pHypo >>= \h -> RP.skipSpaces >> RP.string "->" >> return h) RP.skipSpaces + RP.skipSpaces + (cat,args) <- pAtom + return (DTyp (concat hyps) cat args) + where + pHypo = + do (cat,args) <- pAtom + return [(Explicit,wildCId,DTyp [] cat args)] + RP.<++ + (RP.between (RP.char '(') (RP.char ')') $ do + xs <- RP.option [(Explicit,wildCId)] $ do + xs <- pBinds + RP.skipSpaces + RP.char ':' + return xs + ty <- pType + return [(b,v,ty) | (b,v) <- xs]) + RP.<++ + (RP.between (RP.char '{') (RP.char '}') $ do + vs <- RP.sepBy1 (RP.skipSpaces >> pCId) (RP.skipSpaces >> RP.char ',') + RP.skipSpaces + RP.char ':' + ty <- pType + return [(Implicit,v,ty) | v <- vs]) + + pAtom = do + cat <- pCId + RP.skipSpaces + args <- RP.sepBy pArg RP.skipSpaces + return (cat, args) + +ppType :: Int -> [CId] -> Type -> PP.Doc +ppType d scope (DTyp hyps cat args) + | null hyps = ppRes scope cat args + | otherwise = let (scope',hdocs) = mapAccumL ppHypo scope hyps + in ppParens (d > 0) (foldr (\hdoc doc -> hdoc PP.<+> PP.text "->" PP.<+> doc) (ppRes scope' cat args) hdocs) + where + ppRes scope cat es = ppCId cat PP.<+> PP.hsep (map (ppExpr 4 scope) es) + +ppHypo scope (Explicit,x,typ) = if x == wildCId + then (scope,ppType 1 scope typ) + else let y = freshName x scope + in (y:scope,PP.parens (ppCId y PP.<+> PP.char ':' PP.<+> ppType 0 scope typ)) +ppHypo scope (Implicit,x,typ) = if x == wildCId + then (scope,PP.parens (PP.braces (ppCId x) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ)) + else let y = freshName x scope + in (y:scope,PP.parens (PP.braces (ppCId y) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ)) diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs new file mode 100644 index 000000000..937c21786 --- /dev/null +++ b/src/runtime/haskell/PGF/TypeCheck.hs @@ -0,0 +1,524 @@ +---------------------------------------------------------------------- +-- | +-- Module : PGF.TypeCheck +-- Maintainer : Krasimir Angelov +-- Stability : (stable) +-- Portability : (portable) +-- +-- Type checking in abstract syntax with dependent types. +-- The type checker also performs renaming and checking for unknown +-- functions. The variable references are replaced by de Bruijn indices. +-- +----------------------------------------------------------------------------- + +module PGF.TypeCheck (checkType, checkExpr, inferExpr, + + ppTcError, TcError(..) + ) where + +import PGF.Data +import PGF.Expr +import PGF.Macros (typeOfHypo) +import PGF.CId + +import Data.Map as Map +import Data.IntMap as IntMap +import Data.Maybe as Maybe +import Data.List as List +import Control.Monad +import Text.PrettyPrint + +----------------------------------------------------- +-- The Scope +----------------------------------------------------- + +data TType = TTyp Env Type +newtype Scope = Scope [(CId,TType)] + +emptyScope = Scope [] + +addScopedVar :: CId -> TType -> Scope -> Scope +addScopedVar x tty (Scope gamma) = Scope ((x,tty):gamma) + +-- | returns the type and the De Bruijn index of a local variable +lookupVar :: CId -> Scope -> Maybe (Int,TType) +lookupVar x (Scope gamma) = listToMaybe [(i,tty) | ((y,tty),i) <- zip gamma [0..], x == y] + +-- | returns the type and the name of a local variable +getVar :: Int -> Scope -> (CId,TType) +getVar i (Scope gamma) = gamma !! i + +scopeEnv :: Scope -> Env +scopeEnv (Scope gamma) = let n = length gamma + in [VGen (n-i-1) [] | i <- [0..n-1]] + +scopeVars :: Scope -> [CId] +scopeVars (Scope gamma) = List.map fst gamma + +scopeSize :: Scope -> Int +scopeSize (Scope gamma) = length gamma + +----------------------------------------------------- +-- The Monad +----------------------------------------------------- + +type MetaStore = IntMap MetaValue +data MetaValue + = MUnbound Scope [Expr -> TcM ()] + | MBound Expr + | MGuarded Expr [Expr -> TcM ()] {-# UNPACK #-} !Int -- the Int is the number of constraints that have to be solved + -- to unlock this meta variable + +newtype TcM a = TcM {unTcM :: Abstr -> MetaId -> MetaStore -> TcResult a} +data TcResult a + = Ok {-# UNPACK #-} !MetaId MetaStore a + | Fail TcError + +instance Monad TcM where + return x = TcM (\abstr metaid ms -> Ok metaid ms x) + f >>= g = TcM (\abstr metaid ms -> case unTcM f abstr metaid ms of + Ok metaid ms x -> unTcM (g x) abstr metaid ms + Fail e -> Fail e) + +instance Functor TcM where + fmap f x = TcM (\abstr metaid ms -> case unTcM x abstr metaid ms of + Ok metaid ms x -> Ok metaid ms (f x) + Fail e -> Fail e) + +lookupCatHyps :: CId -> TcM [Hypo] +lookupCatHyps cat = TcM (\abstr metaid ms -> case Map.lookup cat (cats abstr) of + Just hyps -> Ok metaid ms hyps + Nothing -> Fail (UnknownCat cat)) + +lookupFunType :: CId -> TcM TType +lookupFunType fun = TcM (\abstr metaid ms -> case Map.lookup fun (funs abstr) of + Just (ty,_,_) -> Ok metaid ms (TTyp [] ty) + Nothing -> Fail (UnknownFun fun)) + +newMeta :: Scope -> TcM MetaId +newMeta scope = TcM (\abstr metaid ms -> Ok (metaid+1) (IntMap.insert metaid (MUnbound scope []) ms) metaid) + +newGuardedMeta :: Scope -> Expr -> TcM MetaId +newGuardedMeta scope e = getFuns >>= \funs -> TcM (\abstr metaid ms -> Ok (metaid+1) (IntMap.insert metaid (MGuarded e [] 0) ms) metaid) + +getMeta :: MetaId -> TcM MetaValue +getMeta i = TcM (\abstr metaid ms -> Ok metaid ms $! case IntMap.lookup i ms of + Just mv -> mv) +setMeta :: MetaId -> MetaValue -> TcM () +setMeta i mv = TcM (\abstr metaid ms -> Ok metaid (IntMap.insert i mv ms) ()) + +tcError :: TcError -> TcM a +tcError e = TcM (\abstr metaid ms -> Fail e) + +getFuns :: TcM Funs +getFuns = TcM (\abstr metaid ms -> Ok metaid ms (funs abstr)) + +addConstraint :: MetaId -> MetaId -> Env -> [Value] -> (Value -> TcM ()) -> TcM () +addConstraint i j env vs c = do + funs <- getFuns + mv <- getMeta j + case mv of + MUnbound scope cs -> addRef >> setMeta j (MUnbound scope ((\e -> release >> c (apply funs env e vs)) : cs)) + MBound e -> c (apply funs env e vs) + MGuarded e cs x | x == 0 -> c (apply funs env e vs) + | otherwise -> addRef >> setMeta j (MGuarded e ((\e -> release >> c (apply funs env e vs)) : cs) x) + where + addRef = TcM (\abstr metaid ms -> case IntMap.lookup i ms of + Just (MGuarded e cs x) -> Ok metaid (IntMap.insert i (MGuarded e cs (x+1)) ms) ()) + + release = TcM (\abstr metaid ms -> case IntMap.lookup i ms of + Just (MGuarded e cs x) -> if x == 1 + then unTcM (sequence_ [c e | c <- cs]) abstr metaid (IntMap.insert i (MGuarded e [] 0) ms) + else Ok metaid (IntMap.insert i (MGuarded e cs (x-1)) ms) ()) + +----------------------------------------------------- +-- Type errors +----------------------------------------------------- + +-- | If an error occurs in the typechecking phase +-- the type checker returns not a plain text error message +-- but a 'TcError' structure which describes the error. +data TcError + = UnknownCat CId -- ^ Unknown category name was found. + | UnknownFun CId -- ^ Unknown function name was found. + | WrongCatArgs [CId] Type CId Int Int -- ^ A category was applied to wrong number of arguments. + -- The first integer is the number of expected arguments and + -- the second the number of given arguments. + -- The @[CId]@ argument is the list of free variables + -- in the type. It should be used for the 'showType' function. + | TypeMismatch [CId] Expr Type Type -- ^ The expression is not of the expected type. + -- The first type is the expected type, while + -- the second is the inferred. The @[CId]@ argument is the list + -- of free variables in both the expression and the type. + -- It should be used for the 'showType' and 'showExpr' functions. + | NotFunType [CId] Expr Type -- ^ Something that is not of function type was applied to an argument. + | CannotInferType [CId] Expr -- ^ It is not possible to infer the type of an expression. + | UnresolvedMetaVars [CId] Expr [MetaId] -- ^ Some metavariables have to be instantiated in order to complete the typechecking. + | UnexpectedImplArg [CId] Expr -- ^ Implicit argument was passed where the type doesn't allow it + +-- | Renders the type checking error to a document. See 'Text.PrettyPrint'. +ppTcError :: TcError -> Doc +ppTcError (UnknownCat cat) = text "Category" <+> ppCId cat <+> text "is not in scope" +ppTcError (UnknownFun fun) = text "Function" <+> ppCId fun <+> text "is not in scope" +ppTcError (WrongCatArgs xs ty cat m n) = text "Category" <+> ppCId cat <+> text "should have" <+> int m <+> text "argument(s), but has been given" <+> int n $$ + text "In the type:" <+> ppType 0 xs ty +ppTcError (TypeMismatch xs e ty1 ty2) = text "Couldn't match expected type" <+> ppType 0 xs ty1 $$ + text " against inferred type" <+> ppType 0 xs ty2 $$ + text "In the expression:" <+> ppExpr 0 xs e +ppTcError (NotFunType xs e ty) = text "A function type is expected for the expression" <+> ppExpr 0 xs e <+> text "instead of type" <+> ppType 0 xs ty +ppTcError (CannotInferType xs e) = text "Cannot infer the type of expression" <+> ppExpr 0 xs e +ppTcError (UnresolvedMetaVars xs e ms) = text "Meta variable(s)" <+> fsep (List.map ppMeta ms) <+> text "should be resolved" $$ + text "in the expression:" <+> ppExpr 0 xs e +ppTcError (UnexpectedImplArg xs e) = braces (ppExpr 0 xs e) <+> text "is implicit argument but not implicit argument is expected here" + +----------------------------------------------------- +-- checkType +----------------------------------------------------- + +-- | Check whether a given type is consistent with the abstract +-- syntax of the grammar. +checkType :: PGF -> Type -> Either TcError Type +checkType pgf ty = + case unTcM (tcType emptyScope ty >>= refineType) (abstract pgf) 0 IntMap.empty of + Ok _ ms ty -> Right ty + Fail err -> Left err + +tcType :: Scope -> Type -> TcM Type +tcType scope ty@(DTyp hyps cat es) = do + (scope,hyps) <- tcHypos scope hyps + c_hyps <- lookupCatHyps cat + let m = length es + n = length [ty | (Explicit,x,ty) <- c_hyps] + (delta,es) <- tcCatArgs scope es [] c_hyps ty n m + return (DTyp hyps cat es) + +tcHypos :: Scope -> [Hypo] -> TcM (Scope,[Hypo]) +tcHypos scope [] = return (scope,[]) +tcHypos scope (h:hs) = do + (scope,h ) <- tcHypo scope h + (scope,hs) <- tcHypos scope hs + return (scope,h:hs) + +tcHypo :: Scope -> Hypo -> TcM (Scope,Hypo) +tcHypo scope (b,x,ty) = do + ty <- tcType scope ty + if x == wildCId + then return (scope,(b,x,ty)) + else return (addScopedVar x (TTyp (scopeEnv scope) ty) scope,(b,x,ty)) + +tcCatArgs scope [] delta [] ty0 n m = return (delta,[]) +tcCatArgs scope (EImplArg e:es) delta ((Explicit,x,ty):hs) ty0 n m = tcError (UnexpectedImplArg (scopeVars scope) e) +tcCatArgs scope (EImplArg e:es) delta ((Implicit,x,ty):hs) ty0 n m = do + e <- tcExpr scope e (TTyp delta ty) + funs <- getFuns + (delta,es) <- if x == wildCId + then tcCatArgs scope es delta hs ty0 n m + else tcCatArgs scope es (eval funs (scopeEnv scope) e:delta) hs ty0 n m + return (delta,EImplArg e:es) +tcCatArgs scope es delta ((Implicit,x,ty):hs) ty0 n m = do + i <- newMeta scope + (delta,es) <- if x == wildCId + then tcCatArgs scope es delta hs ty0 n m + else tcCatArgs scope es (VMeta i (scopeEnv scope) [] : delta) hs ty0 n m + return (delta,EImplArg (EMeta i) : es) +tcCatArgs scope (e:es) delta ((Explicit,x,ty):hs) ty0 n m = do + e <- tcExpr scope e (TTyp delta ty) + funs <- getFuns + (delta,es) <- if x == wildCId + then tcCatArgs scope es delta hs ty0 n m + else tcCatArgs scope es (eval funs (scopeEnv scope) e:delta) hs ty0 n m + return (delta,e:es) +tcCatArgs scope _ delta _ ty0@(DTyp _ cat _) n m = do + tcError (WrongCatArgs (scopeVars scope) ty0 cat n m) + +----------------------------------------------------- +-- checkExpr +----------------------------------------------------- + +-- | Checks an expression against a specified type. +checkExpr :: PGF -> Expr -> Type -> Either TcError Expr +checkExpr pgf e ty = + case unTcM (do e <- tcExpr emptyScope e (TTyp [] ty) + e <- refineExpr e + checkResolvedMetaStore emptyScope e + return e) (abstract pgf) 0 IntMap.empty of + Ok _ ms e -> Right e + Fail err -> Left err + +tcExpr :: Scope -> Expr -> TType -> TcM Expr +tcExpr scope e0@(EAbs Implicit x e) tty = + case tty of + TTyp delta (DTyp ((Implicit,y,ty):hs) c es) -> do e <- if y == wildCId + then tcExpr (addScopedVar x (TTyp delta ty) scope) + e (TTyp delta (DTyp hs c es)) + else tcExpr (addScopedVar x (TTyp delta ty) scope) + e (TTyp ((VGen (scopeSize scope) []):delta) (DTyp hs c es)) + return (EAbs Implicit x e) + _ -> do ty <- evalType (scopeSize scope) tty + tcError (NotFunType (scopeVars scope) e0 ty) +tcExpr scope e0 (TTyp delta (DTyp ((Implicit,y,ty):hs) c es)) = do + e0 <- if y == wildCId + then tcExpr (addScopedVar wildCId (TTyp delta ty) scope) + e0 (TTyp delta (DTyp hs c es)) + else tcExpr (addScopedVar wildCId (TTyp delta ty) scope) + e0 (TTyp ((VGen (scopeSize scope) []):delta) (DTyp hs c es)) + return (EAbs Implicit wildCId e0) +tcExpr scope e0@(EAbs Explicit x e) tty = + case tty of + TTyp delta (DTyp ((Explicit,y,ty):hs) c es) -> do e <- if y == wildCId + then tcExpr (addScopedVar x (TTyp delta ty) scope) + e (TTyp delta (DTyp hs c es)) + else tcExpr (addScopedVar x (TTyp delta ty) scope) + e (TTyp ((VGen (scopeSize scope) []):delta) (DTyp hs c es)) + return (EAbs Explicit x e) + _ -> do ty <- evalType (scopeSize scope) tty + tcError (NotFunType (scopeVars scope) e0 ty) +tcExpr scope (EMeta _) tty = do + i <- newMeta scope + return (EMeta i) +tcExpr scope e0 tty = do + (e0,tty0) <- infExpr scope e0 + i <- newGuardedMeta scope e0 + eqType scope (scopeSize scope) i tty tty0 + return (EMeta i) + + +----------------------------------------------------- +-- inferExpr +----------------------------------------------------- + +-- | Tries to infer the type of a given expression. Note that +-- even if the expression is type correct it is not always +-- possible to infer its type in the GF type system. +-- In this case the function returns the 'CannotInferType' error. +inferExpr :: PGF -> Expr -> Either TcError (Expr,Type) +inferExpr pgf e = + case unTcM (do (e,tty) <- infExpr emptyScope e + e <- refineExpr e + checkResolvedMetaStore emptyScope e + ty <- evalType 0 tty + return (e,ty)) (abstract pgf) 1 IntMap.empty of + Ok _ ms (e,ty) -> Right (e,ty) + Fail err -> Left err + +infExpr :: Scope -> Expr -> TcM (Expr,TType) +infExpr scope e0@(EApp e1 e2) = do + (e1,TTyp delta ty) <- infExpr scope e1 + (e0,delta,ty) <- tcArg scope e1 e2 delta ty + return (e0,TTyp delta ty) +infExpr scope e0@(EFun x) = do + case lookupVar x scope of + Just (i,tty) -> return (EVar i,tty) + Nothing -> do tty <- lookupFunType x + return (e0,tty) +infExpr scope e0@(EVar i) = do + return (e0,snd (getVar i scope)) +infExpr scope e0@(ELit l) = do + let cat = case l of + LStr _ -> mkCId "String" + LInt _ -> mkCId "Int" + LFlt _ -> mkCId "Float" + return (e0,TTyp [] (DTyp [] cat [])) +infExpr scope (ETyped e ty) = do + ty <- tcType scope ty + e <- tcExpr scope e (TTyp (scopeEnv scope) ty) + return (ETyped e ty,TTyp (scopeEnv scope) ty) +infExpr scope (EImplArg e) = do + (e,tty) <- infExpr scope e + return (EImplArg e,tty) +infExpr scope e = tcError (CannotInferType (scopeVars scope) e) + +tcArg scope e1 e2 delta ty0@(DTyp [] c es) = do + ty1 <- evalType (scopeSize scope) (TTyp delta ty0) + tcError (NotFunType (scopeVars scope) e1 ty1) +tcArg scope e1 (EImplArg e2) delta ty0@(DTyp ((Explicit,x,ty):hs) c es) = tcError (UnexpectedImplArg (scopeVars scope) e2) +tcArg scope e1 (EImplArg e2) delta ty0@(DTyp ((Implicit,x,ty):hs) c es) = do + e2 <- tcExpr scope e2 (TTyp delta ty) + funs <- getFuns + if x == wildCId + then return (EApp e1 (EImplArg e2), delta,DTyp hs c es) + else return (EApp e1 (EImplArg e2),eval funs (scopeEnv scope) e2:delta,DTyp hs c es) +tcArg scope e1 e2 delta ty0@(DTyp ((Explicit,x,ty):hs) c es) = do + e2 <- tcExpr scope e2 (TTyp delta ty) + funs <- getFuns + if x == wildCId + then return (EApp e1 e2, delta,DTyp hs c es) + else return (EApp e1 e2,eval funs (scopeEnv scope) e2:delta,DTyp hs c es) +tcArg scope e1 e2 delta ty0@(DTyp ((Implicit,x,ty):hs) c es) = do + i <- newMeta scope + if x == wildCId + then tcArg scope (EApp e1 (EImplArg (EMeta i))) e2 delta (DTyp hs c es) + else tcArg scope (EApp e1 (EImplArg (EMeta i))) e2 (VMeta i (scopeEnv scope) [] : delta) (DTyp hs c es) + +----------------------------------------------------- +-- eqType +----------------------------------------------------- + +eqType :: Scope -> Int -> MetaId -> TType -> TType -> TcM () +eqType scope k i0 tty1@(TTyp delta1 ty1@(DTyp hyps1 cat1 es1)) tty2@(TTyp delta2 ty2@(DTyp hyps2 cat2 es2)) + | cat1 == cat2 = do (k,delta1,delta2) <- eqHyps k delta1 hyps1 delta2 hyps2 + sequence_ [eqExpr k delta1 e1 delta2 e2 | (e1,e2) <- zip es1 es2] + | otherwise = raiseTypeMatchError + where + raiseTypeMatchError = do ty1 <- evalType k tty1 + ty2 <- evalType k tty2 + e <- refineExpr (EMeta i0) + tcError (TypeMismatch (scopeVars scope) e ty1 ty2) + + eqHyps :: Int -> Env -> [Hypo] -> Env -> [Hypo] -> TcM (Int,Env,Env) + eqHyps k delta1 [] delta2 [] = + return (k,delta1,delta2) + eqHyps k delta1 ((_,x,ty1) : h1s) delta2 ((_,y,ty2) : h2s) = do + eqType scope k i0 (TTyp delta1 ty1) (TTyp delta2 ty2) + if x == wildCId && y == wildCId + then eqHyps k delta1 h1s delta2 h2s + else if x /= wildCId && y /= wildCId + then eqHyps (k+1) ((VGen k []):delta1) h1s ((VGen k []):delta2) h2s + else raiseTypeMatchError + eqHyps k delta1 h1s delta2 h2s = raiseTypeMatchError + + eqExpr :: Int -> Env -> Expr -> Env -> Expr -> TcM () + eqExpr k env1 e1 env2 e2 = do + funs <- getFuns + eqValue k (eval funs env1 e1) (eval funs env2 e2) + + eqValue :: Int -> Value -> Value -> TcM () + eqValue k v1 v2 = do + v1 <- deRef v1 + v2 <- deRef v2 + eqValue' k v1 v2 + + deRef v@(VMeta i env vs) = do + mv <- getMeta i + funs <- getFuns + case mv of + MBound e -> deRef (apply funs env e vs) + MGuarded e _ x | x == 0 -> deRef (apply funs env e vs) + | otherwise -> return v + MUnbound _ _ -> return v + deRef v = return v + + eqValue' k (VSusp i env vs1 c) v2 = addConstraint i0 i env vs1 (\v1 -> eqValue k (c v1) v2) + eqValue' k v1 (VSusp i env vs2 c) = addConstraint i0 i env vs2 (\v2 -> eqValue k v1 (c v2)) + eqValue' k (VMeta i env1 vs1) (VMeta j env2 vs2) | i == j = zipWithM_ (eqValue k) vs1 vs2 + eqValue' k (VMeta i env1 vs1) v2 = do (MUnbound scopei cs) <- getMeta i + e2 <- mkLam i scopei env1 vs1 v2 + setMeta i (MBound e2) + sequence_ [c e2 | c <- cs] + eqValue' k v1 (VMeta i env2 vs2) = do (MUnbound scopei cs) <- getMeta i + e1 <- mkLam i scopei env2 vs2 v1 + setMeta i (MBound e1) + sequence_ [c e1 | c <- cs] + eqValue' k (VApp f1 vs1) (VApp f2 vs2) | f1 == f2 = zipWithM_ (eqValue k) vs1 vs2 + eqValue' k (VLit l1) (VLit l2 ) | l1 == l2 = return () + eqValue' k (VGen i vs1) (VGen j vs2) | i == j = zipWithM_ (eqValue k) vs1 vs2 + eqValue' k (VClosure env1 (EAbs _ x1 e1)) (VClosure env2 (EAbs _ x2 e2)) = let v = VGen k [] + in eqExpr (k+1) (v:env1) e1 (v:env2) e2 + eqValue' k v1 v2 = raiseTypeMatchError + + mkLam i scope env vs0 v = do + let k = scopeSize scope + vs = reverse (take k env) ++ vs0 + xs = nub [i | VGen i [] <- vs] + if length vs == length xs + then return () + else raiseTypeMatchError + v <- occurCheck i k xs v + funs <- getFuns + return (addLam vs0 (value2expr funs (length xs) v)) + where + addLam [] e = e + addLam (v:vs) e = EAbs Explicit var (addLam vs e) + + var = mkCId "v" + + occurCheck i0 k xs (VApp f vs) = do vs <- mapM (occurCheck i0 k xs) vs + return (VApp f vs) + occurCheck i0 k xs (VLit l) = return (VLit l) + occurCheck i0 k xs (VMeta i env vs) = do if i == i0 + then raiseTypeMatchError + else return () + mv <- getMeta i + funs <- getFuns + case mv of + MBound e -> occurCheck i0 k xs (apply funs env e vs) + MGuarded e _ _ -> occurCheck i0 k xs (apply funs env e vs) + MUnbound scopei _ | scopeSize scopei > k -> raiseTypeMatchError + | otherwise -> do vs <- mapM (occurCheck i0 k xs) vs + return (VMeta i env vs) + occurCheck i0 k xs (VSusp i env vs cnt) = do addConstraint i0 i env vs (\v -> occurCheck i0 k xs (cnt v) >> return ()) + return (VSusp i env vs cnt) + occurCheck i0 k xs (VGen i vs) = case List.findIndex (==i) xs of + Just i -> do vs <- mapM (occurCheck i0 k xs) vs + return (VGen i vs) + Nothing -> raiseTypeMatchError + occurCheck i0 k xs (VClosure env e) = do env <- mapM (occurCheck i0 k xs) env + return (VClosure env e) + + +----------------------------------------------------------- +-- check for meta variables that still have to be resolved +----------------------------------------------------------- + +checkResolvedMetaStore :: Scope -> Expr -> TcM () +checkResolvedMetaStore scope e = TcM (\abstr metaid ms -> + let xs = [i | (i,mv) <- IntMap.toList ms, not (isResolved mv)] + in if List.null xs + then Ok metaid ms () + else Fail (UnresolvedMetaVars (scopeVars scope) e xs)) + where + isResolved (MUnbound _ []) = True + isResolved (MGuarded _ _ _) = True + isResolved (MBound _) = True + isResolved _ = False + +----------------------------------------------------- +-- evalType +----------------------------------------------------- + +evalType :: Int -> TType -> TcM Type +evalType k (TTyp delta ty) = do funs <- getFuns + refineType (evalTy funs k delta ty) + where + evalTy sig k delta (DTyp hyps cat es) = + let ((k1,delta1),hyps1) = mapAccumL (evalHypo sig) (k,delta) hyps + in DTyp hyps1 cat (List.map (normalForm sig k1 delta1) es) + + evalHypo sig (k,delta) (b,x,ty) = + if x == wildCId + then ((k, delta),(b,x,evalTy sig k delta ty)) + else ((k+1,(VGen k []):delta),(b,x,evalTy sig k delta ty)) + + +----------------------------------------------------- +-- refinement +----------------------------------------------------- + +refineExpr :: Expr -> TcM Expr +refineExpr e = TcM (\abstr metaid ms -> Ok metaid ms (refineExpr_ ms e)) + +refineExpr_ ms e = refine e + where + refine (EAbs b x e) = EAbs b x (refine e) + refine (EApp e1 e2) = EApp (refine e1) (refine e2) + refine (ELit l) = ELit l + refine (EMeta i) = case IntMap.lookup i ms of + Just (MBound e ) -> refine e + Just (MGuarded e _ _) -> refine e + _ -> EMeta i + refine (EFun f) = EFun f + refine (EVar i) = EVar i + refine (ETyped e ty) = ETyped (refine e) (refineType_ ms ty) + refine (EImplArg e) = EImplArg (refine e) + +refineType :: Type -> TcM Type +refineType ty = TcM (\abstr metaid ms -> Ok metaid ms (refineType_ ms ty)) + +refineType_ ms (DTyp hyps cat es) = DTyp [(b,x,refineType_ ms ty) | (b,x,ty) <- hyps] cat (List.map (refineExpr_ ms) es) + +value2expr sig i (VApp f vs) = foldl EApp (EFun f) (List.map (value2expr sig i) vs) +value2expr sig i (VGen j vs) = foldl EApp (EVar (i-j-1)) (List.map (value2expr sig i) vs) +value2expr sig i (VMeta j env vs) = foldl EApp (EMeta j) (List.map (value2expr sig i) vs) +value2expr sig i (VSusp j env vs k) = value2expr sig i (k (VGen j vs)) +value2expr sig i (VLit l) = ELit l +value2expr sig i (VClosure env (EAbs b x e)) = EAbs b x (value2expr sig (i+1) (eval sig ((VGen i []):env) e)) diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs new file mode 100644 index 000000000..429551f54 --- /dev/null +++ b/src/runtime/haskell/PGF/VisualizeTree.hs @@ -0,0 +1,353 @@ +---------------------------------------------------------------------- +-- | +-- 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 PGF.VisualizeTree ( graphvizAbstractTree + , graphvizParseTree + , graphvizDependencyTree + , graphvizAlignment + , tree2mk + , getDepLabels + , PosText(..), readPosText + ) where + +import PGF.CId (CId,showCId,pCId,mkCId) +import PGF.Data +import PGF.Tree +import PGF.Expr (showExpr) +import PGF.Linearize +import PGF.Macros (lookValCat) + +import qualified Data.Map as Map +import Data.List (intersperse,nub,isPrefixOf,sort,sortBy) +import Data.Char (isDigit) +import qualified Text.ParserCombinators.ReadP as RP + +import Debug.Trace + +graphvizAbstractTree :: PGF -> (Bool,Bool) -> Expr -> String +graphvizAbstractTree pgf funscats = prGraph False . tree2graph pgf funscats . expr2tree + +tree2graph :: PGF -> (Bool,Bool) -> Tree -> [String] +tree2graph pgf (funs,cats) = prf [] where + prf ps t = let (nod,lab) = prn ps t in + (nod ++ " [label = " ++ lab ++ ", style = \"solid\", shape = \"plaintext\"] ;") : + case t of + Fun cid trees -> + [ pra (j:ps) nod t | (j,t) <- zip [0..] trees] ++ + concat [prf (j:ps) t | (j,t) <- zip [0..] trees] + Abs xs (Fun cid trees) -> + [ pra (j:ps) nod t | (j,t) <- zip [0..] trees] ++ + concat [prf (j:ps) t | (j,t) <- zip [0..] trees] + _ -> [] + prn ps t = case t of + Fun cid _ -> + let + fun = if funs then showCId cid else "" + cat = if cats then prCat cid else "" + colon = if funs && cats then " : " else "" + lab = "\"" ++ fun ++ colon ++ cat ++ "\"" + in (show(show (ps :: [Int])),lab) + Abs bs tree -> + let fun = case tree of + Fun cid _ -> Fun cid [] + _ -> tree + in (show(show (ps :: [Int])),"\"" ++ esc (prTree (Abs bs fun)) ++ "\"") + _ -> (show(show (ps :: [Int])),"\"" ++ esc (prTree t) ++ "\"") + pra i nod t = nod ++ arr ++ fst (prn i t) ++ " [style = \"solid\"];" + arr = " -- " -- if digr then " -> " else " -- " + prCat = showCId . lookValCat pgf + esc = concatMap (\c -> if c =='\\' then [c,c] else [c]) --- escape backslash in abstracts + +prGraph digr ns = concat $ map (++"\n") $ [graph ++ "{\n"] ++ ns ++ ["}"] where + graph = if digr then "digraph" else "graph" + + +-- replace each non-atomic constructor with mkC, where C is the val cat +tree2mk :: PGF -> Expr -> String +tree2mk pgf = showExpr [] . tree2expr . t2m . expr2tree where + t2m t = case t of + Fun cid [] -> t + Fun cid ts -> Fun (mk cid) (map t2m ts) + _ -> t + mk = mkCId . ("mk" ++) . showCId . lookValCat pgf + +-- dependency trees from Linearize.linearizeMark + +graphvizDependencyTree :: String -> Bool -> Maybe Labels -> Maybe String -> PGF -> CId -> Expr -> String +graphvizDependencyTree format debug mlab ms pgf lang exp = case format of + "malt" -> unlines (lin2dep format) + "malt_input" -> unlines (lin2dep format) + _ -> prGraph True (lin2dep format) + + where + + lin2dep format = trace (ifd (show sortedNodes ++ show nodeWords)) $ case format of + "malt" -> map (concat . intersperse "\t") wnodes + "malt_input" -> map (concat . intersperse "\t" . take 6) wnodes + _ -> prelude ++ nodes ++ links + + ifd s = if debug then s else [] + + pot = readPosText $ head $ linearizesMark pgf lang exp + ---- use Just str if you have str to match against + + prelude = ["rankdir=LR ;", "node [shape = plaintext] ;"] + + nodes = map mkNode nodeWords + mkNode (i,((_,p),ss)) = + node p ++ " [label = \"" ++ show i ++ ". " ++ ifd (show p) ++ unwords ss ++ "\"] ;" + nodeWords = (0,((mkCId "",[]),["ROOT"])) : zip [1..] [((f,p),w)| + ((Just f,p),w) <- wlins pot] + + links = map mkLink thelinks + thelinks = [(word y, x, label tr y x) | + (_,((f,x),_)) <- tail nodeWords, + let y = dominant x] + mkLink (x,y,l) = node x ++ " -> " ++ node y ++ " [label = \"" ++ l ++ "\"] ;" + node = show . show + + dominant x = case x of + [] -> x + _ | not (x == hx) -> hx + _ -> dominant (init x) + where + hx = headArg (init x) tr x + + headArg x0 tr x = case (tr,x) of + (Fun f [],[_]) -> x0 ---- ?? + (Fun f ts,[_]) -> x0 ++ [getHead (length ts - 1) f] + (Fun f ts,i:y) -> headArg x0 (ts !! i) y + _ -> x0 ---- + + label tr y x = case span (uncurry (==)) (zip y x) of + (xys,(_,i):_) -> getLabel i (funAt tr (map fst xys)) + _ -> "" ---- + + funAt tr x = case (tr,x) of + (Fun f _ ,[]) -> f + (Fun f ts,i:y) -> funAt (ts !! i) y + _ -> mkCId (prTree tr) ---- + + word x = if elem x sortedNodes then x else + let x' = headArg x tr (x ++[0]) in + if x' == x then [] else word x' + + tr = expr2tree exp + sortedNodes = [p | (_,((_,p),_)) <- nodeWords] + + labels = maybe Map.empty id mlab + getHead i f = case Map.lookup f labels of + Just ls -> length $ takeWhile (/= "head") ls + _ -> i + getLabel i f = case Map.lookup f labels of + Just ls | length ls > i -> ifd (showCId f ++ "#" ++ show i ++ "=") ++ ls !! i + _ -> showCId f ++ "#" ++ show i + +-- to generate CoNLL format for MaltParser + nodeMap :: Map.Map [Int] Int + nodeMap = Map.fromList [(p,i) | (i,((_,p),_)) <- nodeWords] + + arcMap :: Map.Map [Int] ([Int],String) + arcMap = Map.fromList [(y,(x,l)) | (x,y,l) <- thelinks] + + lookDomLab p = case Map.lookup p arcMap of + Just (q,l) -> (maybe 0 id (Map.lookup q nodeMap), if null l then rootlabel else l) + _ -> (0,rootlabel) + + wnodes = [[show i, maltws ws, showCId fun, pos, pos, morph, show dom, lab, unspec, unspec] | + (i, ((fun,p),ws)) <- tail nodeWords, + let pos = showCId $ lookValCat pgf fun, + let morph = unspec, + let (dom,lab) = lookDomLab p + ] + maltws = concat . intersperse "+" . words . unwords -- no spaces in column 2 + unspec = "_" + rootlabel = "ROOT" + +type Labels = Map.Map CId [String] + +getDepLabels :: [String] -> Labels +getDepLabels ss = Map.fromList [(mkCId f,ls) | f:ls <- map words ss] + + +-- parse trees from Linearize.linearizeMark +---- nubrec and domins are quadratic, but could be (n log n) + +graphvizParseTree :: PGF -> CId -> Expr -> String +graphvizParseTree pgf lang = prGraph False . lin2tree pgf . linMark where + linMark = head . linearizesMark pgf lang + ---- use Just str if you have str to match against + +lin2tree pgf s = trace s $ prelude ++ nodes ++ links where + + prelude = ["rankdir=BU ;", "node [shape = record, color = white] ;"] + + nodeRecs = zip [0..] + (nub (filter (not . null) (nlins [postext] ++ [leaves postext]))) + nlins pts = + nubrec [] $ [(p,cat f) | T (Just f, p) _ <- pts] : + concatMap nlins [ts | T _ ts <- pts] + leaves pt = [(p++[j],s) | (j,(p,s)) <- + zip [9990..] [(p,s) | ((_,p),ss) <- wlins pt, s <- ss]] + + nubrec es rs = case rs of + r:rr -> let r' = filter (not . flip elem es) (nub r) + in r' : nubrec (r' ++ es) rr + _ -> rs + + nodes = map mkStruct nodeRecs + + mkStruct (i,cs) = struct i ++ "[label = \"" ++ fields cs ++ "\"] ;" + cat = showCId . lookValCat pgf + fields cs = concat (intersperse "|" [ mtag (showp p) ++ c | (p,c) <- cs]) + struct i = "struct" ++ show i + + links = map mkEdge domins + domins = nub [((i,x),(j,y)) | + (i,xs) <- nodeRecs, (j,ys) <- nodeRecs, + x <- xs, y <- ys, dominates x y] + dominates (p,x) (q,y) = not (null q) && p == init q + mkEdge ((i,x),(j,y)) = + struct i ++ ":n" ++ uncommas (showp (fst x)) ++ ":s -- " ++ + struct j ++ ":n" ++ uncommas (showp (fst y)) ++ ":n ;" + + postext = readPosText s + +-- auxiliaries for graphviz syntax +struct i = "struct" ++ show i +mark (j,n) = "n" ++ show j ++ "a" ++ uncommas n +uncommas = map (\c -> if c==',' then 'c' else c) +tag s = "<" ++ s ++ ">" +showp = init . tail . show +mtag = tag . ('n':) . uncommas + +-- word alignments from Linearize.linearizesMark +-- words are chunks like {[0,1,1,0] old} + +graphvizAlignment :: PGF -> Expr -> String +graphvizAlignment pgf = prGraph True . lin2graph . linsMark where + linsMark t = [s | la <- cncnames pgf, s <- take 1 (linearizesMark pgf la t)] + +lin2graph :: [String] -> [String] +lin2graph ss = trace (show ss) $ prelude ++ nodes ++ links + + where + + prelude = ["rankdir=LR ;", "node [shape = record] ;"] + + nlins :: [(Int,[((Int,String),String)])] + nlins = [(i, [((j,showp p),unw ws) | (j,((_,p),ws)) <- zip [0..] ws]) | + (i,ws) <- zip [0..] (map (wlins . readPosText) ss)] + + unw = concat . intersperse "\\ " -- space escape in graphviz + + nodes = map mkStruct nlins + + mkStruct (i, ws) = struct i ++ "[label = \"" ++ fields ws ++ "\"] ;" + + fields ws = concat (intersperse "|" [tag (mark m) ++ " " ++ w | (m,w) <- ws]) + + links = nub $ concatMap mkEdge (init nlins) + + mkEdge (i,lin) = let lin' = snd (nlins !! (i+1)) in -- next lin in the list + [edge i v w | (v@(_,p),_) <- lin, (w@(_,q),_) <- lin', p == q] + + edge i v w = + struct i ++ ":" ++ mark v ++ ":e -> " ++ struct (i+1) ++ ":" ++ mark w ++ ":w ;" +{- +alignmentData :: PGF -> [Expr] -> Map.Map String (Map.Map String Double) +alignmentData pgf = mkStat . concatMap (mkAlign . linsMark) where + linsMark t = + [s | la <- take 2 (cncnames pgf), s <- take 1 (linearizesMark pgf la t)] + + mkStat :: [(String,String)] -> Map.Map String (Map.Map String Double) + mkStat = + + mkAlign :: [String] -> [(String,String)] + mkAlign ss = + + nlins :: [(Int,[((Int,String),String)])] + nlins = [(i, [((j,showp p),unw ws) | (j,((_,p),ws)) <- zip [0..] vs]) | + (i,vs) <- zip [0..] (map (wlins . readPosText) ss)] + + nodes = map mkStruct nlins + + mkStruct (i, ws) = struct i ++ "[label = \"" ++ fields ws ++ "\"] ;" + + fields ws = concat (intersperse "|" [tag (mark m) ++ " " ++ w | (m,w) <- ws]) + + links = nub $ concatMap mkEdge (init nlins) + + mkEdge (i,lin) = let lin' = snd (nlins !! (i+1)) in -- next lin in the list + [edge i v w | (v@(_,p),_) <- lin, (w@(_,q),_) <- lin', p == q] + + edge i v w = + struct i ++ ":" ++ mark v ++ ":e -> " ++ struct (i+1) ++ ":" ++ mark w ++ ":w ;" +-} + +wlins :: PosText -> [((Maybe CId,[Int]),[String])] +wlins pt = case pt of + T p pts -> concatMap (lins p) pts + M ws -> if null ws then [] else [((Nothing,[]),ws)] + where + lins p pt = case pt of + T q pts -> concatMap (lins q) pts + M ws -> if null ws then [] else [(p,ws)] + +data PosText = + T (Maybe CId,[Int]) [PosText] + | M [String] + deriving Show + +readPosText :: String -> PosText +readPosText = fst . head . (RP.readP_to_S pPosText) where + pPosText = do + RP.char '(' >> RP.skipSpaces + p <- pPos + RP.skipSpaces + ts <- RP.many pPosText + RP.char ')' >> RP.skipSpaces + return (T p ts) + RP.<++ do + ws <- RP.sepBy1 (RP.munch1 (flip notElem "()")) (RP.char ' ') + return (M ws) + pPos = do + fun <- (RP.char '(' >> pCId >>= \f -> RP.char ',' >> (return $ Just f)) + RP.<++ (return Nothing) + RP.char '[' >> RP.skipSpaces + is <- RP.sepBy (RP.munch1 isDigit) (RP.char ',') + RP.char ']' >> RP.skipSpaces + RP.char ')' RP.<++ return ' ' + return (fun,map read is) + + +{- +digraph{ +rankdir ="LR" ; +node [shape = record] ; + +struct1 [label = " this| very| intelligent| man"] ; +struct2 [label = " cet| homme| tres| intelligent| ci"] ; + +struct1:f0 -> struct2:f0 ; +struct1:f1 -> struct2:f2 ; +struct1:f2 -> struct2:f3 ; +struct1:f3 -> struct2:f1 ; +struct1:f0 -> struct2:f4 ; +} +-} + diff --git a/src/runtime/javascript/editor.html b/src/runtime/javascript/editor.html new file mode 100644 index 000000000..dd189d9ab --- /dev/null +++ b/src/runtime/javascript/editor.html @@ -0,0 +1,17 @@ + + + + + + + + + + + Web-based Syntax Editor + + +
+
+ + diff --git a/src/runtime/javascript/editorGrammar.js b/src/runtime/javascript/editorGrammar.js new file mode 100644 index 000000000..a4cc01ea5 --- /dev/null +++ b/src/runtime/javascript/editorGrammar.js @@ -0,0 +1 @@ +var Editor = new GFGrammar(new GFAbstract("Sentence",{Available: new Type([], "Adjective"), Bulgarian: new Type([], "Noun"), Command: new Type(["Verb", "Determiner", "Noun"], "Sentence"), CommandAdj: new Type(["Verb", "Determiner", "Adjective", "Noun"], "Sentence"), Copy: new Type([], "Verb"), Cut: new Type([], "Verb"), Danish: new Type([], "Noun"), DefPlDet: new Type([], "Determiner"), DefSgDet: new Type([], "Determiner"), Delete: new Type([], "Verb"), English: new Type([], "Noun"), Enter: new Type([], "Verb"), ErrorMessage: new Type(["Adjective", "Noun"], "Sentence"), Finnish: new Type([], "Noun"), Float_N: new Type([], "Noun"), French: new Type([], "Noun"), German: new Type([], "Noun"), IndefPlDet: new Type([], "Determiner"), IndefSgDet: new Type([], "Determiner"), Integer_N: new Type([], "Noun"), Italian: new Type([], "Noun"), Label: new Type(["Noun"], "Sentence"), Language: new Type([], "Noun"), Next: new Type([], "Adjective"), Node: new Type([], "Noun"), Norwegian: new Type([], "Noun"), Page: new Type([], "Noun"), Parse: new Type([], "Verb"), Paste: new Type([], "Verb"), Previous: new Type([], "Adjective"), RandomlyCommand: new Type(["Verb", "Determiner", "Noun"], "Sentence"), Redo: new Type([], "Verb"), Refine: new Type([], "Verb"), Refinement: new Type([], "Noun"), Replace: new Type([], "Verb"), Russian: new Type([], "Noun"), Select: new Type([], "Verb"), Show: new Type([], "Verb"), SingleWordCommand: new Type(["Verb"], "Sentence"), Spanish: new Type([], "Noun"), String_N: new Type([], "Noun"), Swedish: new Type([], "Noun"), Tree: new Type([], "Noun"), Undo: new Type([], "Verb"), Wrap: new Type([], "Verb"), Wrapper: new Type([], "Noun")}),{EditorEng: new GFConcrete({coding: "utf8"},{Available: function(cs){return new Arr(new Suffix("available", new Arr(new Str(""), new Str("r"), new Str("st"), new Str("ly"))));}, Bulgarian: function(cs){return new Arr(new Arr(Editor.concretes["EditorEng"].rule("_4", cs), Editor.concretes["EditorEng"].rule("_4", cs)), new Int(0));}, Command: function(cs){return new Arr(new Seq(Editor.concretes["EditorEng"].rule("_8", cs), Editor.concretes["EditorEng"].rule("_11", cs), Editor.concretes["EditorEng"].rule("_14", cs), Editor.concretes["EditorEng"].rule("_18", cs)));}, CommandAdj: function(cs){return new Arr(new Seq(Editor.concretes["EditorEng"].rule("_8", cs), Editor.concretes["EditorEng"].rule("_11", cs),(new Arr(Editor.concretes["EditorEng"].rule("_13", cs), Editor.concretes["EditorEng"].rule("_13", cs), Editor.concretes["EditorEng"].rule("_13", cs), Editor.concretes["EditorEng"].rule("_13", cs), Editor.concretes["EditorEng"].rule("_13", cs), Editor.concretes["EditorEng"].rule("_13", cs), Editor.concretes["EditorEng"].rule("_13", cs), Editor.concretes["EditorEng"].rule("_13", cs))).sel(Editor.concretes["EditorEng"].rule("_22", cs).sel(cs[3].sel(new Int(1)))), cs[3].sel(new Int(0)).sel(new Int(0)).sel(new Int(1)), Editor.concretes["EditorEng"].rule("_18", cs)));}, Copy: function(cs){return new Arr(new Suffix("Cop", new Arr(new Str("y"), new Str("ies"), new Str("ied"), new Str("ying"))), new Int(1));}, Cut: function(cs){return new Arr(new Suffix("Cut", Editor.concretes["EditorEng"].rule("_34", cs)), new Int(1));}, Danish: function(cs){return new Arr(new Arr(Editor.concretes["EditorEng"].rule("_37", cs), Editor.concretes["EditorEng"].rule("_37", cs)), new Int(0));}, DefPlDet: function(cs){return Editor.concretes["EditorEng"].rule("_43", cs);}, DefSgDet: function(cs){return Editor.concretes["EditorEng"].rule("_43", cs);}, Delete: function(cs){return new Arr(new Suffix("Delet", Editor.concretes["EditorEng"].rule("_44", cs)), new Int(1));}, English: function(cs){return new Arr(new Arr(Editor.concretes["EditorEng"].rule("_47", cs), Editor.concretes["EditorEng"].rule("_47", cs)), new Int(0));}, Enter: function(cs){return new Arr(new Suffix("Enter", Editor.concretes["EditorEng"].rule("_34", cs)), new Int(1));}, ErrorMessage: function(cs){return new Arr(new Seq(new Str("there"),(new Arr(new Seq(new Str("am"), new Str("not")), new Str("aren't"), new Str("aren't"), new Str("aren't"), new Str("isn't"), new Str("isn't"), new Str("isn't"), new Str("aren't"))).sel(Editor.concretes["EditorEng"].rule("_59", cs)), Editor.concretes["EditorEng"].rule("_62", cs), Editor.concretes["EditorEng"].rule("_62", cs), Editor.concretes["EditorEng"].rule("_62", cs),(new Arr(Editor.concretes["EditorEng"].rule("_67", cs), Editor.concretes["EditorEng"].rule("_67", cs), Editor.concretes["EditorEng"].rule("_67", cs), Editor.concretes["EditorEng"].rule("_67", cs), Editor.concretes["EditorEng"].rule("_67", cs), Editor.concretes["EditorEng"].rule("_67", cs), Editor.concretes["EditorEng"].rule("_67", cs), Editor.concretes["EditorEng"].rule("_67", cs))).sel(Editor.concretes["EditorEng"].rule("_59", cs))));}, Finnish: function(cs){return new Arr(new Arr(Editor.concretes["EditorEng"].rule("_72", cs), Editor.concretes["EditorEng"].rule("_72", cs)), new Int(0));}, Float_N: function(cs){return new Arr(new Arr(new Suffix("float", Editor.concretes["EditorEng"].rule("_3", cs)), new Suffix("floats", Editor.concretes["EditorEng"].rule("_76", cs))), new Int(0));}, French: function(cs){return new Arr(new Arr(Editor.concretes["EditorEng"].rule("_80", cs), Editor.concretes["EditorEng"].rule("_80", cs)), new Int(0));}, German: function(cs){return new Arr(new Arr(Editor.concretes["EditorEng"].rule("_83", cs), Editor.concretes["EditorEng"].rule("_83", cs)), new Int(0));}, IndefPlDet: function(cs){return Editor.concretes["EditorEng"].rule("_89", cs);}, IndefSgDet: function(cs){return Editor.concretes["EditorEng"].rule("_89", cs);}, Integer_N: function(cs){return new Arr(new Arr(new Suffix("integer", Editor.concretes["EditorEng"].rule("_3", cs)), new Suffix("integers", Editor.concretes["EditorEng"].rule("_76", cs))), new Int(0));}, Italian: function(cs){return new Arr(new Arr(Editor.concretes["EditorEng"].rule("_94", cs), Editor.concretes["EditorEng"].rule("_94", cs)), new Int(0));}, Label: function(cs){return new Arr(Editor.concretes["EditorEng"].rule("_8", cs).sel(new Int(0)));}, Language: function(cs){return new Arr(new Arr(new Suffix("language", Editor.concretes["EditorEng"].rule("_3", cs)), new Suffix("languages", Editor.concretes["EditorEng"].rule("_76", cs))), new Int(0));}, Next: function(cs){return new Arr(new Suffix("next", Editor.concretes["EditorEng"].rule("_103", cs)));}, Node: function(cs){return new Arr(new Arr(new Suffix("node", Editor.concretes["EditorEng"].rule("_3", cs)), new Suffix("nodes", Editor.concretes["EditorEng"].rule("_76", cs))), new Int(0));}, Norwegian: function(cs){return new Arr(new Arr(Editor.concretes["EditorEng"].rule("_110", cs), Editor.concretes["EditorEng"].rule("_110", cs)), new Int(0));}, Page: function(cs){return new Arr(new Arr(new Suffix("page", Editor.concretes["EditorEng"].rule("_3", cs)), new Suffix("pages", Editor.concretes["EditorEng"].rule("_76", cs))), new Int(0));}, Parse: function(cs){return new Arr(new Suffix("Pars", Editor.concretes["EditorEng"].rule("_44", cs)), new Int(1));}, Paste: function(cs){return new Arr(new Suffix("Past", Editor.concretes["EditorEng"].rule("_44", cs)), new Int(1));}, Previous: function(cs){return new Arr(new Suffix("previous", Editor.concretes["EditorEng"].rule("_103", cs)));}, RandomlyCommand: function(cs){return new Arr(new Seq(Editor.concretes["EditorEng"].rule("_8", cs), Editor.concretes["EditorEng"].rule("_11", cs), Editor.concretes["EditorEng"].rule("_14", cs), Editor.concretes["EditorEng"].rule("_18", cs), new Str("at"), new Str("random")));}, Redo: function(cs){return new Arr(new Suffix("Redo", Editor.concretes["EditorEng"].rule("_125", cs)), new Int(1));}, Refine: function(cs){return new Arr(new Suffix("Refin", Editor.concretes["EditorEng"].rule("_44", cs)), new Int(1));}, Refinement: function(cs){return new Arr(new Arr(new Suffix("refinement", Editor.concretes["EditorEng"].rule("_3", cs)), new Suffix("refinements", Editor.concretes["EditorEng"].rule("_76", cs))), new Int(0));}, Replace: function(cs){return new Arr(new Suffix("Replac", Editor.concretes["EditorEng"].rule("_44", cs)), new Int(1));}, Russian: function(cs){return new Arr(new Arr(Editor.concretes["EditorEng"].rule("_136", cs), Editor.concretes["EditorEng"].rule("_136", cs)), new Int(0));}, Select: function(cs){return new Arr(new Suffix("Select", Editor.concretes["EditorEng"].rule("_34", cs)), new Int(1));}, Show: function(cs){return new Arr(new Suffix("Show", Editor.concretes["EditorEng"].rule("_34", cs)), new Int(1));}, SingleWordCommand: function(cs){return new Arr(new Seq(Editor.concretes["EditorEng"].rule("_8", cs), Editor.concretes["EditorEng"].rule("_18", cs)));}, Spanish: function(cs){return new Arr(new Arr(Editor.concretes["EditorEng"].rule("_145", cs), Editor.concretes["EditorEng"].rule("_145", cs)), new Int(0));}, String_N: function(cs){return new Arr(new Arr(new Suffix("string", Editor.concretes["EditorEng"].rule("_3", cs)), new Suffix("strings", Editor.concretes["EditorEng"].rule("_76", cs))), new Int(0));}, Swedish: function(cs){return new Arr(new Arr(Editor.concretes["EditorEng"].rule("_152", cs), Editor.concretes["EditorEng"].rule("_152", cs)), new Int(0));}, Tree: function(cs){return new Arr(new Arr(new Suffix("tree", Editor.concretes["EditorEng"].rule("_3", cs)), new Suffix("trees", Editor.concretes["EditorEng"].rule("_76", cs))), new Int(0));}, Undo: function(cs){return new Arr(new Suffix("Undo", Editor.concretes["EditorEng"].rule("_125", cs)), new Int(1));}, Wrap: function(cs){return new Arr(new Suffix("Wrap", Editor.concretes["EditorEng"].rule("_34", cs)), new Int(1));}, Wrapper: function(cs){return new Arr(new Arr(new Suffix("wrapper", Editor.concretes["EditorEng"].rule("_3", cs)), new Suffix("wrappers", Editor.concretes["EditorEng"].rule("_76", cs))), new Int(0));}, _10: function(cs){return Editor.concretes["EditorEng"].rule("_9", cs).sel(new Int(1));}, _103: function(cs){return new Arr(new Str(""), new Str("er"), new Str("est"), new Str("ly"));}, _11: function(cs){return Editor.concretes["EditorEng"].rule("_10", cs).sel(new Int(0));}, _110: function(cs){return new Suffix("Norwegian", Editor.concretes["EditorEng"].rule("_3", cs));}, _12: function(cs){return cs[2].sel(new Int(0));}, _125: function(cs){return new Arr(new Str(""), new Str("es"), new Str("ed"), new Str("ing"));}, _13: function(cs){return Editor.concretes["EditorEng"].rule("_12", cs).sel(new Int(0));}, _136: function(cs){return new Suffix("Russian", Editor.concretes["EditorEng"].rule("_3", cs));}, _14: function(cs){return Editor.concretes["EditorEng"].rule("_13", cs).sel(new Int(1));}, _145: function(cs){return new Suffix("Spanish", Editor.concretes["EditorEng"].rule("_3", cs));}, _15: function(cs){return new Seq();}, _152: function(cs){return new Suffix("Swedish", Editor.concretes["EditorEng"].rule("_3", cs));}, _16: function(cs){return new Arr(new Str("yourself"), Editor.concretes["EditorEng"].rule("_15", cs));}, _167: function(cs){return new Arr(cs[0], cs[0], cs[0], cs[0]);}, _169: function(cs){return new Arr(cs[0], cs[0]);}, _17: function(cs){return cs[0].sel(new Int(1));}, _172: function(cs){return new Arr(cs[0], cs[0], cs[0]);}, _18: function(cs){return Editor.concretes["EditorEng"].rule("_16", cs).sel(Editor.concretes["EditorEng"].rule("_17", cs));}, _22: function(cs){return new Arr(new Int(4), new Int(5), new Int(6));}, _3: function(cs){return new Arr(new Str(""), new Str(""), new Str("'s"));}, _34: function(cs){return new Arr(new Str(""), new Str("s"), new Str("ed"), new Str("ing"));}, _37: function(cs){return new Suffix("Danish", Editor.concretes["EditorEng"].rule("_3", cs));}, _4: function(cs){return new Suffix("Bulgarian", Editor.concretes["EditorEng"].rule("_3", cs));}, _40: function(cs){return new Arr(new Str(""), new Str(""));}, _41: function(cs){return new Suffix("the", Editor.concretes["EditorEng"].rule("_40", cs));}, _42: function(cs){return new Arr(Editor.concretes["EditorEng"].rule("_41", cs), Editor.concretes["EditorEng"].rule("_41", cs));}, _43: function(cs){return new Arr(Editor.concretes["EditorEng"].rule("_42", cs));}, _44: function(cs){return new Arr(new Str("e"), new Str("es"), new Str("ed"), new Str("ing"));}, _47: function(cs){return new Suffix("English", Editor.concretes["EditorEng"].rule("_3", cs));}, _54: function(cs){return new Arr(new Int(4), new Int(7));}, _55: function(cs){return new Arr(new Int(0), new Int(1), new Int(0), new Int(1), new Int(0), new Int(0), new Int(0), new Int(1));}, _56: function(cs){return cs[1].sel(new Int(1));}, _57: function(cs){return Editor.concretes["EditorEng"].rule("_22", cs).sel(Editor.concretes["EditorEng"].rule("_56", cs));}, _58: function(cs){return Editor.concretes["EditorEng"].rule("_55", cs).sel(Editor.concretes["EditorEng"].rule("_57", cs));}, _59: function(cs){return Editor.concretes["EditorEng"].rule("_54", cs).sel(Editor.concretes["EditorEng"].rule("_58", cs));}, _61: function(cs){return new Arr(Editor.concretes["EditorEng"].rule("_15", cs), Editor.concretes["EditorEng"].rule("_15", cs), Editor.concretes["EditorEng"].rule("_15", cs), Editor.concretes["EditorEng"].rule("_15", cs), Editor.concretes["EditorEng"].rule("_15", cs), Editor.concretes["EditorEng"].rule("_15", cs), Editor.concretes["EditorEng"].rule("_15", cs), Editor.concretes["EditorEng"].rule("_15", cs));}, _62: function(cs){return Editor.concretes["EditorEng"].rule("_61", cs).sel(Editor.concretes["EditorEng"].rule("_59", cs));}, _63: function(cs){return new Arr(Editor.concretes["EditorEng"].rule("_8", cs), Editor.concretes["EditorEng"].rule("_8", cs), Editor.concretes["EditorEng"].rule("_8", cs), Editor.concretes["EditorEng"].rule("_8", cs), Editor.concretes["EditorEng"].rule("_8", cs), Editor.concretes["EditorEng"].rule("_8", cs), Editor.concretes["EditorEng"].rule("_8", cs), Editor.concretes["EditorEng"].rule("_8", cs));}, _64: function(cs){return Editor.concretes["EditorEng"].rule("_63", cs).sel(Editor.concretes["EditorEng"].rule("_57", cs));}, _65: function(cs){return Editor.concretes["EditorEng"].rule("_9", cs).sel(new Int(0));}, _66: function(cs){return Editor.concretes["EditorEng"].rule("_65", cs).sel(new Int(1));}, _67: function(cs){return new Seq(new Str("a"), Editor.concretes["EditorEng"].rule("_64", cs), Editor.concretes["EditorEng"].rule("_66", cs));}, _7: function(cs){return cs[0].sel(new Int(0));}, _72: function(cs){return new Suffix("Finnish", Editor.concretes["EditorEng"].rule("_3", cs));}, _76: function(cs){return new Arr(new Str(""), new Str(""), new Str("'"));}, _8: function(cs){return Editor.concretes["EditorEng"].rule("_7", cs).sel(new Int(0));}, _80: function(cs){return new Suffix("French", Editor.concretes["EditorEng"].rule("_3", cs));}, _83: function(cs){return new Suffix("German", Editor.concretes["EditorEng"].rule("_3", cs));}, _86: function(cs){return new Arr(Editor.concretes["EditorEng"].rule("_15", cs), Editor.concretes["EditorEng"].rule("_15", cs));}, _87: function(cs){return new Arr(new Str("a"), Editor.concretes["EditorEng"].rule("_15", cs));}, _88: function(cs){return new Arr(Editor.concretes["EditorEng"].rule("_86", cs), Editor.concretes["EditorEng"].rule("_87", cs));}, _89: function(cs){return new Arr(Editor.concretes["EditorEng"].rule("_88", cs));}, _9: function(cs){return cs[1].sel(new Int(0));}, _94: function(cs){return new Suffix("Italian", Editor.concretes["EditorEng"].rule("_3", cs));}, Adjective: function(cs){return new Arr(Editor.concretes["EditorEng"].rule("_167", cs));}, Determiner: function(cs){return new Arr(new Arr(Editor.concretes["EditorEng"].rule("_169", cs), Editor.concretes["EditorEng"].rule("_169", cs)));}, Noun: function(cs){return new Arr(new Arr(Editor.concretes["EditorEng"].rule("_172", cs), Editor.concretes["EditorEng"].rule("_172", cs)), new Int(0));}, Sentence: function(cs){return new Arr(cs[0]);}, Verb: function(cs){return new Arr(Editor.concretes["EditorEng"].rule("_167", cs), new Int(0));}, "Int": function(cs){return new Arr(cs[0]);}, "Float": function(cs){return new Arr(cs[0]);}, "String": function(cs){return new Arr(cs[0]);}}, new Parser("Sentence",[new Rule(10, new FunApp("Wrapper",[]),[],[[new Terminal("wrapper")]]), new Rule(9, new FunApp("Wrapper",[]),[],[[new Terminal("wrapper")]]), new Rule(8, new FunApp("Wrapper",[]),[],[[new Terminal("wrapper's")]]), new Rule(7, new FunApp("Wrapper",[]),[],[[new Terminal("wrappers")]]), new Rule(6, new FunApp("Wrapper",[]),[],[[new Terminal("wrappers")]]), new Rule(5, new FunApp("Wrapper",[]),[],[[new Terminal("wrappers'")]]), new Rule(17, new FunApp("Wrap",[]),[],[[new Terminal("Wrap")]]), new Rule(20, new FunApp("Wrap",[]),[],[[new Terminal("Wraps")]]), new Rule(19, new FunApp("Wrap",[]),[],[[new Terminal("Wraped")]]), new Rule(18, new FunApp("Wrap",[]),[],[[new Terminal("Wraping")]]), new Rule(17, new FunApp("Undo",[]),[],[[new Terminal("Undo")]]), new Rule(20, new FunApp("Undo",[]),[],[[new Terminal("Undoes")]]), new Rule(19, new FunApp("Undo",[]),[],[[new Terminal("Undoed")]]), new Rule(18, new FunApp("Undo",[]),[],[[new Terminal("Undoing")]]), new Rule(10, new FunApp("Tree",[]),[],[[new Terminal("tree")]]), new Rule(9, new FunApp("Tree",[]),[],[[new Terminal("tree")]]), new Rule(8, new FunApp("Tree",[]),[],[[new Terminal("tree's")]]), new Rule(7, new FunApp("Tree",[]),[],[[new Terminal("trees")]]), new Rule(6, new FunApp("Tree",[]),[],[[new Terminal("trees")]]), new Rule(5, new FunApp("Tree",[]),[],[[new Terminal("trees'")]]), new Rule(10, new FunApp("Swedish",[]),[],[[new Terminal("Swedish")]]), new Rule(9, new FunApp("Swedish",[]),[],[[new Terminal("Swedish")]]), new Rule(8, new FunApp("Swedish",[]),[],[[new Terminal("Swedish's")]]), new Rule(7, new FunApp("Swedish",[]),[],[[new Terminal("Swedish")]]), new Rule(6, new FunApp("Swedish",[]),[],[[new Terminal("Swedish")]]), new Rule(5, new FunApp("Swedish",[]),[],[[new Terminal("Swedish's")]]), new Rule(10, new FunApp("String_N",[]),[],[[new Terminal("string")]]), new Rule(9, new FunApp("String_N",[]),[],[[new Terminal("string")]]), new Rule(8, new FunApp("String_N",[]),[],[[new Terminal("string's")]]), new Rule(7, new FunApp("String_N",[]),[],[[new Terminal("strings")]]), new Rule(6, new FunApp("String_N",[]),[],[[new Terminal("strings")]]), new Rule(5, new FunApp("String_N",[]),[],[[new Terminal("strings'")]]), new Rule(10, new FunApp("Spanish",[]),[],[[new Terminal("Spanish")]]), new Rule(9, new FunApp("Spanish",[]),[],[[new Terminal("Spanish")]]), new Rule(8, new FunApp("Spanish",[]),[],[[new Terminal("Spanish's")]]), new Rule(7, new FunApp("Spanish",[]),[],[[new Terminal("Spanish")]]), new Rule(6, new FunApp("Spanish",[]),[],[[new Terminal("Spanish")]]), new Rule(5, new FunApp("Spanish",[]),[],[[new Terminal("Spanish's")]]), new Rule(11, new FunApp("SingleWordCommand",[new Arg(0)]),[17],[[new ArgProj(0, 0)]]), new Rule(11, new FunApp("SingleWordCommand",[new Arg(0)]),[16],[[new ArgProj(0, 0), new Terminal("yourself")]]), new Rule(17, new FunApp("Show",[]),[],[[new Terminal("Show")]]), new Rule(20, new FunApp("Show",[]),[],[[new Terminal("Shows")]]), new Rule(19, new FunApp("Show",[]),[],[[new Terminal("Showed")]]), new Rule(18, new FunApp("Show",[]),[],[[new Terminal("Showing")]]), new Rule(17, new FunApp("Select",[]),[],[[new Terminal("Select")]]), new Rule(20, new FunApp("Select",[]),[],[[new Terminal("Selects")]]), new Rule(19, new FunApp("Select",[]),[],[[new Terminal("Selected")]]), new Rule(18, new FunApp("Select",[]),[],[[new Terminal("Selecting")]]), new Rule(10, new FunApp("Russian",[]),[],[[new Terminal("Russian")]]), new Rule(9, new FunApp("Russian",[]),[],[[new Terminal("Russian")]]), new Rule(8, new FunApp("Russian",[]),[],[[new Terminal("Russian's")]]), new Rule(7, new FunApp("Russian",[]),[],[[new Terminal("Russian")]]), new Rule(6, new FunApp("Russian",[]),[],[[new Terminal("Russian")]]), new Rule(5, new FunApp("Russian",[]),[],[[new Terminal("Russian's")]]), new Rule(17, new FunApp("Replace",[]),[],[[new Terminal("Replace")]]), new Rule(20, new FunApp("Replace",[]),[],[[new Terminal("Replaces")]]), new Rule(19, new FunApp("Replace",[]),[],[[new Terminal("Replaced")]]), new Rule(18, new FunApp("Replace",[]),[],[[new Terminal("Replacing")]]), new Rule(10, new FunApp("Refinement",[]),[],[[new Terminal("refinement")]]), new Rule(9, new FunApp("Refinement",[]),[],[[new Terminal("refinement")]]), new Rule(8, new FunApp("Refinement",[]),[],[[new Terminal("refinement's")]]), new Rule(7, new FunApp("Refinement",[]),[],[[new Terminal("refinements")]]), new Rule(6, new FunApp("Refinement",[]),[],[[new Terminal("refinements")]]), new Rule(5, new FunApp("Refinement",[]),[],[[new Terminal("refinements'")]]), new Rule(17, new FunApp("Refine",[]),[],[[new Terminal("Refine")]]), new Rule(20, new FunApp("Refine",[]),[],[[new Terminal("Refines")]]), new Rule(19, new FunApp("Refine",[]),[],[[new Terminal("Refined")]]), new Rule(18, new FunApp("Refine",[]),[],[[new Terminal("Refining")]]), new Rule(17, new FunApp("Redo",[]),[],[[new Terminal("Redo")]]), new Rule(20, new FunApp("Redo",[]),[],[[new Terminal("Redoes")]]), new Rule(19, new FunApp("Redo",[]),[],[[new Terminal("Redoed")]]), new Rule(18, new FunApp("Redo",[]),[],[[new Terminal("Redoing")]]), new Rule(11, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[17, 15, 12],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("at"), new Terminal("random")]]), new Rule(11, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[16, 15, 12],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("yourself"), new Terminal("at"), new Terminal("random")]]), new Rule(4, new FunApp("Previous",[]),[],[[new Terminal("previous")]]), new Rule(3, new FunApp("Previous",[]),[],[[new Terminal("previouser")]]), new Rule(2, new FunApp("Previous",[]),[],[[new Terminal("previousest")]]), new Rule(1, new FunApp("Previous",[]),[],[[new Terminal("previously")]]), new Rule(17, new FunApp("Paste",[]),[],[[new Terminal("Paste")]]), new Rule(20, new FunApp("Paste",[]),[],[[new Terminal("Pastes")]]), new Rule(19, new FunApp("Paste",[]),[],[[new Terminal("Pasted")]]), new Rule(18, new FunApp("Paste",[]),[],[[new Terminal("Pasting")]]), new Rule(17, new FunApp("Parse",[]),[],[[new Terminal("Parse")]]), new Rule(20, new FunApp("Parse",[]),[],[[new Terminal("Parses")]]), new Rule(19, new FunApp("Parse",[]),[],[[new Terminal("Parsed")]]), new Rule(18, new FunApp("Parse",[]),[],[[new Terminal("Parsing")]]), new Rule(10, new FunApp("Page",[]),[],[[new Terminal("page")]]), new Rule(9, new FunApp("Page",[]),[],[[new Terminal("page")]]), new Rule(8, new FunApp("Page",[]),[],[[new Terminal("page's")]]), new Rule(7, new FunApp("Page",[]),[],[[new Terminal("pages")]]), new Rule(6, new FunApp("Page",[]),[],[[new Terminal("pages")]]), new Rule(5, new FunApp("Page",[]),[],[[new Terminal("pages'")]]), new Rule(10, new FunApp("Norwegian",[]),[],[[new Terminal("Norwegian")]]), new Rule(9, new FunApp("Norwegian",[]),[],[[new Terminal("Norwegian")]]), new Rule(8, new FunApp("Norwegian",[]),[],[[new Terminal("Norwegian's")]]), new Rule(7, new FunApp("Norwegian",[]),[],[[new Terminal("Norwegian")]]), new Rule(6, new FunApp("Norwegian",[]),[],[[new Terminal("Norwegian")]]), new Rule(5, new FunApp("Norwegian",[]),[],[[new Terminal("Norwegian's")]]), new Rule(10, new FunApp("Node",[]),[],[[new Terminal("node")]]), new Rule(9, new FunApp("Node",[]),[],[[new Terminal("node")]]), new Rule(8, new FunApp("Node",[]),[],[[new Terminal("node's")]]), new Rule(7, new FunApp("Node",[]),[],[[new Terminal("nodes")]]), new Rule(6, new FunApp("Node",[]),[],[[new Terminal("nodes")]]), new Rule(5, new FunApp("Node",[]),[],[[new Terminal("nodes'")]]), new Rule(4, new FunApp("Next",[]),[],[[new Terminal("next")]]), new Rule(3, new FunApp("Next",[]),[],[[new Terminal("nexter")]]), new Rule(2, new FunApp("Next",[]),[],[[new Terminal("nextest")]]), new Rule(1, new FunApp("Next",[]),[],[[new Terminal("nextly")]]), new Rule(10, new FunApp("Language",[]),[],[[new Terminal("language")]]), new Rule(9, new FunApp("Language",[]),[],[[new Terminal("language")]]), new Rule(8, new FunApp("Language",[]),[],[[new Terminal("language's")]]), new Rule(7, new FunApp("Language",[]),[],[[new Terminal("languages")]]), new Rule(6, new FunApp("Language",[]),[],[[new Terminal("languages")]]), new Rule(5, new FunApp("Language",[]),[],[[new Terminal("languages'")]]), new Rule(11, new FunApp("Label",[new Arg(0)]),[24],[[new ArgProj(0, 0)]]), new Rule(24, new Arg(0),[26],[[new ArgProj(0, 0)]]), new Rule(24, new Arg(0),[25],[[new ArgProj(0, 0)]]), new Rule(24, new Arg(0),[10],[[new ArgProj(0, 0)]]), new Rule(10, new FunApp("Italian",[]),[],[[new Terminal("Italian")]]), new Rule(9, new FunApp("Italian",[]),[],[[new Terminal("Italian")]]), new Rule(8, new FunApp("Italian",[]),[],[[new Terminal("Italian's")]]), new Rule(7, new FunApp("Italian",[]),[],[[new Terminal("Italian")]]), new Rule(6, new FunApp("Italian",[]),[],[[new Terminal("Italian")]]), new Rule(5, new FunApp("Italian",[]),[],[[new Terminal("Italian's")]]), new Rule(10, new FunApp("Integer_N",[]),[],[[new Terminal("integer")]]), new Rule(9, new FunApp("Integer_N",[]),[],[[new Terminal("integer")]]), new Rule(8, new FunApp("Integer_N",[]),[],[[new Terminal("integer's")]]), new Rule(7, new FunApp("Integer_N",[]),[],[[new Terminal("integers")]]), new Rule(6, new FunApp("Integer_N",[]),[],[[new Terminal("integers")]]), new Rule(5, new FunApp("Integer_N",[]),[],[[new Terminal("integers'")]]), new Rule(23, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(22, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(15, new FunApp("IndefSgDet",[]),[],[[new Terminal("an")]]), new Rule(15, new FunApp("IndefSgDet",[]),[],[[new Terminal("a")]]), new Rule(21, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(23, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(22, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(15, new FunApp("IndefPlDet",[]),[],[[new Terminal("an")]]), new Rule(15, new FunApp("IndefPlDet",[]),[],[[new Terminal("a")]]), new Rule(21, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(10, new FunApp("German",[]),[],[[new Terminal("German")]]), new Rule(9, new FunApp("German",[]),[],[[new Terminal("German")]]), new Rule(8, new FunApp("German",[]),[],[[new Terminal("German's")]]), new Rule(7, new FunApp("German",[]),[],[[new Terminal("German")]]), new Rule(6, new FunApp("German",[]),[],[[new Terminal("German")]]), new Rule(5, new FunApp("German",[]),[],[[new Terminal("German's")]]), new Rule(10, new FunApp("French",[]),[],[[new Terminal("French")]]), new Rule(9, new FunApp("French",[]),[],[[new Terminal("French")]]), new Rule(8, new FunApp("French",[]),[],[[new Terminal("French's")]]), new Rule(7, new FunApp("French",[]),[],[[new Terminal("French")]]), new Rule(6, new FunApp("French",[]),[],[[new Terminal("French")]]), new Rule(5, new FunApp("French",[]),[],[[new Terminal("French's")]]), new Rule(10, new FunApp("Float_N",[]),[],[[new Terminal("float")]]), new Rule(9, new FunApp("Float_N",[]),[],[[new Terminal("float")]]), new Rule(8, new FunApp("Float_N",[]),[],[[new Terminal("float's")]]), new Rule(7, new FunApp("Float_N",[]),[],[[new Terminal("floats")]]), new Rule(6, new FunApp("Float_N",[]),[],[[new Terminal("floats")]]), new Rule(5, new FunApp("Float_N",[]),[],[[new Terminal("floats'")]]), new Rule(10, new FunApp("Finnish",[]),[],[[new Terminal("Finnish")]]), new Rule(9, new FunApp("Finnish",[]),[],[[new Terminal("Finnish")]]), new Rule(8, new FunApp("Finnish",[]),[],[[new Terminal("Finnish's")]]), new Rule(7, new FunApp("Finnish",[]),[],[[new Terminal("Finnish")]]), new Rule(6, new FunApp("Finnish",[]),[],[[new Terminal("Finnish")]]), new Rule(5, new FunApp("Finnish",[]),[],[[new Terminal("Finnish's")]]), new Rule(11, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[4, 14],[[new Terminal("there"), new Terminal("isn't"), new Terminal("an"), new ArgProj(0, 0), new ArgProj(1, 0)]]), new Rule(11, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[4, 14],[[new Terminal("there"), new Terminal("isn't"), new Terminal("a"), new ArgProj(0, 0), new ArgProj(1, 0)]]), new Rule(11, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[4, 13],[[new Terminal("there"), new Terminal("isn't"), new Terminal("an"), new ArgProj(0, 0), new ArgProj(1, 0)]]), new Rule(11, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[4, 13],[[new Terminal("there"), new Terminal("isn't"), new Terminal("a"), new ArgProj(0, 0), new ArgProj(1, 0)]]), new Rule(11, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[4, 9],[[new Terminal("there"), new Terminal("isn't"), new Terminal("an"), new ArgProj(0, 0), new ArgProj(1, 0)]]), new Rule(11, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[4, 9],[[new Terminal("there"), new Terminal("isn't"), new Terminal("a"), new ArgProj(0, 0), new ArgProj(1, 0)]]), new Rule(17, new FunApp("Enter",[]),[],[[new Terminal("Enter")]]), new Rule(20, new FunApp("Enter",[]),[],[[new Terminal("Enters")]]), new Rule(19, new FunApp("Enter",[]),[],[[new Terminal("Entered")]]), new Rule(18, new FunApp("Enter",[]),[],[[new Terminal("Entering")]]), new Rule(10, new FunApp("English",[]),[],[[new Terminal("English")]]), new Rule(9, new FunApp("English",[]),[],[[new Terminal("English")]]), new Rule(8, new FunApp("English",[]),[],[[new Terminal("English's")]]), new Rule(7, new FunApp("English",[]),[],[[new Terminal("English")]]), new Rule(6, new FunApp("English",[]),[],[[new Terminal("English")]]), new Rule(5, new FunApp("English",[]),[],[[new Terminal("English's")]]), new Rule(17, new FunApp("Delete",[]),[],[[new Terminal("Delete")]]), new Rule(20, new FunApp("Delete",[]),[],[[new Terminal("Deletes")]]), new Rule(19, new FunApp("Delete",[]),[],[[new Terminal("Deleted")]]), new Rule(18, new FunApp("Delete",[]),[],[[new Terminal("Deleting")]]), new Rule(23, new FunApp("DefSgDet",[]),[],[[new Terminal("the")]]), new Rule(22, new FunApp("DefSgDet",[]),[],[[new Terminal("the")]]), new Rule(15, new FunApp("DefSgDet",[]),[],[[new Terminal("the")]]), new Rule(21, new FunApp("DefSgDet",[]),[],[[new Terminal("the")]]), new Rule(23, new FunApp("DefPlDet",[]),[],[[new Terminal("the")]]), new Rule(22, new FunApp("DefPlDet",[]),[],[[new Terminal("the")]]), new Rule(15, new FunApp("DefPlDet",[]),[],[[new Terminal("the")]]), new Rule(21, new FunApp("DefPlDet",[]),[],[[new Terminal("the")]]), new Rule(10, new FunApp("Danish",[]),[],[[new Terminal("Danish")]]), new Rule(9, new FunApp("Danish",[]),[],[[new Terminal("Danish")]]), new Rule(8, new FunApp("Danish",[]),[],[[new Terminal("Danish's")]]), new Rule(7, new FunApp("Danish",[]),[],[[new Terminal("Danish")]]), new Rule(6, new FunApp("Danish",[]),[],[[new Terminal("Danish")]]), new Rule(5, new FunApp("Danish",[]),[],[[new Terminal("Danish's")]]), new Rule(17, new FunApp("Cut",[]),[],[[new Terminal("Cut")]]), new Rule(20, new FunApp("Cut",[]),[],[[new Terminal("Cuts")]]), new Rule(19, new FunApp("Cut",[]),[],[[new Terminal("Cuted")]]), new Rule(18, new FunApp("Cut",[]),[],[[new Terminal("Cuting")]]), new Rule(17, new FunApp("Copy",[]),[],[[new Terminal("Copy")]]), new Rule(20, new FunApp("Copy",[]),[],[[new Terminal("Copies")]]), new Rule(19, new FunApp("Copy",[]),[],[[new Terminal("Copied")]]), new Rule(18, new FunApp("Copy",[]),[],[[new Terminal("Copying")]]), new Rule(11, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[17, 15, 4, 14],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(11, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[17, 15, 4, 13],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(11, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[17, 15, 4, 9],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(11, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[16, 15, 4, 14],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0), new Terminal("yourself")]]), new Rule(11, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[16, 15, 4, 13],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0), new Terminal("yourself")]]), new Rule(11, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[16, 15, 4, 9],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0), new Terminal("yourself")]]), new Rule(11, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[17, 15, 12],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(11, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[16, 15, 12],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("yourself")]]), new Rule(12, new Arg(0),[14],[[new ArgProj(0, 0)]]), new Rule(12, new Arg(0),[13],[[new ArgProj(0, 0)]]), new Rule(12, new Arg(0),[9],[[new ArgProj(0, 0)]]), new Rule(10, new FunApp("Bulgarian",[]),[],[[new Terminal("Bulgarian")]]), new Rule(9, new FunApp("Bulgarian",[]),[],[[new Terminal("Bulgarian")]]), new Rule(8, new FunApp("Bulgarian",[]),[],[[new Terminal("Bulgarian's")]]), new Rule(7, new FunApp("Bulgarian",[]),[],[[new Terminal("Bulgarian")]]), new Rule(6, new FunApp("Bulgarian",[]),[],[[new Terminal("Bulgarian")]]), new Rule(5, new FunApp("Bulgarian",[]),[],[[new Terminal("Bulgarian's")]]), new Rule(4, new FunApp("Available",[]),[],[[new Terminal("available")]]), new Rule(3, new FunApp("Available",[]),[],[[new Terminal("availabler")]]), new Rule(2, new FunApp("Available",[]),[],[[new Terminal("availablest")]]), new Rule(1, new FunApp("Available",[]),[],[[new Terminal("availablely")]])],{Adjective:[4, 3, 2, 1], Determiner:[23, 15, 22, 21], Float:[-3], Int:[-2], Noun:[24, 10, 25, 26, 7, 12, 9, 13, 14, 6, 8, 5], Sentence:[11], String:[-1], Verb:[16, 17, 20, 19, 18], _Var:[-4]})), EditorFre: new GFConcrete({coding: "utf8"},{Available: function(cs){return new Arr(new Arr(new Suffix("disponible", new Arr(new Str(""), new Str("s"), new Str(""), new Str("s"), new Str("ment"))), Editor.concretes["EditorFre"].rule("_5", cs), Editor.concretes["EditorFre"].rule("_5", cs)), new Int(1));}, Bulgarian: function(cs){return new Arr(new Suffix("bulgarien", Editor.concretes["EditorFre"].rule("_8", cs)), new Int(0));}, Command: function(cs){return new Arr(new Seq(Editor.concretes["EditorFre"].rule("_41", cs), Editor.concretes["EditorFre"].rule("_43", cs), Editor.concretes["EditorFre"].rule("_45", cs), Editor.concretes["EditorFre"].rule("_58", cs)));}, CommandAdj: function(cs){return new Arr(new Seq((new Arr(Editor.concretes["EditorFre"].rule("_68", cs), Editor.concretes["EditorFre"].rule("_69", cs), Editor.concretes["EditorFre"].rule("_70", cs), Editor.concretes["EditorFre"].rule("_71", cs), Editor.concretes["EditorFre"].rule("_72", cs), Editor.concretes["EditorFre"].rule("_73", cs), Editor.concretes["EditorFre"].rule("_68", cs), Editor.concretes["EditorFre"].rule("_69", cs), Editor.concretes["EditorFre"].rule("_70", cs), Editor.concretes["EditorFre"].rule("_71", cs), Editor.concretes["EditorFre"].rule("_72", cs), Editor.concretes["EditorFre"].rule("_73", cs), Editor.concretes["EditorFre"].rule("_67", cs), Editor.concretes["EditorFre"].rule("_67", cs))).sel(Editor.concretes["EditorFre"].rule("_40", cs)), Editor.concretes["EditorFre"].rule("_43", cs), Editor.concretes["EditorFre"].rule("_45", cs),(new Arr(new Arr(Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_87", cs)), new Arr(Editor.concretes["EditorFre"].rule("_87", cs), Editor.concretes["EditorFre"].rule("_87", cs)))).sel(Editor.concretes["EditorFre"].rule("_25", cs)).sel(Editor.concretes["EditorFre"].rule("_27", cs))));}, Copy: function(cs){return new Arr(new Suffix("copi", Editor.concretes["EditorFre"].rule("_95", cs)), new Int(0));}, Cut: function(cs){return new Arr(new Suffix("coup", Editor.concretes["EditorFre"].rule("_95", cs)), new Int(0));}, Danish: function(cs){return new Arr(new Suffix("danois", Editor.concretes["EditorFre"].rule("_100", cs)), new Int(0));}, DefPlDet: function(cs){return Editor.concretes["EditorFre"].rule("_112", cs);}, DefSgDet: function(cs){return Editor.concretes["EditorFre"].rule("_112", cs);}, Delete: function(cs){return new Arr(new Suffix("enlev", Editor.concretes["EditorFre"].rule("_95", cs)), new Int(0));}, English: function(cs){return new Arr(new Suffix("anglais", Editor.concretes["EditorFre"].rule("_100", cs)), new Int(0));}, Enter: function(cs){return new Arr(new Suffix("introdui", new Arr(new Str("re"), new Str("re"), new Str("s"), new Str("s"), new Str("t"), new Str("sons"), new Str("sez"), new Str("sent"), new Str("se"), new Str("ses"), new Str("se"), new Str("sions"), new Str("siez"), new Str("sent"), new Str("s"), new Str("sons"), new Str("sez"), new Str("t"), new Str("ts"), new Str("te"), new Str("tes"), new Str("sant"))), new Int(0));}, ErrorMessage: function(cs){return new Arr(new Seq(new Str("il"), new Str("ne"), new Str("y"), new Str("a"), new Str("pas"),(new Arr(new Str("des"), new Str("des"))).sel(Editor.concretes["EditorFre"].rule("_121", cs)),(new Arr(new Seq(Editor.concretes["EditorFre"].rule("_125", cs), Editor.concretes["EditorFre"].rule("_47", cs)), new Seq(Editor.concretes["EditorFre"].rule("_47", cs), Editor.concretes["EditorFre"].rule("_125", cs)))).sel(Editor.concretes["EditorFre"].rule("_18", cs))));}, Finnish: function(cs){return new Arr(new Suffix("finnois", Editor.concretes["EditorFre"].rule("_100", cs)), new Int(0));}, Float_N: function(cs){return new Arr(new Suffix("réel", Editor.concretes["EditorFre"].rule("_8", cs)), new Int(0));}, French: function(cs){return new Arr(new Suffix("français", Editor.concretes["EditorFre"].rule("_100", cs)), new Int(0));}, German: function(cs){return new Arr(new Suffix("allemand", Editor.concretes["EditorFre"].rule("_8", cs)), new Int(0));}, IndefPlDet: function(cs){return Editor.concretes["EditorFre"].rule("_155", cs);}, IndefSgDet: function(cs){return Editor.concretes["EditorFre"].rule("_155", cs);}, Integer_N: function(cs){return new Arr(new Suffix("entier", Editor.concretes["EditorFre"].rule("_8", cs)), new Int(0));}, Italian: function(cs){return new Arr(new Suffix("italien", Editor.concretes["EditorFre"].rule("_8", cs)), new Int(0));}, Label: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_43", cs));}, Language: function(cs){return new Arr(new Suffix("langue", Editor.concretes["EditorFre"].rule("_8", cs)), new Int(1));}, Next: function(cs){return new Arr(new Arr(new Suffix("prochain", Editor.concretes["EditorFre"].rule("_163", cs)), Editor.concretes["EditorFre"].rule("_170", cs), Editor.concretes["EditorFre"].rule("_170", cs)), new Int(1));}, Node: function(cs){return new Arr(new Suffix("noeud", Editor.concretes["EditorFre"].rule("_8", cs)), new Int(0));}, Norwegian: function(cs){return new Arr(new Suffix("norvégien", Editor.concretes["EditorFre"].rule("_8", cs)), new Int(0));}, Page: function(cs){return new Arr(new Suffix("page", Editor.concretes["EditorFre"].rule("_8", cs)), new Int(1));}, Parse: function(cs){return new Arr(new Suffix("analys", Editor.concretes["EditorFre"].rule("_95", cs)), new Int(0));}, Paste: function(cs){return new Arr(new Suffix("coll", Editor.concretes["EditorFre"].rule("_95", cs)), new Int(0));}, Previous: function(cs){return new Arr(new Arr(new Suffix("précédent", Editor.concretes["EditorFre"].rule("_163", cs)), Editor.concretes["EditorFre"].rule("_189", cs), Editor.concretes["EditorFre"].rule("_189", cs)), new Int(1));}, RandomlyCommand: function(cs){return new Arr(new Seq(Editor.concretes["EditorFre"].rule("_41", cs), Editor.concretes["EditorFre"].rule("_43", cs), Editor.concretes["EditorFre"].rule("_45", cs), Editor.concretes["EditorFre"].rule("_58", cs), new Str("aléatoirement")));}, Redo: function(cs){return new Arr(new Suffix("ref", new Arr(new Str("aire"), new Str("aire"), new Str("ais"), new Str("ais"), new Str("ait"), new Str("aisons"), new Str("aites"), new Str("ont"), new Str("asse"), new Str("asses"), new Str("asse"), new Str("assions"), new Str("assiez"), new Str("assent"), new Str("ais"), new Str("aisons"), new Str("aites"), new Str("ait"), new Str("aits"), new Str("aite"), new Str("aites"), new Str("aisant"))), new Int(0));}, Refine: function(cs){return new Arr(new Suffix("raffin", Editor.concretes["EditorFre"].rule("_95", cs)), new Int(0));}, Refinement: function(cs){return new Arr(new Suffix("raffinement", Editor.concretes["EditorFre"].rule("_8", cs)), new Int(0));}, Replace: function(cs){return new Arr(new Suffix("rempla", new Arr(new Str("cer"), new Str("cer"), new Str("ce"), new Str("ces"), new Str("ce"), new Str("çons"), new Str("cez"), new Str("cent"), new Str("ce"), new Str("ces"), new Str("ce"), new Str("cions"), new Str("ciez"), new Str("cent"), new Str("ce"), new Str("çons"), new Str("cez"), new Str("cé"), new Str("cés"), new Str("cée"), new Str("cées"), new Str("çant"))), new Int(0));}, Russian: function(cs){return new Arr(new Suffix("russe", Editor.concretes["EditorFre"].rule("_8", cs)), new Int(1));}, Select: function(cs){return new Arr(new Suffix("selectionn", Editor.concretes["EditorFre"].rule("_95", cs)), new Int(0));}, Show: function(cs){return new Arr(new Suffix("montr", Editor.concretes["EditorFre"].rule("_95", cs)), new Int(0));}, SingleWordCommand: function(cs){return new Arr(new Seq(Editor.concretes["EditorFre"].rule("_12", cs).sel(Editor.concretes["EditorFre"].rule("_20", cs)), Editor.concretes["EditorFre"].rule("_43", cs)));}, Spanish: function(cs){return new Arr(new Suffix("espagnol", Editor.concretes["EditorFre"].rule("_8", cs)), new Int(0));}, String_N: function(cs){return new Arr(new Arr(new Seq(new Str("chaîne"), new Str("de"), new Str("charactères")), new Seq(new Str("chaînes"), new Str("de"), new Str("charactères"))), new Int(1));}, Swedish: function(cs){return new Arr(new Suffix("suédois", Editor.concretes["EditorFre"].rule("_100", cs)), new Int(0));}, Tree: function(cs){return new Arr(new Suffix("arbre", Editor.concretes["EditorFre"].rule("_8", cs)), new Int(0));}, Undo: function(cs){return new Arr(new Suffix("annul", Editor.concretes["EditorFre"].rule("_95", cs)), new Int(0));}, Wrap: function(cs){return new Arr(new Suffix("emball", Editor.concretes["EditorFre"].rule("_95", cs)), new Int(0));}, Wrapper: function(cs){return new Arr(new Suffix("emballage", Editor.concretes["EditorFre"].rule("_8", cs)), new Int(1));}, _100: function(cs){return new Arr(new Str(""), new Str(""));}, _103: function(cs){return new Arr(new Str("le"), new Str("le"), new Str("du"), new Str("au"), new Str("le"));}, _104: function(cs){return new Seq(new Str("de"), new Str("la"));}, _105: function(cs){return new Seq(new Str("Ã"), new Str("la"));}, _106: function(cs){return new Arr(new Str("la"), new Str("la"), Editor.concretes["EditorFre"].rule("_104", cs), Editor.concretes["EditorFre"].rule("_105", cs), new Str("la"));}, _107: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_103", cs), Editor.concretes["EditorFre"].rule("_106", cs));}, _108: function(cs){return new Arr(new Str("les"), new Str("les"), new Str("des"), new Str("aux"), new Str("les"));}, _109: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_108", cs), Editor.concretes["EditorFre"].rule("_108", cs));}, _11: function(cs){return new Seq();}, _110: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_107", cs), Editor.concretes["EditorFre"].rule("_109", cs));}, _111: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_110", cs), Editor.concretes["EditorFre"].rule("_110", cs));}, _112: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_111", cs));}, _12: function(cs){return new Arr(new Str("me"), new Str("te"), new Str("le"), new Str("nous"), new Str("vous"), new Str("les"), new Str("me"), new Str("te"), new Str("la"), new Str("nous"), new Str("vous"), new Str("les"), new Str("se"), Editor.concretes["EditorFre"].rule("_11", cs));}, _121: function(cs){return cs[1].sel(new Int(1));}, _123: function(cs){return new Arr(new Int(1), new Int(3));}, _124: function(cs){return Editor.concretes["EditorFre"].rule("_123", cs).sel(Editor.concretes["EditorFre"].rule("_121", cs));}, _125: function(cs){return Editor.concretes["EditorFre"].rule("_43", cs).sel(Editor.concretes["EditorFre"].rule("_124", cs));}, _13: function(cs){return new Arr(new Int(2), new Int(8));}, _14: function(cs){return cs[2].sel(new Int(1));}, _140: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_11", cs));}, _141: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_140", cs), Editor.concretes["EditorFre"].rule("_140", cs));}, _142: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_141", cs), Editor.concretes["EditorFre"].rule("_141", cs));}, _143: function(cs){return new Seq(new Str("d'"), new Str("un"));}, _144: function(cs){return new Seq(new Str("Ã"), new Str("un"));}, _145: function(cs){return new Arr(new Str("un"), new Str("un"), Editor.concretes["EditorFre"].rule("_143", cs), Editor.concretes["EditorFre"].rule("_144", cs), new Str("un"));}, _146: function(cs){return new Seq(new Str("d'"), new Str("une"));}, _147: function(cs){return new Seq(new Str("Ã"), new Str("une"));}, _148: function(cs){return new Arr(new Str("une"), new Str("une"), Editor.concretes["EditorFre"].rule("_146", cs), Editor.concretes["EditorFre"].rule("_147", cs), new Str("une"));}, _149: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_145", cs), Editor.concretes["EditorFre"].rule("_148", cs));}, _15: function(cs){return Editor.concretes["EditorFre"].rule("_13", cs).sel(Editor.concretes["EditorFre"].rule("_14", cs));}, _150: function(cs){return new Seq(new Str("Ã"), new Str("des"));}, _151: function(cs){return new Arr(new Str("des"), new Str("des"), new Str("de"), Editor.concretes["EditorFre"].rule("_150", cs), new Str("des"));}, _152: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_151", cs), Editor.concretes["EditorFre"].rule("_151", cs));}, _153: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_149", cs), Editor.concretes["EditorFre"].rule("_152", cs));}, _154: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_142", cs), Editor.concretes["EditorFre"].rule("_153", cs));}, _155: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_154", cs));}, _16: function(cs){return new Arr(new Int(12), new Int(13));}, _163: function(cs){return new Arr(new Str(""), new Str("s"), new Str("e"), new Str("es"), new Str("ement"));}, _165: function(cs){return new Seq(new Str("plus"), new Str("prochain"));}, _166: function(cs){return new Seq(new Str("plus"), new Str("prochains"));}, _167: function(cs){return new Seq(new Str("plus"), new Str("prochaine"));}, _168: function(cs){return new Seq(new Str("plus"), new Str("prochaines"));}, _169: function(cs){return new Seq(new Str("plus"), new Str("prochainement"));}, _17: function(cs){return new Arr(new Int(1), new Int(1), new Int(0));}, _170: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_165", cs), Editor.concretes["EditorFre"].rule("_166", cs), Editor.concretes["EditorFre"].rule("_167", cs), Editor.concretes["EditorFre"].rule("_168", cs), Editor.concretes["EditorFre"].rule("_169", cs));}, _18: function(cs){return cs[0].sel(new Int(1));}, _184: function(cs){return new Seq(new Str("plus"), new Str("précédent"));}, _185: function(cs){return new Seq(new Str("plus"), new Str("précédents"));}, _186: function(cs){return new Seq(new Str("plus"), new Str("précédente"));}, _187: function(cs){return new Seq(new Str("plus"), new Str("précédentes"));}, _188: function(cs){return new Seq(new Str("plus"), new Str("précédentement"));}, _189: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_184", cs), Editor.concretes["EditorFre"].rule("_185", cs), Editor.concretes["EditorFre"].rule("_186", cs), Editor.concretes["EditorFre"].rule("_187", cs), Editor.concretes["EditorFre"].rule("_188", cs));}, _19: function(cs){return Editor.concretes["EditorFre"].rule("_17", cs).sel(Editor.concretes["EditorFre"].rule("_18", cs));}, _2: function(cs){return new Seq(new Str("plus"), new Str("disponible"));}, _20: function(cs){return Editor.concretes["EditorFre"].rule("_16", cs).sel(Editor.concretes["EditorFre"].rule("_19", cs));}, _21: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_15", cs), Editor.concretes["EditorFre"].rule("_20", cs));}, _22: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_20", cs), Editor.concretes["EditorFre"].rule("_20", cs));}, _229: function(cs){return new Arr(cs[0], cs[0], cs[0], cs[0], cs[0]);}, _23: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_21", cs), Editor.concretes["EditorFre"].rule("_22", cs));}, _232: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_229", cs), Editor.concretes["EditorFre"].rule("_229", cs));}, _233: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_232", cs), Editor.concretes["EditorFre"].rule("_232", cs));}, _24: function(cs){return new Arr(new Int(1), new Int(0));}, _25: function(cs){return Editor.concretes["EditorFre"].rule("_24", cs).sel(new Int(0));}, _26: function(cs){return Editor.concretes["EditorFre"].rule("_23", cs).sel(Editor.concretes["EditorFre"].rule("_25", cs));}, _27: function(cs){return Editor.concretes["EditorFre"].rule("_24", cs).sel(new Int(1));}, _28: function(cs){return Editor.concretes["EditorFre"].rule("_26", cs).sel(Editor.concretes["EditorFre"].rule("_27", cs));}, _29: function(cs){return Editor.concretes["EditorFre"].rule("_12", cs).sel(Editor.concretes["EditorFre"].rule("_28", cs));}, _3: function(cs){return new Seq(new Str("plus"), new Str("disponibles"));}, _30: function(cs){return new Seq(new Str("me"), Editor.concretes["EditorFre"].rule("_29", cs));}, _31: function(cs){return new Seq(new Str("te"), Editor.concretes["EditorFre"].rule("_29", cs));}, _32: function(cs){return new Seq(Editor.concretes["EditorFre"].rule("_29", cs), new Str("lui"));}, _33: function(cs){return new Seq(new Str("nous"), Editor.concretes["EditorFre"].rule("_29", cs));}, _34: function(cs){return new Seq(new Str("vous"), Editor.concretes["EditorFre"].rule("_29", cs));}, _35: function(cs){return new Seq(Editor.concretes["EditorFre"].rule("_29", cs), new Str("leur"));}, _36: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_30", cs), Editor.concretes["EditorFre"].rule("_31", cs), Editor.concretes["EditorFre"].rule("_32", cs), Editor.concretes["EditorFre"].rule("_33", cs), Editor.concretes["EditorFre"].rule("_34", cs), Editor.concretes["EditorFre"].rule("_35", cs), Editor.concretes["EditorFre"].rule("_30", cs), Editor.concretes["EditorFre"].rule("_31", cs), Editor.concretes["EditorFre"].rule("_32", cs), Editor.concretes["EditorFre"].rule("_33", cs), Editor.concretes["EditorFre"].rule("_34", cs), Editor.concretes["EditorFre"].rule("_35", cs), Editor.concretes["EditorFre"].rule("_29", cs), Editor.concretes["EditorFre"].rule("_29", cs));}, _37: function(cs){return new Arr(new Int(13), new Int(13));}, _38: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_37", cs), Editor.concretes["EditorFre"].rule("_37", cs));}, _39: function(cs){return Editor.concretes["EditorFre"].rule("_38", cs).sel(Editor.concretes["EditorFre"].rule("_25", cs));}, _4: function(cs){return new Seq(new Str("plus"), new Str("disponiblement"));}, _40: function(cs){return Editor.concretes["EditorFre"].rule("_39", cs).sel(Editor.concretes["EditorFre"].rule("_27", cs));}, _41: function(cs){return Editor.concretes["EditorFre"].rule("_36", cs).sel(Editor.concretes["EditorFre"].rule("_40", cs));}, _42: function(cs){return cs[0].sel(new Int(0));}, _43: function(cs){return Editor.concretes["EditorFre"].rule("_42", cs).sel(new Int(0));}, _44: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_11", cs));}, _45: function(cs){return Editor.concretes["EditorFre"].rule("_44", cs).sel(Editor.concretes["EditorFre"].rule("_40", cs));}, _46: function(cs){return cs[1].sel(new Int(0));}, _47: function(cs){return Editor.concretes["EditorFre"].rule("_46", cs).sel(new Int(1));}, _48: function(cs){return Editor.concretes["EditorFre"].rule("_47", cs).sel(new Int(0));}, _49: function(cs){return Editor.concretes["EditorFre"].rule("_48", cs).sel(Editor.concretes["EditorFre"].rule("_14", cs));}, _5: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_2", cs), Editor.concretes["EditorFre"].rule("_3", cs), Editor.concretes["EditorFre"].rule("_2", cs), Editor.concretes["EditorFre"].rule("_3", cs), Editor.concretes["EditorFre"].rule("_4", cs));}, _50: function(cs){return Editor.concretes["EditorFre"].rule("_49", cs).sel(new Int(1));}, _51: function(cs){return cs[2].sel(new Int(0));}, _52: function(cs){return Editor.concretes["EditorFre"].rule("_51", cs).sel(new Int(0));}, _53: function(cs){return new Seq(Editor.concretes["EditorFre"].rule("_50", cs), Editor.concretes["EditorFre"].rule("_52", cs));}, _54: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_11", cs), Editor.concretes["EditorFre"].rule("_53", cs));}, _55: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_53", cs), Editor.concretes["EditorFre"].rule("_53", cs));}, _56: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_54", cs), Editor.concretes["EditorFre"].rule("_55", cs));}, _57: function(cs){return Editor.concretes["EditorFre"].rule("_56", cs).sel(Editor.concretes["EditorFre"].rule("_25", cs));}, _58: function(cs){return Editor.concretes["EditorFre"].rule("_57", cs).sel(Editor.concretes["EditorFre"].rule("_27", cs));}, _61: function(cs){return cs[3].sel(new Int(1));}, _62: function(cs){return Editor.concretes["EditorFre"].rule("_13", cs).sel(Editor.concretes["EditorFre"].rule("_61", cs));}, _63: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_62", cs), Editor.concretes["EditorFre"].rule("_20", cs));}, _64: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_63", cs), Editor.concretes["EditorFre"].rule("_22", cs));}, _65: function(cs){return Editor.concretes["EditorFre"].rule("_64", cs).sel(Editor.concretes["EditorFre"].rule("_25", cs));}, _66: function(cs){return Editor.concretes["EditorFre"].rule("_65", cs).sel(Editor.concretes["EditorFre"].rule("_27", cs));}, _67: function(cs){return Editor.concretes["EditorFre"].rule("_12", cs).sel(Editor.concretes["EditorFre"].rule("_66", cs));}, _68: function(cs){return new Seq(new Str("me"), Editor.concretes["EditorFre"].rule("_67", cs));}, _69: function(cs){return new Seq(new Str("te"), Editor.concretes["EditorFre"].rule("_67", cs));}, _70: function(cs){return new Seq(Editor.concretes["EditorFre"].rule("_67", cs), new Str("lui"));}, _71: function(cs){return new Seq(new Str("nous"), Editor.concretes["EditorFre"].rule("_67", cs));}, _72: function(cs){return new Seq(new Str("vous"), Editor.concretes["EditorFre"].rule("_67", cs));}, _73: function(cs){return new Seq(Editor.concretes["EditorFre"].rule("_67", cs), new Str("leur"));}, _76: function(cs){return Editor.concretes["EditorFre"].rule("_48", cs).sel(Editor.concretes["EditorFre"].rule("_61", cs));}, _77: function(cs){return Editor.concretes["EditorFre"].rule("_76", cs).sel(new Int(1));}, _78: function(cs){return new Arr(new Int(0), new Int(2));}, _79: function(cs){return Editor.concretes["EditorFre"].rule("_78", cs).sel(Editor.concretes["EditorFre"].rule("_61", cs));}, _8: function(cs){return new Arr(new Str(""), new Str("s"));}, _80: function(cs){return Editor.concretes["EditorFre"].rule("_52", cs).sel(Editor.concretes["EditorFre"].rule("_79", cs));}, _81: function(cs){return cs[3].sel(new Int(0));}, _82: function(cs){return Editor.concretes["EditorFre"].rule("_81", cs).sel(new Int(0));}, _83: function(cs){return new Seq(Editor.concretes["EditorFre"].rule("_80", cs), Editor.concretes["EditorFre"].rule("_82", cs));}, _84: function(cs){return new Seq(Editor.concretes["EditorFre"].rule("_82", cs), Editor.concretes["EditorFre"].rule("_80", cs));}, _85: function(cs){return new Arr(Editor.concretes["EditorFre"].rule("_83", cs), Editor.concretes["EditorFre"].rule("_84", cs));}, _86: function(cs){return Editor.concretes["EditorFre"].rule("_85", cs).sel(Editor.concretes["EditorFre"].rule("_14", cs));}, _87: function(cs){return new Seq(Editor.concretes["EditorFre"].rule("_77", cs), Editor.concretes["EditorFre"].rule("_86", cs));}, _95: function(cs){return new Arr(new Str("er"), new Str("er"), new Str("e"), new Str("es"), new Str("e"), new Str("ons"), new Str("ez"), new Str("ent"), new Str("e"), new Str("es"), new Str("e"), new Str("ions"), new Str("iez"), new Str("ent"), new Str("e"), new Str("ons"), new Str("ez"), new Str("é"), new Str("és"), new Str("ée"), new Str("ées"), new Str("ant"));}, Adjective: function(cs){return new Arr(new Arr(Editor.concretes["EditorFre"].rule("_229", cs), Editor.concretes["EditorFre"].rule("_229", cs), Editor.concretes["EditorFre"].rule("_229", cs)), new Int(0));}, Determiner: function(cs){return new Arr(new Arr(Editor.concretes["EditorFre"].rule("_233", cs), Editor.concretes["EditorFre"].rule("_233", cs)));}, Noun: function(cs){return new Arr(new Arr(cs[0], cs[0]), new Int(0));}, Sentence: function(cs){return new Arr(cs[0]);}, Verb: function(cs){return new Arr(new Arr(cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0]), new Int(0));}, "Int": function(cs){return new Arr(cs[0]);}, "Float": function(cs){return new Arr(cs[0]);}, "String": function(cs){return new Arr(cs[0]);}}, new Parser("Sentence",[new Rule(23, new FunApp("Wrapper",[]),[],[[new Terminal("emballage")]]), new Rule(87, new FunApp("Wrapper",[]),[],[[new Terminal("emballages")]]), new Rule(20, new FunApp("Wrap",[]),[],[[new Terminal("emballer")]]), new Rule(47, new FunApp("Wrap",[]),[],[[new Terminal("emballer")]]), new Rule(46, new FunApp("Wrap",[]),[],[[new Terminal("emballe")]]), new Rule(45, new FunApp("Wrap",[]),[],[[new Terminal("emballes")]]), new Rule(44, new FunApp("Wrap",[]),[],[[new Terminal("emballe")]]), new Rule(43, new FunApp("Wrap",[]),[],[[new Terminal("emballons")]]), new Rule(42, new FunApp("Wrap",[]),[],[[new Terminal("emballez")]]), new Rule(41, new FunApp("Wrap",[]),[],[[new Terminal("emballent")]]), new Rule(40, new FunApp("Wrap",[]),[],[[new Terminal("emballe")]]), new Rule(39, new FunApp("Wrap",[]),[],[[new Terminal("emballes")]]), new Rule(38, new FunApp("Wrap",[]),[],[[new Terminal("emballe")]]), new Rule(37, new FunApp("Wrap",[]),[],[[new Terminal("emballions")]]), new Rule(36, new FunApp("Wrap",[]),[],[[new Terminal("emballiez")]]), new Rule(35, new FunApp("Wrap",[]),[],[[new Terminal("emballent")]]), new Rule(34, new FunApp("Wrap",[]),[],[[new Terminal("emballe")]]), new Rule(33, new FunApp("Wrap",[]),[],[[new Terminal("emballons")]]), new Rule(32, new FunApp("Wrap",[]),[],[[new Terminal("emballez")]]), new Rule(31, new FunApp("Wrap",[]),[],[[new Terminal("emballé")]]), new Rule(30, new FunApp("Wrap",[]),[],[[new Terminal("emballés")]]), new Rule(29, new FunApp("Wrap",[]),[],[[new Terminal("emballée")]]), new Rule(28, new FunApp("Wrap",[]),[],[[new Terminal("emballées")]]), new Rule(27, new FunApp("Wrap",[]),[],[[new Terminal("emballant")]]), new Rule(20, new FunApp("Undo",[]),[],[[new Terminal("annuler")]]), new Rule(47, new FunApp("Undo",[]),[],[[new Terminal("annuler")]]), new Rule(46, new FunApp("Undo",[]),[],[[new Terminal("annule")]]), new Rule(45, new FunApp("Undo",[]),[],[[new Terminal("annules")]]), new Rule(44, new FunApp("Undo",[]),[],[[new Terminal("annule")]]), new Rule(43, new FunApp("Undo",[]),[],[[new Terminal("annulons")]]), new Rule(42, new FunApp("Undo",[]),[],[[new Terminal("annulez")]]), new Rule(41, new FunApp("Undo",[]),[],[[new Terminal("annulent")]]), new Rule(40, new FunApp("Undo",[]),[],[[new Terminal("annule")]]), new Rule(39, new FunApp("Undo",[]),[],[[new Terminal("annules")]]), new Rule(38, new FunApp("Undo",[]),[],[[new Terminal("annule")]]), new Rule(37, new FunApp("Undo",[]),[],[[new Terminal("annulions")]]), new Rule(36, new FunApp("Undo",[]),[],[[new Terminal("annuliez")]]), new Rule(35, new FunApp("Undo",[]),[],[[new Terminal("annulent")]]), new Rule(34, new FunApp("Undo",[]),[],[[new Terminal("annule")]]), new Rule(33, new FunApp("Undo",[]),[],[[new Terminal("annulons")]]), new Rule(32, new FunApp("Undo",[]),[],[[new Terminal("annulez")]]), new Rule(31, new FunApp("Undo",[]),[],[[new Terminal("annulé")]]), new Rule(30, new FunApp("Undo",[]),[],[[new Terminal("annulés")]]), new Rule(29, new FunApp("Undo",[]),[],[[new Terminal("annulée")]]), new Rule(28, new FunApp("Undo",[]),[],[[new Terminal("annulées")]]), new Rule(27, new FunApp("Undo",[]),[],[[new Terminal("annulant")]]), new Rule(17, new FunApp("Tree",[]),[],[[new Terminal("arbre")]]), new Rule(16, new FunApp("Tree",[]),[],[[new Terminal("arbres")]]), new Rule(17, new FunApp("Swedish",[]),[],[[new Terminal("suédois")]]), new Rule(16, new FunApp("Swedish",[]),[],[[new Terminal("suédois")]]), new Rule(23, new FunApp("String_N",[]),[],[[new Terminal("chaîne"), new Terminal("de"), new Terminal("charactères")]]), new Rule(87, new FunApp("String_N",[]),[],[[new Terminal("chaînes"), new Terminal("de"), new Terminal("charactères")]]), new Rule(17, new FunApp("Spanish",[]),[],[[new Terminal("espagnol")]]), new Rule(16, new FunApp("Spanish",[]),[],[[new Terminal("espagnols")]]), new Rule(18, new FunApp("SingleWordCommand",[new Arg(0)]),[22],[[new Terminal("s'"), new ArgProj(0, 0)]]), new Rule(18, new FunApp("SingleWordCommand",[new Arg(0)]),[22],[[new Terminal("se"), new ArgProj(0, 0)]]), new Rule(18, new FunApp("SingleWordCommand",[new Arg(0)]),[21],[[new ArgProj(0, 0)]]), new Rule(18, new FunApp("SingleWordCommand",[new Arg(0)]),[20],[[new ArgProj(0, 0)]]), new Rule(20, new FunApp("Show",[]),[],[[new Terminal("montrer")]]), new Rule(47, new FunApp("Show",[]),[],[[new Terminal("montrer")]]), new Rule(46, new FunApp("Show",[]),[],[[new Terminal("montre")]]), new Rule(45, new FunApp("Show",[]),[],[[new Terminal("montres")]]), new Rule(44, new FunApp("Show",[]),[],[[new Terminal("montre")]]), new Rule(43, new FunApp("Show",[]),[],[[new Terminal("montrons")]]), new Rule(42, new FunApp("Show",[]),[],[[new Terminal("montrez")]]), new Rule(41, new FunApp("Show",[]),[],[[new Terminal("montrent")]]), new Rule(40, new FunApp("Show",[]),[],[[new Terminal("montre")]]), new Rule(39, new FunApp("Show",[]),[],[[new Terminal("montres")]]), new Rule(38, new FunApp("Show",[]),[],[[new Terminal("montre")]]), new Rule(37, new FunApp("Show",[]),[],[[new Terminal("montrions")]]), new Rule(36, new FunApp("Show",[]),[],[[new Terminal("montriez")]]), new Rule(35, new FunApp("Show",[]),[],[[new Terminal("montrent")]]), new Rule(34, new FunApp("Show",[]),[],[[new Terminal("montre")]]), new Rule(33, new FunApp("Show",[]),[],[[new Terminal("montrons")]]), new Rule(32, new FunApp("Show",[]),[],[[new Terminal("montrez")]]), new Rule(31, new FunApp("Show",[]),[],[[new Terminal("montré")]]), new Rule(30, new FunApp("Show",[]),[],[[new Terminal("montrés")]]), new Rule(29, new FunApp("Show",[]),[],[[new Terminal("montrée")]]), new Rule(28, new FunApp("Show",[]),[],[[new Terminal("montrées")]]), new Rule(27, new FunApp("Show",[]),[],[[new Terminal("montrant")]]), new Rule(20, new FunApp("Select",[]),[],[[new Terminal("selectionner")]]), new Rule(47, new FunApp("Select",[]),[],[[new Terminal("selectionner")]]), new Rule(46, new FunApp("Select",[]),[],[[new Terminal("selectionne")]]), new Rule(45, new FunApp("Select",[]),[],[[new Terminal("selectionnes")]]), new Rule(44, new FunApp("Select",[]),[],[[new Terminal("selectionne")]]), new Rule(43, new FunApp("Select",[]),[],[[new Terminal("selectionnons")]]), new Rule(42, new FunApp("Select",[]),[],[[new Terminal("selectionnez")]]), new Rule(41, new FunApp("Select",[]),[],[[new Terminal("selectionnent")]]), new Rule(40, new FunApp("Select",[]),[],[[new Terminal("selectionne")]]), new Rule(39, new FunApp("Select",[]),[],[[new Terminal("selectionnes")]]), new Rule(38, new FunApp("Select",[]),[],[[new Terminal("selectionne")]]), new Rule(37, new FunApp("Select",[]),[],[[new Terminal("selectionnions")]]), new Rule(36, new FunApp("Select",[]),[],[[new Terminal("selectionniez")]]), new Rule(35, new FunApp("Select",[]),[],[[new Terminal("selectionnent")]]), new Rule(34, new FunApp("Select",[]),[],[[new Terminal("selectionne")]]), new Rule(33, new FunApp("Select",[]),[],[[new Terminal("selectionnons")]]), new Rule(32, new FunApp("Select",[]),[],[[new Terminal("selectionnez")]]), new Rule(31, new FunApp("Select",[]),[],[[new Terminal("selectionné")]]), new Rule(30, new FunApp("Select",[]),[],[[new Terminal("selectionnés")]]), new Rule(29, new FunApp("Select",[]),[],[[new Terminal("selectionnée")]]), new Rule(28, new FunApp("Select",[]),[],[[new Terminal("selectionnées")]]), new Rule(27, new FunApp("Select",[]),[],[[new Terminal("selectionnant")]]), new Rule(23, new FunApp("Russian",[]),[],[[new Terminal("russe")]]), new Rule(87, new FunApp("Russian",[]),[],[[new Terminal("russes")]]), new Rule(20, new FunApp("Replace",[]),[],[[new Terminal("remplacer")]]), new Rule(47, new FunApp("Replace",[]),[],[[new Terminal("remplacer")]]), new Rule(46, new FunApp("Replace",[]),[],[[new Terminal("remplace")]]), new Rule(45, new FunApp("Replace",[]),[],[[new Terminal("remplaces")]]), new Rule(44, new FunApp("Replace",[]),[],[[new Terminal("remplace")]]), new Rule(43, new FunApp("Replace",[]),[],[[new Terminal("remplaçons")]]), new Rule(42, new FunApp("Replace",[]),[],[[new Terminal("remplacez")]]), new Rule(41, new FunApp("Replace",[]),[],[[new Terminal("remplacent")]]), new Rule(40, new FunApp("Replace",[]),[],[[new Terminal("remplace")]]), new Rule(39, new FunApp("Replace",[]),[],[[new Terminal("remplaces")]]), new Rule(38, new FunApp("Replace",[]),[],[[new Terminal("remplace")]]), new Rule(37, new FunApp("Replace",[]),[],[[new Terminal("remplacions")]]), new Rule(36, new FunApp("Replace",[]),[],[[new Terminal("remplaciez")]]), new Rule(35, new FunApp("Replace",[]),[],[[new Terminal("remplacent")]]), new Rule(34, new FunApp("Replace",[]),[],[[new Terminal("remplace")]]), new Rule(33, new FunApp("Replace",[]),[],[[new Terminal("remplaçons")]]), new Rule(32, new FunApp("Replace",[]),[],[[new Terminal("remplacez")]]), new Rule(31, new FunApp("Replace",[]),[],[[new Terminal("remplacé")]]), new Rule(30, new FunApp("Replace",[]),[],[[new Terminal("remplacés")]]), new Rule(29, new FunApp("Replace",[]),[],[[new Terminal("remplacée")]]), new Rule(28, new FunApp("Replace",[]),[],[[new Terminal("remplacées")]]), new Rule(27, new FunApp("Replace",[]),[],[[new Terminal("remplaçant")]]), new Rule(17, new FunApp("Refinement",[]),[],[[new Terminal("raffinement")]]), new Rule(16, new FunApp("Refinement",[]),[],[[new Terminal("raffinements")]]), new Rule(20, new FunApp("Refine",[]),[],[[new Terminal("raffiner")]]), new Rule(47, new FunApp("Refine",[]),[],[[new Terminal("raffiner")]]), new Rule(46, new FunApp("Refine",[]),[],[[new Terminal("raffine")]]), new Rule(45, new FunApp("Refine",[]),[],[[new Terminal("raffines")]]), new Rule(44, new FunApp("Refine",[]),[],[[new Terminal("raffine")]]), new Rule(43, new FunApp("Refine",[]),[],[[new Terminal("raffinons")]]), new Rule(42, new FunApp("Refine",[]),[],[[new Terminal("raffinez")]]), new Rule(41, new FunApp("Refine",[]),[],[[new Terminal("raffinent")]]), new Rule(40, new FunApp("Refine",[]),[],[[new Terminal("raffine")]]), new Rule(39, new FunApp("Refine",[]),[],[[new Terminal("raffines")]]), new Rule(38, new FunApp("Refine",[]),[],[[new Terminal("raffine")]]), new Rule(37, new FunApp("Refine",[]),[],[[new Terminal("raffinions")]]), new Rule(36, new FunApp("Refine",[]),[],[[new Terminal("raffiniez")]]), new Rule(35, new FunApp("Refine",[]),[],[[new Terminal("raffinent")]]), new Rule(34, new FunApp("Refine",[]),[],[[new Terminal("raffine")]]), new Rule(33, new FunApp("Refine",[]),[],[[new Terminal("raffinons")]]), new Rule(32, new FunApp("Refine",[]),[],[[new Terminal("raffinez")]]), new Rule(31, new FunApp("Refine",[]),[],[[new Terminal("raffiné")]]), new Rule(30, new FunApp("Refine",[]),[],[[new Terminal("raffinés")]]), new Rule(29, new FunApp("Refine",[]),[],[[new Terminal("raffinée")]]), new Rule(28, new FunApp("Refine",[]),[],[[new Terminal("raffinées")]]), new Rule(27, new FunApp("Refine",[]),[],[[new Terminal("raffinant")]]), new Rule(20, new FunApp("Redo",[]),[],[[new Terminal("refaire")]]), new Rule(47, new FunApp("Redo",[]),[],[[new Terminal("refaire")]]), new Rule(46, new FunApp("Redo",[]),[],[[new Terminal("refais")]]), new Rule(45, new FunApp("Redo",[]),[],[[new Terminal("refais")]]), new Rule(44, new FunApp("Redo",[]),[],[[new Terminal("refait")]]), new Rule(43, new FunApp("Redo",[]),[],[[new Terminal("refaisons")]]), new Rule(42, new FunApp("Redo",[]),[],[[new Terminal("refaites")]]), new Rule(41, new FunApp("Redo",[]),[],[[new Terminal("refont")]]), new Rule(40, new FunApp("Redo",[]),[],[[new Terminal("refasse")]]), new Rule(39, new FunApp("Redo",[]),[],[[new Terminal("refasses")]]), new Rule(38, new FunApp("Redo",[]),[],[[new Terminal("refasse")]]), new Rule(37, new FunApp("Redo",[]),[],[[new Terminal("refassions")]]), new Rule(36, new FunApp("Redo",[]),[],[[new Terminal("refassiez")]]), new Rule(35, new FunApp("Redo",[]),[],[[new Terminal("refassent")]]), new Rule(34, new FunApp("Redo",[]),[],[[new Terminal("refais")]]), new Rule(33, new FunApp("Redo",[]),[],[[new Terminal("refaisons")]]), new Rule(32, new FunApp("Redo",[]),[],[[new Terminal("refaites")]]), new Rule(31, new FunApp("Redo",[]),[],[[new Terminal("refait")]]), new Rule(30, new FunApp("Redo",[]),[],[[new Terminal("refaits")]]), new Rule(29, new FunApp("Redo",[]),[],[[new Terminal("refaite")]]), new Rule(28, new FunApp("Redo",[]),[],[[new Terminal("refaites")]]), new Rule(27, new FunApp("Redo",[]),[],[[new Terminal("refaisant")]]), new Rule(18, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[22, 24, 23],[[new Terminal("s'"), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("aléatoirement")]]), new Rule(18, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[22, 24, 23],[[new Terminal("se"), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("aléatoirement")]]), new Rule(18, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[21, 24, 23],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("aléatoirement")]]), new Rule(18, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[20, 24, 23],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("aléatoirement")]]), new Rule(18, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[22, 19, 17],[[new Terminal("s'"), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("aléatoirement")]]), new Rule(18, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[22, 19, 17],[[new Terminal("se"), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("aléatoirement")]]), new Rule(18, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[21, 19, 17],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("aléatoirement")]]), new Rule(18, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[20, 19, 17],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("aléatoirement")]]), new Rule(15, new FunApp("Previous",[]),[],[[new Terminal("précédent")]]), new Rule(14, new FunApp("Previous",[]),[],[[new Terminal("précédents")]]), new Rule(13, new FunApp("Previous",[]),[],[[new Terminal("précédente")]]), new Rule(12, new FunApp("Previous",[]),[],[[new Terminal("précédentes")]]), new Rule(11, new FunApp("Previous",[]),[],[[new Terminal("précédentement")]]), new Rule(10, new FunApp("Previous",[]),[],[[new Terminal("plus"), new Terminal("précédent")]]), new Rule(9, new FunApp("Previous",[]),[],[[new Terminal("plus"), new Terminal("précédents")]]), new Rule(8, new FunApp("Previous",[]),[],[[new Terminal("plus"), new Terminal("précédente")]]), new Rule(7, new FunApp("Previous",[]),[],[[new Terminal("plus"), new Terminal("précédentes")]]), new Rule(6, new FunApp("Previous",[]),[],[[new Terminal("plus"), new Terminal("précédentement")]]), new Rule(5, new FunApp("Previous",[]),[],[[new Terminal("plus"), new Terminal("précédent")]]), new Rule(4, new FunApp("Previous",[]),[],[[new Terminal("plus"), new Terminal("précédents")]]), new Rule(3, new FunApp("Previous",[]),[],[[new Terminal("plus"), new Terminal("précédente")]]), new Rule(2, new FunApp("Previous",[]),[],[[new Terminal("plus"), new Terminal("précédentes")]]), new Rule(1, new FunApp("Previous",[]),[],[[new Terminal("plus"), new Terminal("précédentement")]]), new Rule(20, new FunApp("Paste",[]),[],[[new Terminal("coller")]]), new Rule(47, new FunApp("Paste",[]),[],[[new Terminal("coller")]]), new Rule(46, new FunApp("Paste",[]),[],[[new Terminal("colle")]]), new Rule(45, new FunApp("Paste",[]),[],[[new Terminal("colles")]]), new Rule(44, new FunApp("Paste",[]),[],[[new Terminal("colle")]]), new Rule(43, new FunApp("Paste",[]),[],[[new Terminal("collons")]]), new Rule(42, new FunApp("Paste",[]),[],[[new Terminal("collez")]]), new Rule(41, new FunApp("Paste",[]),[],[[new Terminal("collent")]]), new Rule(40, new FunApp("Paste",[]),[],[[new Terminal("colle")]]), new Rule(39, new FunApp("Paste",[]),[],[[new Terminal("colles")]]), new Rule(38, new FunApp("Paste",[]),[],[[new Terminal("colle")]]), new Rule(37, new FunApp("Paste",[]),[],[[new Terminal("collions")]]), new Rule(36, new FunApp("Paste",[]),[],[[new Terminal("colliez")]]), new Rule(35, new FunApp("Paste",[]),[],[[new Terminal("collent")]]), new Rule(34, new FunApp("Paste",[]),[],[[new Terminal("colle")]]), new Rule(33, new FunApp("Paste",[]),[],[[new Terminal("collons")]]), new Rule(32, new FunApp("Paste",[]),[],[[new Terminal("collez")]]), new Rule(31, new FunApp("Paste",[]),[],[[new Terminal("collé")]]), new Rule(30, new FunApp("Paste",[]),[],[[new Terminal("collés")]]), new Rule(29, new FunApp("Paste",[]),[],[[new Terminal("collée")]]), new Rule(28, new FunApp("Paste",[]),[],[[new Terminal("collées")]]), new Rule(27, new FunApp("Paste",[]),[],[[new Terminal("collant")]]), new Rule(20, new FunApp("Parse",[]),[],[[new Terminal("analyser")]]), new Rule(47, new FunApp("Parse",[]),[],[[new Terminal("analyser")]]), new Rule(46, new FunApp("Parse",[]),[],[[new Terminal("analyse")]]), new Rule(45, new FunApp("Parse",[]),[],[[new Terminal("analyses")]]), new Rule(44, new FunApp("Parse",[]),[],[[new Terminal("analyse")]]), new Rule(43, new FunApp("Parse",[]),[],[[new Terminal("analysons")]]), new Rule(42, new FunApp("Parse",[]),[],[[new Terminal("analysez")]]), new Rule(41, new FunApp("Parse",[]),[],[[new Terminal("analysent")]]), new Rule(40, new FunApp("Parse",[]),[],[[new Terminal("analyse")]]), new Rule(39, new FunApp("Parse",[]),[],[[new Terminal("analyses")]]), new Rule(38, new FunApp("Parse",[]),[],[[new Terminal("analyse")]]), new Rule(37, new FunApp("Parse",[]),[],[[new Terminal("analysions")]]), new Rule(36, new FunApp("Parse",[]),[],[[new Terminal("analysiez")]]), new Rule(35, new FunApp("Parse",[]),[],[[new Terminal("analysent")]]), new Rule(34, new FunApp("Parse",[]),[],[[new Terminal("analyse")]]), new Rule(33, new FunApp("Parse",[]),[],[[new Terminal("analysons")]]), new Rule(32, new FunApp("Parse",[]),[],[[new Terminal("analysez")]]), new Rule(31, new FunApp("Parse",[]),[],[[new Terminal("analysé")]]), new Rule(30, new FunApp("Parse",[]),[],[[new Terminal("analysés")]]), new Rule(29, new FunApp("Parse",[]),[],[[new Terminal("analysée")]]), new Rule(28, new FunApp("Parse",[]),[],[[new Terminal("analysées")]]), new Rule(27, new FunApp("Parse",[]),[],[[new Terminal("analysant")]]), new Rule(23, new FunApp("Page",[]),[],[[new Terminal("page")]]), new Rule(87, new FunApp("Page",[]),[],[[new Terminal("pages")]]), new Rule(17, new FunApp("Norwegian",[]),[],[[new Terminal("norvégien")]]), new Rule(16, new FunApp("Norwegian",[]),[],[[new Terminal("norvégiens")]]), new Rule(17, new FunApp("Node",[]),[],[[new Terminal("noeud")]]), new Rule(16, new FunApp("Node",[]),[],[[new Terminal("noeuds")]]), new Rule(15, new FunApp("Next",[]),[],[[new Terminal("prochain")]]), new Rule(14, new FunApp("Next",[]),[],[[new Terminal("prochains")]]), new Rule(13, new FunApp("Next",[]),[],[[new Terminal("prochaine")]]), new Rule(12, new FunApp("Next",[]),[],[[new Terminal("prochaines")]]), new Rule(11, new FunApp("Next",[]),[],[[new Terminal("prochainement")]]), new Rule(10, new FunApp("Next",[]),[],[[new Terminal("plus"), new Terminal("prochain")]]), new Rule(9, new FunApp("Next",[]),[],[[new Terminal("plus"), new Terminal("prochains")]]), new Rule(8, new FunApp("Next",[]),[],[[new Terminal("plus"), new Terminal("prochaine")]]), new Rule(7, new FunApp("Next",[]),[],[[new Terminal("plus"), new Terminal("prochaines")]]), new Rule(6, new FunApp("Next",[]),[],[[new Terminal("plus"), new Terminal("prochainement")]]), new Rule(5, new FunApp("Next",[]),[],[[new Terminal("plus"), new Terminal("prochain")]]), new Rule(4, new FunApp("Next",[]),[],[[new Terminal("plus"), new Terminal("prochains")]]), new Rule(3, new FunApp("Next",[]),[],[[new Terminal("plus"), new Terminal("prochaine")]]), new Rule(2, new FunApp("Next",[]),[],[[new Terminal("plus"), new Terminal("prochaines")]]), new Rule(1, new FunApp("Next",[]),[],[[new Terminal("plus"), new Terminal("prochainement")]]), new Rule(23, new FunApp("Language",[]),[],[[new Terminal("langue")]]), new Rule(87, new FunApp("Language",[]),[],[[new Terminal("langues")]]), new Rule(18, new FunApp("Label",[new Arg(0)]),[89],[[new ArgProj(0, 0)]]), new Rule(89, new Arg(0),[23],[[new ArgProj(0, 0)]]), new Rule(89, new Arg(0),[17],[[new ArgProj(0, 0)]]), new Rule(17, new FunApp("Italian",[]),[],[[new Terminal("italien")]]), new Rule(16, new FunApp("Italian",[]),[],[[new Terminal("italiens")]]), new Rule(17, new FunApp("Integer_N",[]),[],[[new Terminal("entier")]]), new Rule(16, new FunApp("Integer_N",[]),[],[[new Terminal("entiers")]]), new Rule(85, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(84, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(83, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(82, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(81, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(80, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(79, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(78, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(77, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(76, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(75, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(74, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(73, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(72, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(71, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(70, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(69, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(68, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(67, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(66, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(65, new FunApp("IndefSgDet",[]),[],[[new Terminal("un")]]), new Rule(19, new FunApp("IndefSgDet",[]),[],[[new Terminal("un")]]), new Rule(64, new FunApp("IndefSgDet",[]),[],[[new Terminal("d'"), new Terminal("un")]]), new Rule(63, new FunApp("IndefSgDet",[]),[],[[new Terminal("Ã"), new Terminal("un")]]), new Rule(62, new FunApp("IndefSgDet",[]),[],[[new Terminal("un")]]), new Rule(61, new FunApp("IndefSgDet",[]),[],[[new Terminal("une")]]), new Rule(24, new FunApp("IndefSgDet",[]),[],[[new Terminal("une")]]), new Rule(60, new FunApp("IndefSgDet",[]),[],[[new Terminal("d'"), new Terminal("une")]]), new Rule(59, new FunApp("IndefSgDet",[]),[],[[new Terminal("Ã"), new Terminal("une")]]), new Rule(58, new FunApp("IndefSgDet",[]),[],[[new Terminal("une")]]), new Rule(57, new FunApp("IndefSgDet",[]),[],[[new Terminal("des")]]), new Rule(56, new FunApp("IndefSgDet",[]),[],[[new Terminal("des")]]), new Rule(55, new FunApp("IndefSgDet",[]),[],[[new Terminal("d'")]]), new Rule(55, new FunApp("IndefSgDet",[]),[],[[new Terminal("de")]]), new Rule(54, new FunApp("IndefSgDet",[]),[],[[new Terminal("Ã"), new Terminal("des")]]), new Rule(53, new FunApp("IndefSgDet",[]),[],[[new Terminal("des")]]), new Rule(52, new FunApp("IndefSgDet",[]),[],[[new Terminal("des")]]), new Rule(51, new FunApp("IndefSgDet",[]),[],[[new Terminal("des")]]), new Rule(50, new FunApp("IndefSgDet",[]),[],[[new Terminal("d'")]]), new Rule(50, new FunApp("IndefSgDet",[]),[],[[new Terminal("de")]]), new Rule(49, new FunApp("IndefSgDet",[]),[],[[new Terminal("Ã"), new Terminal("des")]]), new Rule(48, new FunApp("IndefSgDet",[]),[],[[new Terminal("des")]]), new Rule(85, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(84, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(83, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(82, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(81, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(80, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(79, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(78, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(77, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(76, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(75, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(74, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(73, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(72, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(71, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(70, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(69, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(68, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(67, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(66, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(65, new FunApp("IndefPlDet",[]),[],[[new Terminal("un")]]), new Rule(19, new FunApp("IndefPlDet",[]),[],[[new Terminal("un")]]), new Rule(64, new FunApp("IndefPlDet",[]),[],[[new Terminal("d'"), new Terminal("un")]]), new Rule(63, new FunApp("IndefPlDet",[]),[],[[new Terminal("Ã"), new Terminal("un")]]), new Rule(62, new FunApp("IndefPlDet",[]),[],[[new Terminal("un")]]), new Rule(61, new FunApp("IndefPlDet",[]),[],[[new Terminal("une")]]), new Rule(24, new FunApp("IndefPlDet",[]),[],[[new Terminal("une")]]), new Rule(60, new FunApp("IndefPlDet",[]),[],[[new Terminal("d'"), new Terminal("une")]]), new Rule(59, new FunApp("IndefPlDet",[]),[],[[new Terminal("Ã"), new Terminal("une")]]), new Rule(58, new FunApp("IndefPlDet",[]),[],[[new Terminal("une")]]), new Rule(57, new FunApp("IndefPlDet",[]),[],[[new Terminal("des")]]), new Rule(56, new FunApp("IndefPlDet",[]),[],[[new Terminal("des")]]), new Rule(55, new FunApp("IndefPlDet",[]),[],[[new Terminal("d'")]]), new Rule(55, new FunApp("IndefPlDet",[]),[],[[new Terminal("de")]]), new Rule(54, new FunApp("IndefPlDet",[]),[],[[new Terminal("Ã"), new Terminal("des")]]), new Rule(53, new FunApp("IndefPlDet",[]),[],[[new Terminal("des")]]), new Rule(52, new FunApp("IndefPlDet",[]),[],[[new Terminal("des")]]), new Rule(51, new FunApp("IndefPlDet",[]),[],[[new Terminal("des")]]), new Rule(50, new FunApp("IndefPlDet",[]),[],[[new Terminal("d'")]]), new Rule(50, new FunApp("IndefPlDet",[]),[],[[new Terminal("de")]]), new Rule(49, new FunApp("IndefPlDet",[]),[],[[new Terminal("Ã"), new Terminal("des")]]), new Rule(48, new FunApp("IndefPlDet",[]),[],[[new Terminal("des")]]), new Rule(17, new FunApp("German",[]),[],[[new Terminal("allemand")]]), new Rule(16, new FunApp("German",[]),[],[[new Terminal("allemands")]]), new Rule(17, new FunApp("French",[]),[],[[new Terminal("français")]]), new Rule(16, new FunApp("French",[]),[],[[new Terminal("français")]]), new Rule(17, new FunApp("Float_N",[]),[],[[new Terminal("réel")]]), new Rule(16, new FunApp("Float_N",[]),[],[[new Terminal("réels")]]), new Rule(17, new FunApp("Finnish",[]),[],[[new Terminal("finnois")]]), new Rule(16, new FunApp("Finnish",[]),[],[[new Terminal("finnois")]]), new Rule(18, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[12, 87],[[new Terminal("il"), new Terminal("n'"), new Terminal("y"), new Terminal("a"), new Terminal("pas"), new Terminal("des"), new ArgProj(1, 0), new ArgProj(0, 0)]]), new Rule(18, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[12, 87],[[new Terminal("il"), new Terminal("ne"), new Terminal("y"), new Terminal("a"), new Terminal("pas"), new Terminal("des"), new ArgProj(1, 0), new ArgProj(0, 0)]]), new Rule(18, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[14, 16],[[new Terminal("il"), new Terminal("n'"), new Terminal("y"), new Terminal("a"), new Terminal("pas"), new Terminal("des"), new ArgProj(1, 0), new ArgProj(0, 0)]]), new Rule(18, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[14, 16],[[new Terminal("il"), new Terminal("ne"), new Terminal("y"), new Terminal("a"), new Terminal("pas"), new Terminal("des"), new ArgProj(1, 0), new ArgProj(0, 0)]]), new Rule(18, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[88, 87],[[new Terminal("il"), new Terminal("n'"), new Terminal("y"), new Terminal("a"), new Terminal("pas"), new Terminal("des"), new ArgProj(0, 0), new ArgProj(1, 0)]]), new Rule(18, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[88, 87],[[new Terminal("il"), new Terminal("ne"), new Terminal("y"), new Terminal("a"), new Terminal("pas"), new Terminal("des"), new ArgProj(0, 0), new ArgProj(1, 0)]]), new Rule(18, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[86, 16],[[new Terminal("il"), new Terminal("n'"), new Terminal("y"), new Terminal("a"), new Terminal("pas"), new Terminal("des"), new ArgProj(0, 0), new ArgProj(1, 0)]]), new Rule(18, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[86, 16],[[new Terminal("il"), new Terminal("ne"), new Terminal("y"), new Terminal("a"), new Terminal("pas"), new Terminal("des"), new ArgProj(0, 0), new ArgProj(1, 0)]]), new Rule(20, new FunApp("Enter",[]),[],[[new Terminal("introduire")]]), new Rule(47, new FunApp("Enter",[]),[],[[new Terminal("introduire")]]), new Rule(46, new FunApp("Enter",[]),[],[[new Terminal("introduis")]]), new Rule(45, new FunApp("Enter",[]),[],[[new Terminal("introduis")]]), new Rule(44, new FunApp("Enter",[]),[],[[new Terminal("introduit")]]), new Rule(43, new FunApp("Enter",[]),[],[[new Terminal("introduisons")]]), new Rule(42, new FunApp("Enter",[]),[],[[new Terminal("introduisez")]]), new Rule(41, new FunApp("Enter",[]),[],[[new Terminal("introduisent")]]), new Rule(40, new FunApp("Enter",[]),[],[[new Terminal("introduise")]]), new Rule(39, new FunApp("Enter",[]),[],[[new Terminal("introduises")]]), new Rule(38, new FunApp("Enter",[]),[],[[new Terminal("introduise")]]), new Rule(37, new FunApp("Enter",[]),[],[[new Terminal("introduisions")]]), new Rule(36, new FunApp("Enter",[]),[],[[new Terminal("introduisiez")]]), new Rule(35, new FunApp("Enter",[]),[],[[new Terminal("introduisent")]]), new Rule(34, new FunApp("Enter",[]),[],[[new Terminal("introduis")]]), new Rule(33, new FunApp("Enter",[]),[],[[new Terminal("introduisons")]]), new Rule(32, new FunApp("Enter",[]),[],[[new Terminal("introduisez")]]), new Rule(31, new FunApp("Enter",[]),[],[[new Terminal("introduit")]]), new Rule(30, new FunApp("Enter",[]),[],[[new Terminal("introduits")]]), new Rule(29, new FunApp("Enter",[]),[],[[new Terminal("introduite")]]), new Rule(28, new FunApp("Enter",[]),[],[[new Terminal("introduites")]]), new Rule(27, new FunApp("Enter",[]),[],[[new Terminal("introduisant")]]), new Rule(17, new FunApp("English",[]),[],[[new Terminal("anglais")]]), new Rule(16, new FunApp("English",[]),[],[[new Terminal("anglais")]]), new Rule(20, new FunApp("Delete",[]),[],[[new Terminal("enlever")]]), new Rule(47, new FunApp("Delete",[]),[],[[new Terminal("enlever")]]), new Rule(46, new FunApp("Delete",[]),[],[[new Terminal("enleve")]]), new Rule(45, new FunApp("Delete",[]),[],[[new Terminal("enleves")]]), new Rule(44, new FunApp("Delete",[]),[],[[new Terminal("enleve")]]), new Rule(43, new FunApp("Delete",[]),[],[[new Terminal("enlevons")]]), new Rule(42, new FunApp("Delete",[]),[],[[new Terminal("enlevez")]]), new Rule(41, new FunApp("Delete",[]),[],[[new Terminal("enlevent")]]), new Rule(40, new FunApp("Delete",[]),[],[[new Terminal("enleve")]]), new Rule(39, new FunApp("Delete",[]),[],[[new Terminal("enleves")]]), new Rule(38, new FunApp("Delete",[]),[],[[new Terminal("enleve")]]), new Rule(37, new FunApp("Delete",[]),[],[[new Terminal("enlevions")]]), new Rule(36, new FunApp("Delete",[]),[],[[new Terminal("enleviez")]]), new Rule(35, new FunApp("Delete",[]),[],[[new Terminal("enlevent")]]), new Rule(34, new FunApp("Delete",[]),[],[[new Terminal("enleve")]]), new Rule(33, new FunApp("Delete",[]),[],[[new Terminal("enlevons")]]), new Rule(32, new FunApp("Delete",[]),[],[[new Terminal("enlevez")]]), new Rule(31, new FunApp("Delete",[]),[],[[new Terminal("enlevé")]]), new Rule(30, new FunApp("Delete",[]),[],[[new Terminal("enlevés")]]), new Rule(29, new FunApp("Delete",[]),[],[[new Terminal("enlevée")]]), new Rule(28, new FunApp("Delete",[]),[],[[new Terminal("enlevées")]]), new Rule(27, new FunApp("Delete",[]),[],[[new Terminal("enlevant")]]), new Rule(85, new FunApp("DefSgDet",[]),[],[[new Terminal("l'")]]), new Rule(85, new FunApp("DefSgDet",[]),[],[[new Terminal("le")]]), new Rule(84, new FunApp("DefSgDet",[]),[],[[new Terminal("l'")]]), new Rule(84, new FunApp("DefSgDet",[]),[],[[new Terminal("le")]]), new Rule(83, new FunApp("DefSgDet",[]),[],[[new Terminal("de"), new Terminal("l'")]]), new Rule(83, new FunApp("DefSgDet",[]),[],[[new Terminal("du")]]), new Rule(82, new FunApp("DefSgDet",[]),[],[[new Terminal("Ã"), new Terminal("l'")]]), new Rule(82, new FunApp("DefSgDet",[]),[],[[new Terminal("au")]]), new Rule(81, new FunApp("DefSgDet",[]),[],[[new Terminal("l'")]]), new Rule(81, new FunApp("DefSgDet",[]),[],[[new Terminal("le")]]), new Rule(80, new FunApp("DefSgDet",[]),[],[[new Terminal("l'")]]), new Rule(80, new FunApp("DefSgDet",[]),[],[[new Terminal("la")]]), new Rule(79, new FunApp("DefSgDet",[]),[],[[new Terminal("l'")]]), new Rule(79, new FunApp("DefSgDet",[]),[],[[new Terminal("la")]]), new Rule(78, new FunApp("DefSgDet",[]),[],[[new Terminal("d'"), new Terminal("l'")]]), new Rule(78, new FunApp("DefSgDet",[]),[],[[new Terminal("de"), new Terminal("l'")]]), new Rule(78, new FunApp("DefSgDet",[]),[],[[new Terminal("d'"), new Terminal("la")]]), new Rule(78, new FunApp("DefSgDet",[]),[],[[new Terminal("de"), new Terminal("la")]]), new Rule(77, new FunApp("DefSgDet",[]),[],[[new Terminal("Ã"), new Terminal("l'")]]), new Rule(77, new FunApp("DefSgDet",[]),[],[[new Terminal("Ã"), new Terminal("la")]]), new Rule(76, new FunApp("DefSgDet",[]),[],[[new Terminal("l'")]]), new Rule(76, new FunApp("DefSgDet",[]),[],[[new Terminal("la")]]), new Rule(75, new FunApp("DefSgDet",[]),[],[[new Terminal("les")]]), new Rule(74, new FunApp("DefSgDet",[]),[],[[new Terminal("les")]]), new Rule(73, new FunApp("DefSgDet",[]),[],[[new Terminal("des")]]), new Rule(72, new FunApp("DefSgDet",[]),[],[[new Terminal("aux")]]), new Rule(71, new FunApp("DefSgDet",[]),[],[[new Terminal("les")]]), new Rule(70, new FunApp("DefSgDet",[]),[],[[new Terminal("les")]]), new Rule(69, new FunApp("DefSgDet",[]),[],[[new Terminal("les")]]), new Rule(68, new FunApp("DefSgDet",[]),[],[[new Terminal("des")]]), new Rule(67, new FunApp("DefSgDet",[]),[],[[new Terminal("aux")]]), new Rule(66, new FunApp("DefSgDet",[]),[],[[new Terminal("les")]]), new Rule(65, new FunApp("DefSgDet",[]),[],[[new Terminal("l'")]]), new Rule(65, new FunApp("DefSgDet",[]),[],[[new Terminal("le")]]), new Rule(19, new FunApp("DefSgDet",[]),[],[[new Terminal("l'")]]), new Rule(19, new FunApp("DefSgDet",[]),[],[[new Terminal("le")]]), new Rule(64, new FunApp("DefSgDet",[]),[],[[new Terminal("de"), new Terminal("l'")]]), new Rule(64, new FunApp("DefSgDet",[]),[],[[new Terminal("du")]]), new Rule(63, new FunApp("DefSgDet",[]),[],[[new Terminal("Ã"), new Terminal("l'")]]), new Rule(63, new FunApp("DefSgDet",[]),[],[[new Terminal("au")]]), new Rule(62, new FunApp("DefSgDet",[]),[],[[new Terminal("l'")]]), new Rule(62, new FunApp("DefSgDet",[]),[],[[new Terminal("le")]]), new Rule(61, new FunApp("DefSgDet",[]),[],[[new Terminal("l'")]]), new Rule(61, new FunApp("DefSgDet",[]),[],[[new Terminal("la")]]), new Rule(24, new FunApp("DefSgDet",[]),[],[[new Terminal("l'")]]), new Rule(24, new FunApp("DefSgDet",[]),[],[[new Terminal("la")]]), new Rule(60, new FunApp("DefSgDet",[]),[],[[new Terminal("d'"), new Terminal("l'")]]), new Rule(60, new FunApp("DefSgDet",[]),[],[[new Terminal("de"), new Terminal("l'")]]), new Rule(60, new FunApp("DefSgDet",[]),[],[[new Terminal("d'"), new Terminal("la")]]), new Rule(60, new FunApp("DefSgDet",[]),[],[[new Terminal("de"), new Terminal("la")]]), new Rule(59, new FunApp("DefSgDet",[]),[],[[new Terminal("Ã"), new Terminal("l'")]]), new Rule(59, new FunApp("DefSgDet",[]),[],[[new Terminal("Ã"), new Terminal("la")]]), new Rule(58, new FunApp("DefSgDet",[]),[],[[new Terminal("l'")]]), new Rule(58, new FunApp("DefSgDet",[]),[],[[new Terminal("la")]]), new Rule(57, new FunApp("DefSgDet",[]),[],[[new Terminal("les")]]), new Rule(56, new FunApp("DefSgDet",[]),[],[[new Terminal("les")]]), new Rule(55, new FunApp("DefSgDet",[]),[],[[new Terminal("des")]]), new Rule(54, new FunApp("DefSgDet",[]),[],[[new Terminal("aux")]]), new Rule(53, new FunApp("DefSgDet",[]),[],[[new Terminal("les")]]), new Rule(52, new FunApp("DefSgDet",[]),[],[[new Terminal("les")]]), new Rule(51, new FunApp("DefSgDet",[]),[],[[new Terminal("les")]]), new Rule(50, new FunApp("DefSgDet",[]),[],[[new Terminal("des")]]), new Rule(49, new FunApp("DefSgDet",[]),[],[[new Terminal("aux")]]), new Rule(48, new FunApp("DefSgDet",[]),[],[[new Terminal("les")]]), new Rule(85, new FunApp("DefPlDet",[]),[],[[new Terminal("l'")]]), new Rule(85, new FunApp("DefPlDet",[]),[],[[new Terminal("le")]]), new Rule(84, new FunApp("DefPlDet",[]),[],[[new Terminal("l'")]]), new Rule(84, new FunApp("DefPlDet",[]),[],[[new Terminal("le")]]), new Rule(83, new FunApp("DefPlDet",[]),[],[[new Terminal("de"), new Terminal("l'")]]), new Rule(83, new FunApp("DefPlDet",[]),[],[[new Terminal("du")]]), new Rule(82, new FunApp("DefPlDet",[]),[],[[new Terminal("Ã"), new Terminal("l'")]]), new Rule(82, new FunApp("DefPlDet",[]),[],[[new Terminal("au")]]), new Rule(81, new FunApp("DefPlDet",[]),[],[[new Terminal("l'")]]), new Rule(81, new FunApp("DefPlDet",[]),[],[[new Terminal("le")]]), new Rule(80, new FunApp("DefPlDet",[]),[],[[new Terminal("l'")]]), new Rule(80, new FunApp("DefPlDet",[]),[],[[new Terminal("la")]]), new Rule(79, new FunApp("DefPlDet",[]),[],[[new Terminal("l'")]]), new Rule(79, new FunApp("DefPlDet",[]),[],[[new Terminal("la")]]), new Rule(78, new FunApp("DefPlDet",[]),[],[[new Terminal("d'"), new Terminal("l'")]]), new Rule(78, new FunApp("DefPlDet",[]),[],[[new Terminal("de"), new Terminal("l'")]]), new Rule(78, new FunApp("DefPlDet",[]),[],[[new Terminal("d'"), new Terminal("la")]]), new Rule(78, new FunApp("DefPlDet",[]),[],[[new Terminal("de"), new Terminal("la")]]), new Rule(77, new FunApp("DefPlDet",[]),[],[[new Terminal("Ã"), new Terminal("l'")]]), new Rule(77, new FunApp("DefPlDet",[]),[],[[new Terminal("Ã"), new Terminal("la")]]), new Rule(76, new FunApp("DefPlDet",[]),[],[[new Terminal("l'")]]), new Rule(76, new FunApp("DefPlDet",[]),[],[[new Terminal("la")]]), new Rule(75, new FunApp("DefPlDet",[]),[],[[new Terminal("les")]]), new Rule(74, new FunApp("DefPlDet",[]),[],[[new Terminal("les")]]), new Rule(73, new FunApp("DefPlDet",[]),[],[[new Terminal("des")]]), new Rule(72, new FunApp("DefPlDet",[]),[],[[new Terminal("aux")]]), new Rule(71, new FunApp("DefPlDet",[]),[],[[new Terminal("les")]]), new Rule(70, new FunApp("DefPlDet",[]),[],[[new Terminal("les")]]), new Rule(69, new FunApp("DefPlDet",[]),[],[[new Terminal("les")]]), new Rule(68, new FunApp("DefPlDet",[]),[],[[new Terminal("des")]]), new Rule(67, new FunApp("DefPlDet",[]),[],[[new Terminal("aux")]]), new Rule(66, new FunApp("DefPlDet",[]),[],[[new Terminal("les")]]), new Rule(65, new FunApp("DefPlDet",[]),[],[[new Terminal("l'")]]), new Rule(65, new FunApp("DefPlDet",[]),[],[[new Terminal("le")]]), new Rule(19, new FunApp("DefPlDet",[]),[],[[new Terminal("l'")]]), new Rule(19, new FunApp("DefPlDet",[]),[],[[new Terminal("le")]]), new Rule(64, new FunApp("DefPlDet",[]),[],[[new Terminal("de"), new Terminal("l'")]]), new Rule(64, new FunApp("DefPlDet",[]),[],[[new Terminal("du")]]), new Rule(63, new FunApp("DefPlDet",[]),[],[[new Terminal("Ã"), new Terminal("l'")]]), new Rule(63, new FunApp("DefPlDet",[]),[],[[new Terminal("au")]]), new Rule(62, new FunApp("DefPlDet",[]),[],[[new Terminal("l'")]]), new Rule(62, new FunApp("DefPlDet",[]),[],[[new Terminal("le")]]), new Rule(61, new FunApp("DefPlDet",[]),[],[[new Terminal("l'")]]), new Rule(61, new FunApp("DefPlDet",[]),[],[[new Terminal("la")]]), new Rule(24, new FunApp("DefPlDet",[]),[],[[new Terminal("l'")]]), new Rule(24, new FunApp("DefPlDet",[]),[],[[new Terminal("la")]]), new Rule(60, new FunApp("DefPlDet",[]),[],[[new Terminal("d'"), new Terminal("l'")]]), new Rule(60, new FunApp("DefPlDet",[]),[],[[new Terminal("de"), new Terminal("l'")]]), new Rule(60, new FunApp("DefPlDet",[]),[],[[new Terminal("d'"), new Terminal("la")]]), new Rule(60, new FunApp("DefPlDet",[]),[],[[new Terminal("de"), new Terminal("la")]]), new Rule(59, new FunApp("DefPlDet",[]),[],[[new Terminal("Ã"), new Terminal("l'")]]), new Rule(59, new FunApp("DefPlDet",[]),[],[[new Terminal("Ã"), new Terminal("la")]]), new Rule(58, new FunApp("DefPlDet",[]),[],[[new Terminal("l'")]]), new Rule(58, new FunApp("DefPlDet",[]),[],[[new Terminal("la")]]), new Rule(57, new FunApp("DefPlDet",[]),[],[[new Terminal("les")]]), new Rule(56, new FunApp("DefPlDet",[]),[],[[new Terminal("les")]]), new Rule(55, new FunApp("DefPlDet",[]),[],[[new Terminal("des")]]), new Rule(54, new FunApp("DefPlDet",[]),[],[[new Terminal("aux")]]), new Rule(53, new FunApp("DefPlDet",[]),[],[[new Terminal("les")]]), new Rule(52, new FunApp("DefPlDet",[]),[],[[new Terminal("les")]]), new Rule(51, new FunApp("DefPlDet",[]),[],[[new Terminal("les")]]), new Rule(50, new FunApp("DefPlDet",[]),[],[[new Terminal("des")]]), new Rule(49, new FunApp("DefPlDet",[]),[],[[new Terminal("aux")]]), new Rule(48, new FunApp("DefPlDet",[]),[],[[new Terminal("les")]]), new Rule(17, new FunApp("Danish",[]),[],[[new Terminal("danois")]]), new Rule(16, new FunApp("Danish",[]),[],[[new Terminal("danois")]]), new Rule(20, new FunApp("Cut",[]),[],[[new Terminal("couper")]]), new Rule(47, new FunApp("Cut",[]),[],[[new Terminal("couper")]]), new Rule(46, new FunApp("Cut",[]),[],[[new Terminal("coupe")]]), new Rule(45, new FunApp("Cut",[]),[],[[new Terminal("coupes")]]), new Rule(44, new FunApp("Cut",[]),[],[[new Terminal("coupe")]]), new Rule(43, new FunApp("Cut",[]),[],[[new Terminal("coupons")]]), new Rule(42, new FunApp("Cut",[]),[],[[new Terminal("coupez")]]), new Rule(41, new FunApp("Cut",[]),[],[[new Terminal("coupent")]]), new Rule(40, new FunApp("Cut",[]),[],[[new Terminal("coupe")]]), new Rule(39, new FunApp("Cut",[]),[],[[new Terminal("coupes")]]), new Rule(38, new FunApp("Cut",[]),[],[[new Terminal("coupe")]]), new Rule(37, new FunApp("Cut",[]),[],[[new Terminal("coupions")]]), new Rule(36, new FunApp("Cut",[]),[],[[new Terminal("coupiez")]]), new Rule(35, new FunApp("Cut",[]),[],[[new Terminal("coupent")]]), new Rule(34, new FunApp("Cut",[]),[],[[new Terminal("coupe")]]), new Rule(33, new FunApp("Cut",[]),[],[[new Terminal("coupons")]]), new Rule(32, new FunApp("Cut",[]),[],[[new Terminal("coupez")]]), new Rule(31, new FunApp("Cut",[]),[],[[new Terminal("coupé")]]), new Rule(30, new FunApp("Cut",[]),[],[[new Terminal("coupés")]]), new Rule(29, new FunApp("Cut",[]),[],[[new Terminal("coupée")]]), new Rule(28, new FunApp("Cut",[]),[],[[new Terminal("coupées")]]), new Rule(27, new FunApp("Cut",[]),[],[[new Terminal("coupant")]]), new Rule(20, new FunApp("Copy",[]),[],[[new Terminal("copier")]]), new Rule(47, new FunApp("Copy",[]),[],[[new Terminal("copier")]]), new Rule(46, new FunApp("Copy",[]),[],[[new Terminal("copie")]]), new Rule(45, new FunApp("Copy",[]),[],[[new Terminal("copies")]]), new Rule(44, new FunApp("Copy",[]),[],[[new Terminal("copie")]]), new Rule(43, new FunApp("Copy",[]),[],[[new Terminal("copions")]]), new Rule(42, new FunApp("Copy",[]),[],[[new Terminal("copiez")]]), new Rule(41, new FunApp("Copy",[]),[],[[new Terminal("copient")]]), new Rule(40, new FunApp("Copy",[]),[],[[new Terminal("copie")]]), new Rule(39, new FunApp("Copy",[]),[],[[new Terminal("copies")]]), new Rule(38, new FunApp("Copy",[]),[],[[new Terminal("copie")]]), new Rule(37, new FunApp("Copy",[]),[],[[new Terminal("copiions")]]), new Rule(36, new FunApp("Copy",[]),[],[[new Terminal("copiiez")]]), new Rule(35, new FunApp("Copy",[]),[],[[new Terminal("copient")]]), new Rule(34, new FunApp("Copy",[]),[],[[new Terminal("copie")]]), new Rule(33, new FunApp("Copy",[]),[],[[new Terminal("copions")]]), new Rule(32, new FunApp("Copy",[]),[],[[new Terminal("copiez")]]), new Rule(31, new FunApp("Copy",[]),[],[[new Terminal("copié")]]), new Rule(30, new FunApp("Copy",[]),[],[[new Terminal("copiés")]]), new Rule(29, new FunApp("Copy",[]),[],[[new Terminal("copiée")]]), new Rule(28, new FunApp("Copy",[]),[],[[new Terminal("copiées")]]), new Rule(27, new FunApp("Copy",[]),[],[[new Terminal("copiant")]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[22, 24, 13, 23],[[new Terminal("s'"), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(3, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[22, 24, 13, 23],[[new Terminal("se"), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(3, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[21, 24, 13, 23],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(3, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[20, 24, 13, 23],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(3, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[22, 19, 15, 17],[[new Terminal("s'"), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(3, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[22, 19, 15, 17],[[new Terminal("se"), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(3, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[21, 19, 15, 17],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(3, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[20, 19, 15, 17],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(3, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[22, 24, 26, 23],[[new Terminal("s'"), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[22, 24, 26, 23],[[new Terminal("se"), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[21, 24, 26, 23],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[20, 24, 26, 23],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[22, 19, 25, 17],[[new Terminal("s'"), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[22, 19, 25, 17],[[new Terminal("se"), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[21, 19, 25, 17],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[20, 19, 25, 17],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(18, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[22, 24, 23],[[new Terminal("s'"), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[22, 24, 23],[[new Terminal("se"), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[21, 24, 23],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[20, 24, 23],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[22, 19, 17],[[new Terminal("s'"), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[22, 19, 17],[[new Terminal("se"), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[21, 19, 17],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[20, 19, 17],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(17, new FunApp("Bulgarian",[]),[],[[new Terminal("bulgarien")]]), new Rule(16, new FunApp("Bulgarian",[]),[],[[new Terminal("bulgariens")]]), new Rule(15, new FunApp("Available",[]),[],[[new Terminal("disponible")]]), new Rule(14, new FunApp("Available",[]),[],[[new Terminal("disponibles")]]), new Rule(13, new FunApp("Available",[]),[],[[new Terminal("disponible")]]), new Rule(12, new FunApp("Available",[]),[],[[new Terminal("disponibles")]]), new Rule(11, new FunApp("Available",[]),[],[[new Terminal("disponiblement")]]), new Rule(10, new FunApp("Available",[]),[],[[new Terminal("plus"), new Terminal("disponible")]]), new Rule(9, new FunApp("Available",[]),[],[[new Terminal("plus"), new Terminal("disponibles")]]), new Rule(8, new FunApp("Available",[]),[],[[new Terminal("plus"), new Terminal("disponible")]]), new Rule(7, new FunApp("Available",[]),[],[[new Terminal("plus"), new Terminal("disponibles")]]), new Rule(6, new FunApp("Available",[]),[],[[new Terminal("plus"), new Terminal("disponiblement")]]), new Rule(5, new FunApp("Available",[]),[],[[new Terminal("plus"), new Terminal("disponible")]]), new Rule(4, new FunApp("Available",[]),[],[[new Terminal("plus"), new Terminal("disponibles")]]), new Rule(3, new FunApp("Available",[]),[],[[new Terminal("plus"), new Terminal("disponible")]]), new Rule(2, new FunApp("Available",[]),[],[[new Terminal("plus"), new Terminal("disponibles")]]), new Rule(1, new FunApp("Available",[]),[],[[new Terminal("plus"), new Terminal("disponiblement")]])],{Adjective:[25, 15, 10, 5, 86, 14, 9, 4, 26, 13, 8, 3, 88, 12, 7, 2, 11, 6, 1], Determiner:[85, 65, 75, 57, 80, 61, 70, 52, 84, 19, 74, 56, 79, 24, 69, 51, 83, 64, 73, 55, 78, 60, 68, 50, 82, 63, 72, 54, 77, 59, 67, 49, 81, 62, 71, 53, 76, 58, 66, 48], Float:[-3], Int:[-2], Noun:[89, 17, 23, 16, 87], Sentence:[18], String:[-1], Verb:[20, 21, 22, 47, 46, 45, 44, 43, 42, 41, 40, 39, 38, 37, 36, 35, 34, 33, 32, 31, 30, 29, 28, 27], _Var:[-4]})), EditorSpa: new GFConcrete({coding: "utf8"},{Available: function(cs){return new Arr(new Arr(new Suffix("disponible", Editor.concretes["EditorSpa"].rule("_0", cs)), Editor.concretes["EditorSpa"].rule("_5", cs), Editor.concretes["EditorSpa"].rule("_5", cs)), new Int(1));}, Bulgarian: function(cs){return new Arr(new Suffix("Búlgaro", Editor.concretes["EditorSpa"].rule("_8", cs)), new Int(0));}, Command: function(cs){return new Arr(new Seq(Editor.concretes["EditorSpa"].rule("_12", cs), Editor.concretes["EditorSpa"].rule("_38", cs), Editor.concretes["EditorSpa"].rule("_40", cs), Editor.concretes["EditorSpa"].rule("_42", cs), Editor.concretes["EditorSpa"].rule("_55", cs)));}, CommandAdj: function(cs){return new Arr(new Seq(Editor.concretes["EditorSpa"].rule("_12", cs), Editor.concretes["EditorSpa"].rule("_14", cs).sel(Editor.concretes["EditorSpa"].rule("_24", cs).sel(Editor.concretes["EditorSpa"].rule("_63", cs))), Editor.concretes["EditorSpa"].rule("_40", cs), Editor.concretes["EditorSpa"].rule("_41", cs).sel(Editor.concretes["EditorSpa"].rule("_63", cs)),(new Arr(new Arr(Editor.concretes["EditorSpa"].rule("_13", cs), Editor.concretes["EditorSpa"].rule("_78", cs)), new Arr(Editor.concretes["EditorSpa"].rule("_78", cs), Editor.concretes["EditorSpa"].rule("_78", cs)))).sel(Editor.concretes["EditorSpa"].rule("_19", cs)).sel(Editor.concretes["EditorSpa"].rule("_21", cs))));}, Copy: function(cs){return new Arr(new Suffix("Cop", new Arr(new Str("iar"), new Str("iar"), new Str("ío"), new Str("ías"), new Str("ía"), new Str("iamos"), new Str("iáis"), new Str("ían"), new Str("íe"), new Str("íes"), new Str("íe"), new Str("iemos"), new Str("iéis"), new Str("íen"), new Str("ía"), new Str("iemos"), new Str("iad"), new Str("iado"), new Str("iados"), new Str("iada"), new Str("iadas"), new Str("iando"))), new Int(0));}, Cut: function(cs){return new Arr(new Suffix("Cort", Editor.concretes["EditorSpa"].rule("_89", cs)), new Int(0));}, Danish: function(cs){return new Arr(new Suffix("Danés", Editor.concretes["EditorSpa"].rule("_92", cs)), new Int(0));}, DefPlDet: function(cs){return Editor.concretes["EditorSpa"].rule("_109", cs);}, DefSgDet: function(cs){return Editor.concretes["EditorSpa"].rule("_109", cs);}, Delete: function(cs){return new Arr(new Suffix("Borr", Editor.concretes["EditorSpa"].rule("_89", cs)), new Int(0));}, English: function(cs){return new Arr(new Suffix("Inglés", Editor.concretes["EditorSpa"].rule("_92", cs)), new Int(0));}, Enter: function(cs){return new Arr(new Suffix("introdu", new Arr(new Str("cir"), new Str("cir"), new Str("zco"), new Str("ces"), new Str("ce"), new Str("cimos"), new Str("cís"), new Str("cen"), new Str("zca"), new Str("zcas"), new Str("zca"), new Str("zcamos"), new Str("zcáis"), new Str("zcan"), new Str("ce"), new Str("zcamos"), new Str("cid"), new Str("cido"), new Str("cidos"), new Str("cida"), new Str("cidas"), new Str("ciendo"))), new Int(0));}, ErrorMessage: function(cs){return new Arr(new Seq(new Str("no"),(new Arr(Editor.concretes["EditorSpa"].rule("_119", cs), Editor.concretes["EditorSpa"].rule("_119", cs))).sel(Editor.concretes["EditorSpa"].rule("_121", cs).sel(new Int(0))).sel(Editor.concretes["EditorSpa"].rule("_121", cs).sel(new Int(1))).sel(Editor.concretes["EditorSpa"].rule("_121", cs).sel(new Int(2))),(new Arr(Editor.concretes["EditorSpa"].rule("_128", cs), Editor.concretes["EditorSpa"].rule("_128", cs))).sel(Editor.concretes["EditorSpa"].rule("_130", cs).sel(new Int(0))).sel(Editor.concretes["EditorSpa"].rule("_130", cs).sel(new Int(1))),(new Arr(new Str("un"), new Str("una"))).sel(Editor.concretes["EditorSpa"].rule("_136", cs)),(new Arr(new Seq(Editor.concretes["EditorSpa"].rule("_139", cs), Editor.concretes["EditorSpa"].rule("_140", cs)), new Seq(Editor.concretes["EditorSpa"].rule("_140", cs), Editor.concretes["EditorSpa"].rule("_139", cs)))).sel(Editor.concretes["EditorSpa"].rule("_29", cs))));}, Finnish: function(cs){return new Arr(new Suffix("Finlandés", Editor.concretes["EditorSpa"].rule("_92", cs)), new Int(0));}, Float_N: function(cs){return new Arr(new Arr(new Seq(new Str("número"), new Str("real")), new Seq(new Str("números"), new Str("real"))), new Int(0));}, French: function(cs){return new Arr(new Suffix("Francés", Editor.concretes["EditorSpa"].rule("_92", cs)), new Int(0));}, German: function(cs){return new Arr(new Suffix("Alemán", Editor.concretes["EditorSpa"].rule("_92", cs)), new Int(0));}, IndefPlDet: function(cs){return Editor.concretes["EditorSpa"].rule("_176", cs);}, IndefSgDet: function(cs){return Editor.concretes["EditorSpa"].rule("_176", cs);}, Integer_N: function(cs){return new Arr(new Arr(new Seq(new Str("número"), new Str("entero")), new Seq(new Str("números"), new Str("entero"))), new Int(0));}, Italian: function(cs){return new Arr(new Suffix("Italiano", Editor.concretes["EditorSpa"].rule("_8", cs)), new Int(0));}, Label: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_12", cs));}, Language: function(cs){return new Arr(new Suffix("lenguaje", Editor.concretes["EditorSpa"].rule("_8", cs)), new Int(0));}, Next: function(cs){return new Arr(new Arr(new Suffix("siguiente", Editor.concretes["EditorSpa"].rule("_0", cs)), Editor.concretes["EditorSpa"].rule("_190", cs), Editor.concretes["EditorSpa"].rule("_190", cs)), new Int(1));}, Node: function(cs){return new Arr(new Suffix("nodo", Editor.concretes["EditorSpa"].rule("_8", cs)), new Int(0));}, Norwegian: function(cs){return new Arr(new Suffix("Noruego", Editor.concretes["EditorSpa"].rule("_8", cs)), new Int(0));}, Page: function(cs){return new Arr(new Suffix("página", Editor.concretes["EditorSpa"].rule("_8", cs)), new Int(1));}, Parse: function(cs){return new Arr(new Arr(new Str("Analizar"), new Str("Analizar"), new Str("Analizo"), new Str("Analizas"), new Str("Analiza"), new Str("Analizamos"), new Str("Analizáis"), new Str("Analizan"), new Str("Analice"), new Str("Analices"), new Str("Analice"), new Str("Analicemos"), new Str("Analicéis"), new Str("Analicen"), new Str("Analiza"), new Str("Analicemos"), new Str("Analizad"), new Str("sintácticamente"), new Str("sintácticamentos"), new Str("sintácticamenta"), new Str("sintácticamentas"), new Str("Analizando")), new Int(0));}, Paste: function(cs){return new Arr(new Suffix("Peg", new Arr(new Str("ar"), new Str("ar"), new Str("o"), new Str("as"), new Str("a"), new Str("amos"), new Str("áis"), new Str("an"), new Str("ue"), new Str("ues"), new Str("ue"), new Str("uemos"), new Str("uéis"), new Str("uen"), new Str("a"), new Str("uemos"), new Str("ad"), new Str("ado"), new Str("ados"), new Str("ada"), new Str("adas"), new Str("ando"))), new Int(0));}, Previous: function(cs){return new Arr(new Arr(new Suffix("anterior", new Arr(new Str(""), new Str("es"), new Str(""), new Str("es"), new Str("mente"))), Editor.concretes["EditorSpa"].rule("_209", cs), Editor.concretes["EditorSpa"].rule("_209", cs)), new Int(1));}, RandomlyCommand: function(cs){return new Arr(new Seq(Editor.concretes["EditorSpa"].rule("_12", cs), Editor.concretes["EditorSpa"].rule("_38", cs), Editor.concretes["EditorSpa"].rule("_40", cs), Editor.concretes["EditorSpa"].rule("_42", cs), Editor.concretes["EditorSpa"].rule("_55", cs), new Str("aleatoriamente")));}, Redo: function(cs){return new Arr(new Suffix("reh", Editor.concretes["EditorSpa"].rule("_214", cs)), new Int(0));}, Refine: function(cs){return new Arr(new Suffix("Refin", Editor.concretes["EditorSpa"].rule("_89", cs)), new Int(0));}, Refinement: function(cs){return new Arr(new Suffix("refinamiento", Editor.concretes["EditorSpa"].rule("_8", cs)), new Int(0));}, Replace: function(cs){return new Arr(new Suffix("Reempla", new Arr(new Str("zar"), new Str("zar"), new Str("zo"), new Str("zas"), new Str("za"), new Str("zamos"), new Str("záis"), new Str("zan"), new Str("ce"), new Str("ces"), new Str("ce"), new Str("cemos"), new Str("céis"), new Str("cen"), new Str("za"), new Str("cemos"), new Str("zad"), new Str("zado"), new Str("zados"), new Str("zada"), new Str("zadas"), new Str("zando"))), new Int(0));}, Russian: function(cs){return new Arr(new Suffix("Ruso", Editor.concretes["EditorSpa"].rule("_8", cs)), new Int(0));}, Select: function(cs){return new Arr(new Suffix("Seleccion", Editor.concretes["EditorSpa"].rule("_89", cs)), new Int(0));}, Show: function(cs){return new Arr(new Suffix("Mostr", Editor.concretes["EditorSpa"].rule("_89", cs)), new Int(0));}, SingleWordCommand: function(cs){return new Arr(new Seq(Editor.concretes["EditorSpa"].rule("_12", cs), Editor.concretes["EditorSpa"].rule("_14", cs).sel((new Arr(new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(1))).sel(Editor.concretes["EditorSpa"].rule("_31", cs))), Editor.concretes["EditorSpa"].rule("_41", cs).sel(Editor.concretes["EditorSpa"].rule("_31", cs))));}, Spanish: function(cs){return new Arr(new Suffix("Español", Editor.concretes["EditorSpa"].rule("_92", cs)), new Int(0));}, String_N: function(cs){return new Arr(new Arr(new Seq(new Str("cadena"), new Str("de"), new Str("caracteres")), new Seq(new Str("cadenas"), new Str("de"), new Str("caracteres"))), new Int(1));}, Swedish: function(cs){return new Arr(new Suffix("Sueco", Editor.concretes["EditorSpa"].rule("_8", cs)), new Int(0));}, Tree: function(cs){return new Arr(new Suffix("árbol", Editor.concretes["EditorSpa"].rule("_92", cs)), new Int(0));}, Undo: function(cs){return new Arr(new Suffix("desh", Editor.concretes["EditorSpa"].rule("_214", cs)), new Int(0));}, Wrap: function(cs){return new Arr(new Suffix("env", new Arr(new Str("olver"), new Str("olver"), new Str("uelvo"), new Str("uelves"), new Str("uelve"), new Str("olvemos"), new Str("olvéis"), new Str("uelven"), new Str("uelva"), new Str("uelvas"), new Str("uelva"), new Str("olvamos"), new Str("olváis"), new Str("uelvan"), new Str("uelve"), new Str("olvamos"), new Str("olved"), new Str("olvido"), new Str("olvidos"), new Str("olvida"), new Str("olvidas"), new Str("olviendo"))), new Int(0));}, Wrapper: function(cs){return new Arr(new Suffix("envoltura", Editor.concretes["EditorSpa"].rule("_8", cs)), new Int(1));}, _0: function(cs){return new Arr(new Str(""), new Str("s"), new Str(""), new Str("s"), new Str("mente"));}, _100: function(cs){return new Seq(new Str("de"), new Str("los"));}, _101: function(cs){return new Seq(new Str("a"), new Str("los"));}, _102: function(cs){return new Arr(new Str("los"), new Str("los"), Editor.concretes["EditorSpa"].rule("_100", cs), Editor.concretes["EditorSpa"].rule("_101", cs));}, _103: function(cs){return new Seq(new Str("de"), new Str("las"));}, _104: function(cs){return new Seq(new Str("a"), new Str("las"));}, _105: function(cs){return new Arr(new Str("las"), new Str("las"), Editor.concretes["EditorSpa"].rule("_103", cs), Editor.concretes["EditorSpa"].rule("_104", cs));}, _106: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_102", cs), Editor.concretes["EditorSpa"].rule("_105", cs));}, _107: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_99", cs), Editor.concretes["EditorSpa"].rule("_106", cs));}, _108: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_107", cs), Editor.concretes["EditorSpa"].rule("_107", cs));}, _109: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_108", cs));}, _11: function(cs){return cs[0].sel(new Int(0));}, _117: function(cs){return new Arr(new Str("he"), new Str("has"), new Str("hay"));}, _118: function(cs){return new Arr(new Str("hemos"), new Str("habéis"), new Str("han"));}, _119: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_117", cs), Editor.concretes["EditorSpa"].rule("_118", cs));}, _12: function(cs){return Editor.concretes["EditorSpa"].rule("_11", cs).sel(new Int(0));}, _121: function(cs){return new Arr(new Int(0), new Int(0), new Int(2));}, _128: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_13", cs), Editor.concretes["EditorSpa"].rule("_13", cs));}, _13: function(cs){return new Seq();}, _130: function(cs){return new Arr(new Int(0), new Int(0));}, _136: function(cs){return cs[1].sel(new Int(1));}, _138: function(cs){return Editor.concretes["EditorSpa"].rule("_69", cs).sel(Editor.concretes["EditorSpa"].rule("_136", cs));}, _139: function(cs){return Editor.concretes["EditorSpa"].rule("_12", cs).sel(Editor.concretes["EditorSpa"].rule("_138", cs));}, _14: function(cs){return new Arr(new Str("&+"), Editor.concretes["EditorSpa"].rule("_13", cs));}, _140: function(cs){return Editor.concretes["EditorSpa"].rule("_43", cs).sel(new Int(0));}, _15: function(cs){return new Arr(new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(1), new Int(1));}, _157: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_13", cs), Editor.concretes["EditorSpa"].rule("_13", cs), Editor.concretes["EditorSpa"].rule("_13", cs), Editor.concretes["EditorSpa"].rule("_13", cs));}, _158: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_157", cs), Editor.concretes["EditorSpa"].rule("_157", cs));}, _159: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_158", cs), Editor.concretes["EditorSpa"].rule("_158", cs));}, _16: function(cs){return new Arr(new Int(13), new Int(13));}, _160: function(cs){return new Seq(new Str("de"), new Str("un"));}, _161: function(cs){return new Seq(new Str("a"), new Str("un"));}, _162: function(cs){return new Arr(new Str("un"), new Str("un"), Editor.concretes["EditorSpa"].rule("_160", cs), Editor.concretes["EditorSpa"].rule("_161", cs));}, _163: function(cs){return new Seq(new Str("de"), new Str("una"));}, _164: function(cs){return new Seq(new Str("a"), new Str("una"));}, _165: function(cs){return new Arr(new Str("una"), new Str("una"), Editor.concretes["EditorSpa"].rule("_163", cs), Editor.concretes["EditorSpa"].rule("_164", cs));}, _166: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_162", cs), Editor.concretes["EditorSpa"].rule("_165", cs));}, _167: function(cs){return new Seq(new Str("de"), new Str("unos"));}, _168: function(cs){return new Seq(new Str("a"), new Str("unos"));}, _169: function(cs){return new Arr(new Str("unos"), new Str("unos"), Editor.concretes["EditorSpa"].rule("_167", cs), Editor.concretes["EditorSpa"].rule("_168", cs));}, _17: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_16", cs), Editor.concretes["EditorSpa"].rule("_16", cs));}, _170: function(cs){return new Seq(new Str("de"), new Str("unas"));}, _171: function(cs){return new Seq(new Str("a"), new Str("unas"));}, _172: function(cs){return new Arr(new Str("unas"), new Str("unas"), Editor.concretes["EditorSpa"].rule("_170", cs), Editor.concretes["EditorSpa"].rule("_171", cs));}, _173: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_169", cs), Editor.concretes["EditorSpa"].rule("_172", cs));}, _174: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_166", cs), Editor.concretes["EditorSpa"].rule("_173", cs));}, _175: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_159", cs), Editor.concretes["EditorSpa"].rule("_174", cs));}, _176: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_175", cs));}, _18: function(cs){return new Arr(new Int(1), new Int(0));}, _187: function(cs){return new Seq(new Str("más"), new Str("siguiente"));}, _188: function(cs){return new Seq(new Str("más"), new Str("siguientes"));}, _189: function(cs){return new Seq(new Str("más"), new Str("siguientemente"));}, _19: function(cs){return Editor.concretes["EditorSpa"].rule("_18", cs).sel(new Int(0));}, _190: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_187", cs), Editor.concretes["EditorSpa"].rule("_188", cs), Editor.concretes["EditorSpa"].rule("_187", cs), Editor.concretes["EditorSpa"].rule("_188", cs), Editor.concretes["EditorSpa"].rule("_189", cs));}, _2: function(cs){return new Seq(new Str("más"), new Str("disponible"));}, _20: function(cs){return Editor.concretes["EditorSpa"].rule("_17", cs).sel(Editor.concretes["EditorSpa"].rule("_19", cs));}, _206: function(cs){return new Seq(new Str("más"), new Str("anterior"));}, _207: function(cs){return new Seq(new Str("más"), new Str("anteriores"));}, _208: function(cs){return new Seq(new Str("más"), new Str("anteriormente"));}, _209: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_206", cs), Editor.concretes["EditorSpa"].rule("_207", cs), Editor.concretes["EditorSpa"].rule("_206", cs), Editor.concretes["EditorSpa"].rule("_207", cs), Editor.concretes["EditorSpa"].rule("_208", cs));}, _21: function(cs){return Editor.concretes["EditorSpa"].rule("_18", cs).sel(new Int(1));}, _214: function(cs){return new Arr(new Str("acer"), new Str("acer"), new Str("ago"), new Str("aces"), new Str("ace"), new Str("acemos"), new Str("acéis"), new Str("acen"), new Str("aga"), new Str("agas"), new Str("aga"), new Str("agamos"), new Str("agáis"), new Str("agan"), new Str("az"), new Str("agamos"), new Str("aced"), new Str("echo"), new Str("echos"), new Str("echa"), new Str("echas"), new Str("aciendo"));}, _22: function(cs){return Editor.concretes["EditorSpa"].rule("_20", cs).sel(Editor.concretes["EditorSpa"].rule("_21", cs));}, _23: function(cs){return Editor.concretes["EditorSpa"].rule("_15", cs).sel(Editor.concretes["EditorSpa"].rule("_22", cs));}, _24: function(cs){return new Arr(new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), new Int(0), Editor.concretes["EditorSpa"].rule("_23", cs));}, _25: function(cs){return new Arr(new Int(2), new Int(8));}, _253: function(cs){return new Arr(cs[0], cs[0], cs[0], cs[0], cs[0]);}, _256: function(cs){return new Arr(cs[0], cs[0], cs[0], cs[0]);}, _257: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_256", cs), Editor.concretes["EditorSpa"].rule("_256", cs));}, _258: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_257", cs), Editor.concretes["EditorSpa"].rule("_257", cs));}, _26: function(cs){return cs[2].sel(new Int(1));}, _27: function(cs){return Editor.concretes["EditorSpa"].rule("_25", cs).sel(Editor.concretes["EditorSpa"].rule("_26", cs));}, _28: function(cs){return new Arr(new Int(12), new Int(13));}, _29: function(cs){return cs[0].sel(new Int(1));}, _3: function(cs){return new Seq(new Str("más"), new Str("disponibles"));}, _30: function(cs){return Editor.concretes["EditorSpa"].rule("_18", cs).sel(Editor.concretes["EditorSpa"].rule("_29", cs));}, _31: function(cs){return Editor.concretes["EditorSpa"].rule("_28", cs).sel(Editor.concretes["EditorSpa"].rule("_30", cs));}, _32: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_27", cs), Editor.concretes["EditorSpa"].rule("_31", cs));}, _33: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_31", cs), Editor.concretes["EditorSpa"].rule("_31", cs));}, _34: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_32", cs), Editor.concretes["EditorSpa"].rule("_33", cs));}, _35: function(cs){return Editor.concretes["EditorSpa"].rule("_34", cs).sel(Editor.concretes["EditorSpa"].rule("_19", cs));}, _36: function(cs){return Editor.concretes["EditorSpa"].rule("_35", cs).sel(Editor.concretes["EditorSpa"].rule("_21", cs));}, _37: function(cs){return Editor.concretes["EditorSpa"].rule("_24", cs).sel(Editor.concretes["EditorSpa"].rule("_36", cs));}, _38: function(cs){return Editor.concretes["EditorSpa"].rule("_14", cs).sel(Editor.concretes["EditorSpa"].rule("_37", cs));}, _39: function(cs){return new Arr(new Str("me"), new Str("te"), new Str("le"), new Str("nos"), new Str("vos"), new Str("les"), new Str("me"), new Str("te"), new Str("le"), new Str("nos"), new Str("vos"), new Str("les"), Editor.concretes["EditorSpa"].rule("_13", cs), Editor.concretes["EditorSpa"].rule("_13", cs));}, _4: function(cs){return new Seq(new Str("más"), new Str("disponiblemente"));}, _40: function(cs){return Editor.concretes["EditorSpa"].rule("_39", cs).sel(Editor.concretes["EditorSpa"].rule("_22", cs));}, _41: function(cs){return new Arr(new Str("me"), new Str("te"), new Str("lo"), new Str("nos"), new Str("vos"), new Str("los"), new Str("me"), new Str("te"), new Str("la"), new Str("nos"), new Str("vos"), new Str("las"), new Str("se"), Editor.concretes["EditorSpa"].rule("_13", cs));}, _42: function(cs){return Editor.concretes["EditorSpa"].rule("_41", cs).sel(Editor.concretes["EditorSpa"].rule("_36", cs));}, _43: function(cs){return cs[1].sel(new Int(0));}, _44: function(cs){return Editor.concretes["EditorSpa"].rule("_43", cs).sel(new Int(1));}, _45: function(cs){return Editor.concretes["EditorSpa"].rule("_44", cs).sel(new Int(0));}, _46: function(cs){return Editor.concretes["EditorSpa"].rule("_45", cs).sel(Editor.concretes["EditorSpa"].rule("_26", cs));}, _47: function(cs){return Editor.concretes["EditorSpa"].rule("_46", cs).sel(new Int(1));}, _48: function(cs){return cs[2].sel(new Int(0));}, _49: function(cs){return Editor.concretes["EditorSpa"].rule("_48", cs).sel(new Int(0));}, _5: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_2", cs), Editor.concretes["EditorSpa"].rule("_3", cs), Editor.concretes["EditorSpa"].rule("_2", cs), Editor.concretes["EditorSpa"].rule("_3", cs), Editor.concretes["EditorSpa"].rule("_4", cs));}, _50: function(cs){return new Seq(Editor.concretes["EditorSpa"].rule("_47", cs), Editor.concretes["EditorSpa"].rule("_49", cs));}, _51: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_13", cs), Editor.concretes["EditorSpa"].rule("_50", cs));}, _52: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_50", cs), Editor.concretes["EditorSpa"].rule("_50", cs));}, _53: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_51", cs), Editor.concretes["EditorSpa"].rule("_52", cs));}, _54: function(cs){return Editor.concretes["EditorSpa"].rule("_53", cs).sel(Editor.concretes["EditorSpa"].rule("_19", cs));}, _55: function(cs){return Editor.concretes["EditorSpa"].rule("_54", cs).sel(Editor.concretes["EditorSpa"].rule("_21", cs));}, _58: function(cs){return cs[3].sel(new Int(1));}, _59: function(cs){return Editor.concretes["EditorSpa"].rule("_25", cs).sel(Editor.concretes["EditorSpa"].rule("_58", cs));}, _60: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_59", cs), Editor.concretes["EditorSpa"].rule("_31", cs));}, _61: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_60", cs), Editor.concretes["EditorSpa"].rule("_33", cs));}, _62: function(cs){return Editor.concretes["EditorSpa"].rule("_61", cs).sel(Editor.concretes["EditorSpa"].rule("_19", cs));}, _63: function(cs){return Editor.concretes["EditorSpa"].rule("_62", cs).sel(Editor.concretes["EditorSpa"].rule("_21", cs));}, _67: function(cs){return Editor.concretes["EditorSpa"].rule("_45", cs).sel(Editor.concretes["EditorSpa"].rule("_58", cs));}, _68: function(cs){return Editor.concretes["EditorSpa"].rule("_67", cs).sel(new Int(1));}, _69: function(cs){return new Arr(new Int(0), new Int(2));}, _70: function(cs){return Editor.concretes["EditorSpa"].rule("_69", cs).sel(Editor.concretes["EditorSpa"].rule("_58", cs));}, _71: function(cs){return Editor.concretes["EditorSpa"].rule("_49", cs).sel(Editor.concretes["EditorSpa"].rule("_70", cs));}, _72: function(cs){return cs[3].sel(new Int(0));}, _73: function(cs){return Editor.concretes["EditorSpa"].rule("_72", cs).sel(new Int(0));}, _74: function(cs){return new Seq(Editor.concretes["EditorSpa"].rule("_71", cs), Editor.concretes["EditorSpa"].rule("_73", cs));}, _75: function(cs){return new Seq(Editor.concretes["EditorSpa"].rule("_73", cs), Editor.concretes["EditorSpa"].rule("_71", cs));}, _76: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_74", cs), Editor.concretes["EditorSpa"].rule("_75", cs));}, _77: function(cs){return Editor.concretes["EditorSpa"].rule("_76", cs).sel(Editor.concretes["EditorSpa"].rule("_26", cs));}, _78: function(cs){return new Seq(Editor.concretes["EditorSpa"].rule("_68", cs), Editor.concretes["EditorSpa"].rule("_77", cs));}, _8: function(cs){return new Arr(new Str(""), new Str("s"));}, _89: function(cs){return new Arr(new Str("ar"), new Str("ar"), new Str("o"), new Str("as"), new Str("a"), new Str("amos"), new Str("áis"), new Str("an"), new Str("e"), new Str("es"), new Str("e"), new Str("emos"), new Str("éis"), new Str("en"), new Str("a"), new Str("emos"), new Str("ad"), new Str("ado"), new Str("ados"), new Str("ada"), new Str("adas"), new Str("ando"));}, _92: function(cs){return new Arr(new Str(""), new Str("es"));}, _95: function(cs){return new Arr(new Str("el"), new Str("el"), new Str("del"), new Str("al"));}, _96: function(cs){return new Seq(new Str("de"), new Str("la"));}, _97: function(cs){return new Seq(new Str("a"), new Str("la"));}, _98: function(cs){return new Arr(new Str("la"), new Str("la"), Editor.concretes["EditorSpa"].rule("_96", cs), Editor.concretes["EditorSpa"].rule("_97", cs));}, _99: function(cs){return new Arr(Editor.concretes["EditorSpa"].rule("_95", cs), Editor.concretes["EditorSpa"].rule("_98", cs));}, Adjective: function(cs){return new Arr(new Arr(Editor.concretes["EditorSpa"].rule("_253", cs), Editor.concretes["EditorSpa"].rule("_253", cs), Editor.concretes["EditorSpa"].rule("_253", cs)), new Int(0));}, Determiner: function(cs){return new Arr(new Arr(Editor.concretes["EditorSpa"].rule("_258", cs), Editor.concretes["EditorSpa"].rule("_258", cs)));}, Noun: function(cs){return new Arr(new Arr(cs[0], cs[0]), new Int(0));}, Sentence: function(cs){return new Arr(cs[0]);}, Verb: function(cs){return new Arr(new Arr(cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0]), new Int(0));}, "Int": function(cs){return new Arr(cs[0]);}, "Float": function(cs){return new Arr(cs[0]);}, "String": function(cs){return new Arr(cs[0]);}}, new Parser("Sentence",[new Rule(22, new FunApp("Wrapper",[]),[],[[new Terminal("envoltura")]]), new Rule(78, new FunApp("Wrapper",[]),[],[[new Terminal("envolturas")]]), new Rule(20, new FunApp("Wrap",[]),[],[[new Terminal("envolver")]]), new Rule(46, new FunApp("Wrap",[]),[],[[new Terminal("envolver")]]), new Rule(45, new FunApp("Wrap",[]),[],[[new Terminal("envuelvo")]]), new Rule(44, new FunApp("Wrap",[]),[],[[new Terminal("envuelves")]]), new Rule(43, new FunApp("Wrap",[]),[],[[new Terminal("envuelve")]]), new Rule(42, new FunApp("Wrap",[]),[],[[new Terminal("envolvemos")]]), new Rule(41, new FunApp("Wrap",[]),[],[[new Terminal("envolvéis")]]), new Rule(40, new FunApp("Wrap",[]),[],[[new Terminal("envuelven")]]), new Rule(39, new FunApp("Wrap",[]),[],[[new Terminal("envuelva")]]), new Rule(38, new FunApp("Wrap",[]),[],[[new Terminal("envuelvas")]]), new Rule(37, new FunApp("Wrap",[]),[],[[new Terminal("envuelva")]]), new Rule(36, new FunApp("Wrap",[]),[],[[new Terminal("envolvamos")]]), new Rule(35, new FunApp("Wrap",[]),[],[[new Terminal("envolváis")]]), new Rule(34, new FunApp("Wrap",[]),[],[[new Terminal("envuelvan")]]), new Rule(33, new FunApp("Wrap",[]),[],[[new Terminal("envuelve")]]), new Rule(32, new FunApp("Wrap",[]),[],[[new Terminal("envolvamos")]]), new Rule(31, new FunApp("Wrap",[]),[],[[new Terminal("envolved")]]), new Rule(30, new FunApp("Wrap",[]),[],[[new Terminal("envolvido")]]), new Rule(29, new FunApp("Wrap",[]),[],[[new Terminal("envolvidos")]]), new Rule(28, new FunApp("Wrap",[]),[],[[new Terminal("envolvida")]]), new Rule(27, new FunApp("Wrap",[]),[],[[new Terminal("envolvidas")]]), new Rule(26, new FunApp("Wrap",[]),[],[[new Terminal("envolviendo")]]), new Rule(20, new FunApp("Undo",[]),[],[[new Terminal("deshacer")]]), new Rule(46, new FunApp("Undo",[]),[],[[new Terminal("deshacer")]]), new Rule(45, new FunApp("Undo",[]),[],[[new Terminal("deshago")]]), new Rule(44, new FunApp("Undo",[]),[],[[new Terminal("deshaces")]]), new Rule(43, new FunApp("Undo",[]),[],[[new Terminal("deshace")]]), new Rule(42, new FunApp("Undo",[]),[],[[new Terminal("deshacemos")]]), new Rule(41, new FunApp("Undo",[]),[],[[new Terminal("deshacéis")]]), new Rule(40, new FunApp("Undo",[]),[],[[new Terminal("deshacen")]]), new Rule(39, new FunApp("Undo",[]),[],[[new Terminal("deshaga")]]), new Rule(38, new FunApp("Undo",[]),[],[[new Terminal("deshagas")]]), new Rule(37, new FunApp("Undo",[]),[],[[new Terminal("deshaga")]]), new Rule(36, new FunApp("Undo",[]),[],[[new Terminal("deshagamos")]]), new Rule(35, new FunApp("Undo",[]),[],[[new Terminal("deshagáis")]]), new Rule(34, new FunApp("Undo",[]),[],[[new Terminal("deshagan")]]), new Rule(33, new FunApp("Undo",[]),[],[[new Terminal("deshaz")]]), new Rule(32, new FunApp("Undo",[]),[],[[new Terminal("deshagamos")]]), new Rule(31, new FunApp("Undo",[]),[],[[new Terminal("deshaced")]]), new Rule(30, new FunApp("Undo",[]),[],[[new Terminal("deshecho")]]), new Rule(29, new FunApp("Undo",[]),[],[[new Terminal("deshechos")]]), new Rule(28, new FunApp("Undo",[]),[],[[new Terminal("deshecha")]]), new Rule(27, new FunApp("Undo",[]),[],[[new Terminal("deshechas")]]), new Rule(26, new FunApp("Undo",[]),[],[[new Terminal("deshaciendo")]]), new Rule(17, new FunApp("Tree",[]),[],[[new Terminal("árbol")]]), new Rule(16, new FunApp("Tree",[]),[],[[new Terminal("árboles")]]), new Rule(17, new FunApp("Swedish",[]),[],[[new Terminal("Sueco")]]), new Rule(16, new FunApp("Swedish",[]),[],[[new Terminal("Suecos")]]), new Rule(22, new FunApp("String_N",[]),[],[[new Terminal("cadena"), new Terminal("de"), new Terminal("caracteres")]]), new Rule(78, new FunApp("String_N",[]),[],[[new Terminal("cadenas"), new Terminal("de"), new Terminal("caracteres")]]), new Rule(17, new FunApp("Spanish",[]),[],[[new Terminal("Español")]]), new Rule(16, new FunApp("Spanish",[]),[],[[new Terminal("Españoles")]]), new Rule(18, new FunApp("SingleWordCommand",[new Arg(0)]),[21],[[new ArgProj(0, 0), new Terminal("&+"), new Terminal("se")]]), new Rule(18, new FunApp("SingleWordCommand",[new Arg(0)]),[20],[[new ArgProj(0, 0)]]), new Rule(20, new FunApp("Show",[]),[],[[new Terminal("Mostrar")]]), new Rule(46, new FunApp("Show",[]),[],[[new Terminal("Mostrar")]]), new Rule(45, new FunApp("Show",[]),[],[[new Terminal("Mostro")]]), new Rule(44, new FunApp("Show",[]),[],[[new Terminal("Mostras")]]), new Rule(43, new FunApp("Show",[]),[],[[new Terminal("Mostra")]]), new Rule(42, new FunApp("Show",[]),[],[[new Terminal("Mostramos")]]), new Rule(41, new FunApp("Show",[]),[],[[new Terminal("Mostráis")]]), new Rule(40, new FunApp("Show",[]),[],[[new Terminal("Mostran")]]), new Rule(39, new FunApp("Show",[]),[],[[new Terminal("Mostre")]]), new Rule(38, new FunApp("Show",[]),[],[[new Terminal("Mostres")]]), new Rule(37, new FunApp("Show",[]),[],[[new Terminal("Mostre")]]), new Rule(36, new FunApp("Show",[]),[],[[new Terminal("Mostremos")]]), new Rule(35, new FunApp("Show",[]),[],[[new Terminal("Mostréis")]]), new Rule(34, new FunApp("Show",[]),[],[[new Terminal("Mostren")]]), new Rule(33, new FunApp("Show",[]),[],[[new Terminal("Mostra")]]), new Rule(32, new FunApp("Show",[]),[],[[new Terminal("Mostremos")]]), new Rule(31, new FunApp("Show",[]),[],[[new Terminal("Mostrad")]]), new Rule(30, new FunApp("Show",[]),[],[[new Terminal("Mostrado")]]), new Rule(29, new FunApp("Show",[]),[],[[new Terminal("Mostrados")]]), new Rule(28, new FunApp("Show",[]),[],[[new Terminal("Mostrada")]]), new Rule(27, new FunApp("Show",[]),[],[[new Terminal("Mostradas")]]), new Rule(26, new FunApp("Show",[]),[],[[new Terminal("Mostrando")]]), new Rule(20, new FunApp("Select",[]),[],[[new Terminal("Seleccionar")]]), new Rule(46, new FunApp("Select",[]),[],[[new Terminal("Seleccionar")]]), new Rule(45, new FunApp("Select",[]),[],[[new Terminal("Selecciono")]]), new Rule(44, new FunApp("Select",[]),[],[[new Terminal("Seleccionas")]]), new Rule(43, new FunApp("Select",[]),[],[[new Terminal("Selecciona")]]), new Rule(42, new FunApp("Select",[]),[],[[new Terminal("Seleccionamos")]]), new Rule(41, new FunApp("Select",[]),[],[[new Terminal("Seleccionáis")]]), new Rule(40, new FunApp("Select",[]),[],[[new Terminal("Seleccionan")]]), new Rule(39, new FunApp("Select",[]),[],[[new Terminal("Seleccione")]]), new Rule(38, new FunApp("Select",[]),[],[[new Terminal("Selecciones")]]), new Rule(37, new FunApp("Select",[]),[],[[new Terminal("Seleccione")]]), new Rule(36, new FunApp("Select",[]),[],[[new Terminal("Seleccionemos")]]), new Rule(35, new FunApp("Select",[]),[],[[new Terminal("Seleccionéis")]]), new Rule(34, new FunApp("Select",[]),[],[[new Terminal("Seleccionen")]]), new Rule(33, new FunApp("Select",[]),[],[[new Terminal("Selecciona")]]), new Rule(32, new FunApp("Select",[]),[],[[new Terminal("Seleccionemos")]]), new Rule(31, new FunApp("Select",[]),[],[[new Terminal("Seleccionad")]]), new Rule(30, new FunApp("Select",[]),[],[[new Terminal("Seleccionado")]]), new Rule(29, new FunApp("Select",[]),[],[[new Terminal("Seleccionados")]]), new Rule(28, new FunApp("Select",[]),[],[[new Terminal("Seleccionada")]]), new Rule(27, new FunApp("Select",[]),[],[[new Terminal("Seleccionadas")]]), new Rule(26, new FunApp("Select",[]),[],[[new Terminal("Seleccionando")]]), new Rule(17, new FunApp("Russian",[]),[],[[new Terminal("Ruso")]]), new Rule(16, new FunApp("Russian",[]),[],[[new Terminal("Rusos")]]), new Rule(20, new FunApp("Replace",[]),[],[[new Terminal("Reemplazar")]]), new Rule(46, new FunApp("Replace",[]),[],[[new Terminal("Reemplazar")]]), new Rule(45, new FunApp("Replace",[]),[],[[new Terminal("Reemplazo")]]), new Rule(44, new FunApp("Replace",[]),[],[[new Terminal("Reemplazas")]]), new Rule(43, new FunApp("Replace",[]),[],[[new Terminal("Reemplaza")]]), new Rule(42, new FunApp("Replace",[]),[],[[new Terminal("Reemplazamos")]]), new Rule(41, new FunApp("Replace",[]),[],[[new Terminal("Reemplazáis")]]), new Rule(40, new FunApp("Replace",[]),[],[[new Terminal("Reemplazan")]]), new Rule(39, new FunApp("Replace",[]),[],[[new Terminal("Reemplace")]]), new Rule(38, new FunApp("Replace",[]),[],[[new Terminal("Reemplaces")]]), new Rule(37, new FunApp("Replace",[]),[],[[new Terminal("Reemplace")]]), new Rule(36, new FunApp("Replace",[]),[],[[new Terminal("Reemplacemos")]]), new Rule(35, new FunApp("Replace",[]),[],[[new Terminal("Reemplacéis")]]), new Rule(34, new FunApp("Replace",[]),[],[[new Terminal("Reemplacen")]]), new Rule(33, new FunApp("Replace",[]),[],[[new Terminal("Reemplaza")]]), new Rule(32, new FunApp("Replace",[]),[],[[new Terminal("Reemplacemos")]]), new Rule(31, new FunApp("Replace",[]),[],[[new Terminal("Reemplazad")]]), new Rule(30, new FunApp("Replace",[]),[],[[new Terminal("Reemplazado")]]), new Rule(29, new FunApp("Replace",[]),[],[[new Terminal("Reemplazados")]]), new Rule(28, new FunApp("Replace",[]),[],[[new Terminal("Reemplazada")]]), new Rule(27, new FunApp("Replace",[]),[],[[new Terminal("Reemplazadas")]]), new Rule(26, new FunApp("Replace",[]),[],[[new Terminal("Reemplazando")]]), new Rule(17, new FunApp("Refinement",[]),[],[[new Terminal("refinamiento")]]), new Rule(16, new FunApp("Refinement",[]),[],[[new Terminal("refinamientos")]]), new Rule(20, new FunApp("Refine",[]),[],[[new Terminal("Refinar")]]), new Rule(46, new FunApp("Refine",[]),[],[[new Terminal("Refinar")]]), new Rule(45, new FunApp("Refine",[]),[],[[new Terminal("Refino")]]), new Rule(44, new FunApp("Refine",[]),[],[[new Terminal("Refinas")]]), new Rule(43, new FunApp("Refine",[]),[],[[new Terminal("Refina")]]), new Rule(42, new FunApp("Refine",[]),[],[[new Terminal("Refinamos")]]), new Rule(41, new FunApp("Refine",[]),[],[[new Terminal("Refináis")]]), new Rule(40, new FunApp("Refine",[]),[],[[new Terminal("Refinan")]]), new Rule(39, new FunApp("Refine",[]),[],[[new Terminal("Refine")]]), new Rule(38, new FunApp("Refine",[]),[],[[new Terminal("Refines")]]), new Rule(37, new FunApp("Refine",[]),[],[[new Terminal("Refine")]]), new Rule(36, new FunApp("Refine",[]),[],[[new Terminal("Refinemos")]]), new Rule(35, new FunApp("Refine",[]),[],[[new Terminal("Refinéis")]]), new Rule(34, new FunApp("Refine",[]),[],[[new Terminal("Refinen")]]), new Rule(33, new FunApp("Refine",[]),[],[[new Terminal("Refina")]]), new Rule(32, new FunApp("Refine",[]),[],[[new Terminal("Refinemos")]]), new Rule(31, new FunApp("Refine",[]),[],[[new Terminal("Refinad")]]), new Rule(30, new FunApp("Refine",[]),[],[[new Terminal("Refinado")]]), new Rule(29, new FunApp("Refine",[]),[],[[new Terminal("Refinados")]]), new Rule(28, new FunApp("Refine",[]),[],[[new Terminal("Refinada")]]), new Rule(27, new FunApp("Refine",[]),[],[[new Terminal("Refinadas")]]), new Rule(26, new FunApp("Refine",[]),[],[[new Terminal("Refinando")]]), new Rule(20, new FunApp("Redo",[]),[],[[new Terminal("rehacer")]]), new Rule(46, new FunApp("Redo",[]),[],[[new Terminal("rehacer")]]), new Rule(45, new FunApp("Redo",[]),[],[[new Terminal("rehago")]]), new Rule(44, new FunApp("Redo",[]),[],[[new Terminal("rehaces")]]), new Rule(43, new FunApp("Redo",[]),[],[[new Terminal("rehace")]]), new Rule(42, new FunApp("Redo",[]),[],[[new Terminal("rehacemos")]]), new Rule(41, new FunApp("Redo",[]),[],[[new Terminal("rehacéis")]]), new Rule(40, new FunApp("Redo",[]),[],[[new Terminal("rehacen")]]), new Rule(39, new FunApp("Redo",[]),[],[[new Terminal("rehaga")]]), new Rule(38, new FunApp("Redo",[]),[],[[new Terminal("rehagas")]]), new Rule(37, new FunApp("Redo",[]),[],[[new Terminal("rehaga")]]), new Rule(36, new FunApp("Redo",[]),[],[[new Terminal("rehagamos")]]), new Rule(35, new FunApp("Redo",[]),[],[[new Terminal("rehagáis")]]), new Rule(34, new FunApp("Redo",[]),[],[[new Terminal("rehagan")]]), new Rule(33, new FunApp("Redo",[]),[],[[new Terminal("rehaz")]]), new Rule(32, new FunApp("Redo",[]),[],[[new Terminal("rehagamos")]]), new Rule(31, new FunApp("Redo",[]),[],[[new Terminal("rehaced")]]), new Rule(30, new FunApp("Redo",[]),[],[[new Terminal("rehecho")]]), new Rule(29, new FunApp("Redo",[]),[],[[new Terminal("rehechos")]]), new Rule(28, new FunApp("Redo",[]),[],[[new Terminal("rehecha")]]), new Rule(27, new FunApp("Redo",[]),[],[[new Terminal("rehechas")]]), new Rule(26, new FunApp("Redo",[]),[],[[new Terminal("rehaciendo")]]), new Rule(18, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[21, 23, 22],[[new ArgProj(0, 0), new Terminal("&+"), new Terminal("se"), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("aleatoriamente")]]), new Rule(18, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[20, 23, 22],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("aleatoriamente")]]), new Rule(18, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[21, 19, 17],[[new ArgProj(0, 0), new Terminal("&+"), new Terminal("se"), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("aleatoriamente")]]), new Rule(18, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[20, 19, 17],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("aleatoriamente")]]), new Rule(15, new FunApp("Previous",[]),[],[[new Terminal("anterior")]]), new Rule(14, new FunApp("Previous",[]),[],[[new Terminal("anteriores")]]), new Rule(13, new FunApp("Previous",[]),[],[[new Terminal("anterior")]]), new Rule(12, new FunApp("Previous",[]),[],[[new Terminal("anteriores")]]), new Rule(11, new FunApp("Previous",[]),[],[[new Terminal("anteriormente")]]), new Rule(10, new FunApp("Previous",[]),[],[[new Terminal("más"), new Terminal("anterior")]]), new Rule(9, new FunApp("Previous",[]),[],[[new Terminal("más"), new Terminal("anteriores")]]), new Rule(8, new FunApp("Previous",[]),[],[[new Terminal("más"), new Terminal("anterior")]]), new Rule(7, new FunApp("Previous",[]),[],[[new Terminal("más"), new Terminal("anteriores")]]), new Rule(6, new FunApp("Previous",[]),[],[[new Terminal("más"), new Terminal("anteriormente")]]), new Rule(5, new FunApp("Previous",[]),[],[[new Terminal("más"), new Terminal("anterior")]]), new Rule(4, new FunApp("Previous",[]),[],[[new Terminal("más"), new Terminal("anteriores")]]), new Rule(3, new FunApp("Previous",[]),[],[[new Terminal("más"), new Terminal("anterior")]]), new Rule(2, new FunApp("Previous",[]),[],[[new Terminal("más"), new Terminal("anteriores")]]), new Rule(1, new FunApp("Previous",[]),[],[[new Terminal("más"), new Terminal("anteriormente")]]), new Rule(20, new FunApp("Paste",[]),[],[[new Terminal("Pegar")]]), new Rule(46, new FunApp("Paste",[]),[],[[new Terminal("Pegar")]]), new Rule(45, new FunApp("Paste",[]),[],[[new Terminal("Pego")]]), new Rule(44, new FunApp("Paste",[]),[],[[new Terminal("Pegas")]]), new Rule(43, new FunApp("Paste",[]),[],[[new Terminal("Pega")]]), new Rule(42, new FunApp("Paste",[]),[],[[new Terminal("Pegamos")]]), new Rule(41, new FunApp("Paste",[]),[],[[new Terminal("Pegáis")]]), new Rule(40, new FunApp("Paste",[]),[],[[new Terminal("Pegan")]]), new Rule(39, new FunApp("Paste",[]),[],[[new Terminal("Pegue")]]), new Rule(38, new FunApp("Paste",[]),[],[[new Terminal("Pegues")]]), new Rule(37, new FunApp("Paste",[]),[],[[new Terminal("Pegue")]]), new Rule(36, new FunApp("Paste",[]),[],[[new Terminal("Peguemos")]]), new Rule(35, new FunApp("Paste",[]),[],[[new Terminal("Peguéis")]]), new Rule(34, new FunApp("Paste",[]),[],[[new Terminal("Peguen")]]), new Rule(33, new FunApp("Paste",[]),[],[[new Terminal("Pega")]]), new Rule(32, new FunApp("Paste",[]),[],[[new Terminal("Peguemos")]]), new Rule(31, new FunApp("Paste",[]),[],[[new Terminal("Pegad")]]), new Rule(30, new FunApp("Paste",[]),[],[[new Terminal("Pegado")]]), new Rule(29, new FunApp("Paste",[]),[],[[new Terminal("Pegados")]]), new Rule(28, new FunApp("Paste",[]),[],[[new Terminal("Pegada")]]), new Rule(27, new FunApp("Paste",[]),[],[[new Terminal("Pegadas")]]), new Rule(26, new FunApp("Paste",[]),[],[[new Terminal("Pegando")]]), new Rule(20, new FunApp("Parse",[]),[],[[new Terminal("Analizar")]]), new Rule(46, new FunApp("Parse",[]),[],[[new Terminal("Analizar")]]), new Rule(45, new FunApp("Parse",[]),[],[[new Terminal("Analizo")]]), new Rule(44, new FunApp("Parse",[]),[],[[new Terminal("Analizas")]]), new Rule(43, new FunApp("Parse",[]),[],[[new Terminal("Analiza")]]), new Rule(42, new FunApp("Parse",[]),[],[[new Terminal("Analizamos")]]), new Rule(41, new FunApp("Parse",[]),[],[[new Terminal("Analizáis")]]), new Rule(40, new FunApp("Parse",[]),[],[[new Terminal("Analizan")]]), new Rule(39, new FunApp("Parse",[]),[],[[new Terminal("Analice")]]), new Rule(38, new FunApp("Parse",[]),[],[[new Terminal("Analices")]]), new Rule(37, new FunApp("Parse",[]),[],[[new Terminal("Analice")]]), new Rule(36, new FunApp("Parse",[]),[],[[new Terminal("Analicemos")]]), new Rule(35, new FunApp("Parse",[]),[],[[new Terminal("Analicéis")]]), new Rule(34, new FunApp("Parse",[]),[],[[new Terminal("Analicen")]]), new Rule(33, new FunApp("Parse",[]),[],[[new Terminal("Analiza")]]), new Rule(32, new FunApp("Parse",[]),[],[[new Terminal("Analicemos")]]), new Rule(31, new FunApp("Parse",[]),[],[[new Terminal("Analizad")]]), new Rule(30, new FunApp("Parse",[]),[],[[new Terminal("sintácticamente")]]), new Rule(29, new FunApp("Parse",[]),[],[[new Terminal("sintácticamentos")]]), new Rule(28, new FunApp("Parse",[]),[],[[new Terminal("sintácticamenta")]]), new Rule(27, new FunApp("Parse",[]),[],[[new Terminal("sintácticamentas")]]), new Rule(26, new FunApp("Parse",[]),[],[[new Terminal("Analizando")]]), new Rule(22, new FunApp("Page",[]),[],[[new Terminal("página")]]), new Rule(78, new FunApp("Page",[]),[],[[new Terminal("páginas")]]), new Rule(17, new FunApp("Norwegian",[]),[],[[new Terminal("Noruego")]]), new Rule(16, new FunApp("Norwegian",[]),[],[[new Terminal("Noruegos")]]), new Rule(17, new FunApp("Node",[]),[],[[new Terminal("nodo")]]), new Rule(16, new FunApp("Node",[]),[],[[new Terminal("nodos")]]), new Rule(15, new FunApp("Next",[]),[],[[new Terminal("siguiente")]]), new Rule(14, new FunApp("Next",[]),[],[[new Terminal("siguientes")]]), new Rule(13, new FunApp("Next",[]),[],[[new Terminal("siguiente")]]), new Rule(12, new FunApp("Next",[]),[],[[new Terminal("siguientes")]]), new Rule(11, new FunApp("Next",[]),[],[[new Terminal("siguientemente")]]), new Rule(10, new FunApp("Next",[]),[],[[new Terminal("más"), new Terminal("siguiente")]]), new Rule(9, new FunApp("Next",[]),[],[[new Terminal("más"), new Terminal("siguientes")]]), new Rule(8, new FunApp("Next",[]),[],[[new Terminal("más"), new Terminal("siguiente")]]), new Rule(7, new FunApp("Next",[]),[],[[new Terminal("más"), new Terminal("siguientes")]]), new Rule(6, new FunApp("Next",[]),[],[[new Terminal("más"), new Terminal("siguientemente")]]), new Rule(5, new FunApp("Next",[]),[],[[new Terminal("más"), new Terminal("siguiente")]]), new Rule(4, new FunApp("Next",[]),[],[[new Terminal("más"), new Terminal("siguientes")]]), new Rule(3, new FunApp("Next",[]),[],[[new Terminal("más"), new Terminal("siguiente")]]), new Rule(2, new FunApp("Next",[]),[],[[new Terminal("más"), new Terminal("siguientes")]]), new Rule(1, new FunApp("Next",[]),[],[[new Terminal("más"), new Terminal("siguientemente")]]), new Rule(17, new FunApp("Language",[]),[],[[new Terminal("lenguaje")]]), new Rule(16, new FunApp("Language",[]),[],[[new Terminal("lenguajes")]]), new Rule(18, new FunApp("Label",[new Arg(0)]),[77],[[new ArgProj(0, 0)]]), new Rule(77, new Arg(0),[22],[[new ArgProj(0, 0)]]), new Rule(77, new Arg(0),[17],[[new ArgProj(0, 0)]]), new Rule(17, new FunApp("Italian",[]),[],[[new Terminal("Italiano")]]), new Rule(16, new FunApp("Italian",[]),[],[[new Terminal("Italianos")]]), new Rule(17, new FunApp("Integer_N",[]),[],[[new Terminal("número"), new Terminal("entero")]]), new Rule(16, new FunApp("Integer_N",[]),[],[[new Terminal("números"), new Terminal("entero")]]), new Rule(76, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(75, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(74, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(73, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(72, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(71, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(70, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(69, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(68, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(67, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(66, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(65, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(64, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(63, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(62, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(61, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(60, new FunApp("IndefSgDet",[]),[],[[new Terminal("un")]]), new Rule(19, new FunApp("IndefSgDet",[]),[],[[new Terminal("un")]]), new Rule(59, new FunApp("IndefSgDet",[]),[],[[new Terminal("de"), new Terminal("un")]]), new Rule(58, new FunApp("IndefSgDet",[]),[],[[new Terminal("a"), new Terminal("un")]]), new Rule(57, new FunApp("IndefSgDet",[]),[],[[new Terminal("una")]]), new Rule(23, new FunApp("IndefSgDet",[]),[],[[new Terminal("una")]]), new Rule(56, new FunApp("IndefSgDet",[]),[],[[new Terminal("de"), new Terminal("una")]]), new Rule(55, new FunApp("IndefSgDet",[]),[],[[new Terminal("a"), new Terminal("una")]]), new Rule(54, new FunApp("IndefSgDet",[]),[],[[new Terminal("unos")]]), new Rule(53, new FunApp("IndefSgDet",[]),[],[[new Terminal("unos")]]), new Rule(52, new FunApp("IndefSgDet",[]),[],[[new Terminal("de"), new Terminal("unos")]]), new Rule(51, new FunApp("IndefSgDet",[]),[],[[new Terminal("a"), new Terminal("unos")]]), new Rule(50, new FunApp("IndefSgDet",[]),[],[[new Terminal("unas")]]), new Rule(49, new FunApp("IndefSgDet",[]),[],[[new Terminal("unas")]]), new Rule(48, new FunApp("IndefSgDet",[]),[],[[new Terminal("de"), new Terminal("unas")]]), new Rule(47, new FunApp("IndefSgDet",[]),[],[[new Terminal("a"), new Terminal("unas")]]), new Rule(76, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(75, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(74, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(73, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(72, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(71, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(70, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(69, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(68, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(67, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(66, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(65, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(64, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(63, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(62, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(61, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(60, new FunApp("IndefPlDet",[]),[],[[new Terminal("un")]]), new Rule(19, new FunApp("IndefPlDet",[]),[],[[new Terminal("un")]]), new Rule(59, new FunApp("IndefPlDet",[]),[],[[new Terminal("de"), new Terminal("un")]]), new Rule(58, new FunApp("IndefPlDet",[]),[],[[new Terminal("a"), new Terminal("un")]]), new Rule(57, new FunApp("IndefPlDet",[]),[],[[new Terminal("una")]]), new Rule(23, new FunApp("IndefPlDet",[]),[],[[new Terminal("una")]]), new Rule(56, new FunApp("IndefPlDet",[]),[],[[new Terminal("de"), new Terminal("una")]]), new Rule(55, new FunApp("IndefPlDet",[]),[],[[new Terminal("a"), new Terminal("una")]]), new Rule(54, new FunApp("IndefPlDet",[]),[],[[new Terminal("unos")]]), new Rule(53, new FunApp("IndefPlDet",[]),[],[[new Terminal("unos")]]), new Rule(52, new FunApp("IndefPlDet",[]),[],[[new Terminal("de"), new Terminal("unos")]]), new Rule(51, new FunApp("IndefPlDet",[]),[],[[new Terminal("a"), new Terminal("unos")]]), new Rule(50, new FunApp("IndefPlDet",[]),[],[[new Terminal("unas")]]), new Rule(49, new FunApp("IndefPlDet",[]),[],[[new Terminal("unas")]]), new Rule(48, new FunApp("IndefPlDet",[]),[],[[new Terminal("de"), new Terminal("unas")]]), new Rule(47, new FunApp("IndefPlDet",[]),[],[[new Terminal("a"), new Terminal("unas")]]), new Rule(17, new FunApp("German",[]),[],[[new Terminal("Alemán")]]), new Rule(16, new FunApp("German",[]),[],[[new Terminal("Alemánes")]]), new Rule(17, new FunApp("French",[]),[],[[new Terminal("Francés")]]), new Rule(16, new FunApp("French",[]),[],[[new Terminal("Francéses")]]), new Rule(17, new FunApp("Float_N",[]),[],[[new Terminal("número"), new Terminal("real")]]), new Rule(16, new FunApp("Float_N",[]),[],[[new Terminal("números"), new Terminal("real")]]), new Rule(17, new FunApp("Finnish",[]),[],[[new Terminal("Finlandés")]]), new Rule(16, new FunApp("Finnish",[]),[],[[new Terminal("Finlandéses")]]), new Rule(18, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[13, 22],[[new Terminal("no"), new Terminal("hay"), new Terminal("una"), new ArgProj(1, 0), new ArgProj(0, 0)]]), new Rule(18, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[15, 17],[[new Terminal("no"), new Terminal("hay"), new Terminal("un"), new ArgProj(1, 0), new ArgProj(0, 0)]]), new Rule(18, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[25, 22],[[new Terminal("no"), new Terminal("hay"), new Terminal("una"), new ArgProj(0, 0), new ArgProj(1, 0)]]), new Rule(18, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[24, 17],[[new Terminal("no"), new Terminal("hay"), new Terminal("un"), new ArgProj(0, 0), new ArgProj(1, 0)]]), new Rule(20, new FunApp("Enter",[]),[],[[new Terminal("introducir")]]), new Rule(46, new FunApp("Enter",[]),[],[[new Terminal("introducir")]]), new Rule(45, new FunApp("Enter",[]),[],[[new Terminal("introduzco")]]), new Rule(44, new FunApp("Enter",[]),[],[[new Terminal("introduces")]]), new Rule(43, new FunApp("Enter",[]),[],[[new Terminal("introduce")]]), new Rule(42, new FunApp("Enter",[]),[],[[new Terminal("introducimos")]]), new Rule(41, new FunApp("Enter",[]),[],[[new Terminal("introducís")]]), new Rule(40, new FunApp("Enter",[]),[],[[new Terminal("introducen")]]), new Rule(39, new FunApp("Enter",[]),[],[[new Terminal("introduzca")]]), new Rule(38, new FunApp("Enter",[]),[],[[new Terminal("introduzcas")]]), new Rule(37, new FunApp("Enter",[]),[],[[new Terminal("introduzca")]]), new Rule(36, new FunApp("Enter",[]),[],[[new Terminal("introduzcamos")]]), new Rule(35, new FunApp("Enter",[]),[],[[new Terminal("introduzcáis")]]), new Rule(34, new FunApp("Enter",[]),[],[[new Terminal("introduzcan")]]), new Rule(33, new FunApp("Enter",[]),[],[[new Terminal("introduce")]]), new Rule(32, new FunApp("Enter",[]),[],[[new Terminal("introduzcamos")]]), new Rule(31, new FunApp("Enter",[]),[],[[new Terminal("introducid")]]), new Rule(30, new FunApp("Enter",[]),[],[[new Terminal("introducido")]]), new Rule(29, new FunApp("Enter",[]),[],[[new Terminal("introducidos")]]), new Rule(28, new FunApp("Enter",[]),[],[[new Terminal("introducida")]]), new Rule(27, new FunApp("Enter",[]),[],[[new Terminal("introducidas")]]), new Rule(26, new FunApp("Enter",[]),[],[[new Terminal("introduciendo")]]), new Rule(17, new FunApp("English",[]),[],[[new Terminal("Inglés")]]), new Rule(16, new FunApp("English",[]),[],[[new Terminal("Ingléses")]]), new Rule(20, new FunApp("Delete",[]),[],[[new Terminal("Borrar")]]), new Rule(46, new FunApp("Delete",[]),[],[[new Terminal("Borrar")]]), new Rule(45, new FunApp("Delete",[]),[],[[new Terminal("Borro")]]), new Rule(44, new FunApp("Delete",[]),[],[[new Terminal("Borras")]]), new Rule(43, new FunApp("Delete",[]),[],[[new Terminal("Borra")]]), new Rule(42, new FunApp("Delete",[]),[],[[new Terminal("Borramos")]]), new Rule(41, new FunApp("Delete",[]),[],[[new Terminal("Borráis")]]), new Rule(40, new FunApp("Delete",[]),[],[[new Terminal("Borran")]]), new Rule(39, new FunApp("Delete",[]),[],[[new Terminal("Borre")]]), new Rule(38, new FunApp("Delete",[]),[],[[new Terminal("Borres")]]), new Rule(37, new FunApp("Delete",[]),[],[[new Terminal("Borre")]]), new Rule(36, new FunApp("Delete",[]),[],[[new Terminal("Borremos")]]), new Rule(35, new FunApp("Delete",[]),[],[[new Terminal("Borréis")]]), new Rule(34, new FunApp("Delete",[]),[],[[new Terminal("Borren")]]), new Rule(33, new FunApp("Delete",[]),[],[[new Terminal("Borra")]]), new Rule(32, new FunApp("Delete",[]),[],[[new Terminal("Borremos")]]), new Rule(31, new FunApp("Delete",[]),[],[[new Terminal("Borrad")]]), new Rule(30, new FunApp("Delete",[]),[],[[new Terminal("Borrado")]]), new Rule(29, new FunApp("Delete",[]),[],[[new Terminal("Borrados")]]), new Rule(28, new FunApp("Delete",[]),[],[[new Terminal("Borrada")]]), new Rule(27, new FunApp("Delete",[]),[],[[new Terminal("Borradas")]]), new Rule(26, new FunApp("Delete",[]),[],[[new Terminal("Borrando")]]), new Rule(76, new FunApp("DefSgDet",[]),[],[[new Terminal("el")]]), new Rule(75, new FunApp("DefSgDet",[]),[],[[new Terminal("el")]]), new Rule(74, new FunApp("DefSgDet",[]),[],[[new Terminal("del")]]), new Rule(73, new FunApp("DefSgDet",[]),[],[[new Terminal("al")]]), new Rule(72, new FunApp("DefSgDet",[]),[],[[new Terminal("la")]]), new Rule(71, new FunApp("DefSgDet",[]),[],[[new Terminal("la")]]), new Rule(70, new FunApp("DefSgDet",[]),[],[[new Terminal("de"), new Terminal("la")]]), new Rule(69, new FunApp("DefSgDet",[]),[],[[new Terminal("a"), new Terminal("la")]]), new Rule(68, new FunApp("DefSgDet",[]),[],[[new Terminal("los")]]), new Rule(67, new FunApp("DefSgDet",[]),[],[[new Terminal("los")]]), new Rule(66, new FunApp("DefSgDet",[]),[],[[new Terminal("de"), new Terminal("los")]]), new Rule(65, new FunApp("DefSgDet",[]),[],[[new Terminal("a"), new Terminal("los")]]), new Rule(64, new FunApp("DefSgDet",[]),[],[[new Terminal("las")]]), new Rule(63, new FunApp("DefSgDet",[]),[],[[new Terminal("las")]]), new Rule(62, new FunApp("DefSgDet",[]),[],[[new Terminal("de"), new Terminal("las")]]), new Rule(61, new FunApp("DefSgDet",[]),[],[[new Terminal("a"), new Terminal("las")]]), new Rule(60, new FunApp("DefSgDet",[]),[],[[new Terminal("el")]]), new Rule(19, new FunApp("DefSgDet",[]),[],[[new Terminal("el")]]), new Rule(59, new FunApp("DefSgDet",[]),[],[[new Terminal("del")]]), new Rule(58, new FunApp("DefSgDet",[]),[],[[new Terminal("al")]]), new Rule(57, new FunApp("DefSgDet",[]),[],[[new Terminal("la")]]), new Rule(23, new FunApp("DefSgDet",[]),[],[[new Terminal("la")]]), new Rule(56, new FunApp("DefSgDet",[]),[],[[new Terminal("de"), new Terminal("la")]]), new Rule(55, new FunApp("DefSgDet",[]),[],[[new Terminal("a"), new Terminal("la")]]), new Rule(54, new FunApp("DefSgDet",[]),[],[[new Terminal("los")]]), new Rule(53, new FunApp("DefSgDet",[]),[],[[new Terminal("los")]]), new Rule(52, new FunApp("DefSgDet",[]),[],[[new Terminal("de"), new Terminal("los")]]), new Rule(51, new FunApp("DefSgDet",[]),[],[[new Terminal("a"), new Terminal("los")]]), new Rule(50, new FunApp("DefSgDet",[]),[],[[new Terminal("las")]]), new Rule(49, new FunApp("DefSgDet",[]),[],[[new Terminal("las")]]), new Rule(48, new FunApp("DefSgDet",[]),[],[[new Terminal("de"), new Terminal("las")]]), new Rule(47, new FunApp("DefSgDet",[]),[],[[new Terminal("a"), new Terminal("las")]]), new Rule(76, new FunApp("DefPlDet",[]),[],[[new Terminal("el")]]), new Rule(75, new FunApp("DefPlDet",[]),[],[[new Terminal("el")]]), new Rule(74, new FunApp("DefPlDet",[]),[],[[new Terminal("del")]]), new Rule(73, new FunApp("DefPlDet",[]),[],[[new Terminal("al")]]), new Rule(72, new FunApp("DefPlDet",[]),[],[[new Terminal("la")]]), new Rule(71, new FunApp("DefPlDet",[]),[],[[new Terminal("la")]]), new Rule(70, new FunApp("DefPlDet",[]),[],[[new Terminal("de"), new Terminal("la")]]), new Rule(69, new FunApp("DefPlDet",[]),[],[[new Terminal("a"), new Terminal("la")]]), new Rule(68, new FunApp("DefPlDet",[]),[],[[new Terminal("los")]]), new Rule(67, new FunApp("DefPlDet",[]),[],[[new Terminal("los")]]), new Rule(66, new FunApp("DefPlDet",[]),[],[[new Terminal("de"), new Terminal("los")]]), new Rule(65, new FunApp("DefPlDet",[]),[],[[new Terminal("a"), new Terminal("los")]]), new Rule(64, new FunApp("DefPlDet",[]),[],[[new Terminal("las")]]), new Rule(63, new FunApp("DefPlDet",[]),[],[[new Terminal("las")]]), new Rule(62, new FunApp("DefPlDet",[]),[],[[new Terminal("de"), new Terminal("las")]]), new Rule(61, new FunApp("DefPlDet",[]),[],[[new Terminal("a"), new Terminal("las")]]), new Rule(60, new FunApp("DefPlDet",[]),[],[[new Terminal("el")]]), new Rule(19, new FunApp("DefPlDet",[]),[],[[new Terminal("el")]]), new Rule(59, new FunApp("DefPlDet",[]),[],[[new Terminal("del")]]), new Rule(58, new FunApp("DefPlDet",[]),[],[[new Terminal("al")]]), new Rule(57, new FunApp("DefPlDet",[]),[],[[new Terminal("la")]]), new Rule(23, new FunApp("DefPlDet",[]),[],[[new Terminal("la")]]), new Rule(56, new FunApp("DefPlDet",[]),[],[[new Terminal("de"), new Terminal("la")]]), new Rule(55, new FunApp("DefPlDet",[]),[],[[new Terminal("a"), new Terminal("la")]]), new Rule(54, new FunApp("DefPlDet",[]),[],[[new Terminal("los")]]), new Rule(53, new FunApp("DefPlDet",[]),[],[[new Terminal("los")]]), new Rule(52, new FunApp("DefPlDet",[]),[],[[new Terminal("de"), new Terminal("los")]]), new Rule(51, new FunApp("DefPlDet",[]),[],[[new Terminal("a"), new Terminal("los")]]), new Rule(50, new FunApp("DefPlDet",[]),[],[[new Terminal("las")]]), new Rule(49, new FunApp("DefPlDet",[]),[],[[new Terminal("las")]]), new Rule(48, new FunApp("DefPlDet",[]),[],[[new Terminal("de"), new Terminal("las")]]), new Rule(47, new FunApp("DefPlDet",[]),[],[[new Terminal("a"), new Terminal("las")]]), new Rule(17, new FunApp("Danish",[]),[],[[new Terminal("Danés")]]), new Rule(16, new FunApp("Danish",[]),[],[[new Terminal("Danéses")]]), new Rule(20, new FunApp("Cut",[]),[],[[new Terminal("Cortar")]]), new Rule(46, new FunApp("Cut",[]),[],[[new Terminal("Cortar")]]), new Rule(45, new FunApp("Cut",[]),[],[[new Terminal("Corto")]]), new Rule(44, new FunApp("Cut",[]),[],[[new Terminal("Cortas")]]), new Rule(43, new FunApp("Cut",[]),[],[[new Terminal("Corta")]]), new Rule(42, new FunApp("Cut",[]),[],[[new Terminal("Cortamos")]]), new Rule(41, new FunApp("Cut",[]),[],[[new Terminal("Cortáis")]]), new Rule(40, new FunApp("Cut",[]),[],[[new Terminal("Cortan")]]), new Rule(39, new FunApp("Cut",[]),[],[[new Terminal("Corte")]]), new Rule(38, new FunApp("Cut",[]),[],[[new Terminal("Cortes")]]), new Rule(37, new FunApp("Cut",[]),[],[[new Terminal("Corte")]]), new Rule(36, new FunApp("Cut",[]),[],[[new Terminal("Cortemos")]]), new Rule(35, new FunApp("Cut",[]),[],[[new Terminal("Cortéis")]]), new Rule(34, new FunApp("Cut",[]),[],[[new Terminal("Corten")]]), new Rule(33, new FunApp("Cut",[]),[],[[new Terminal("Corta")]]), new Rule(32, new FunApp("Cut",[]),[],[[new Terminal("Cortemos")]]), new Rule(31, new FunApp("Cut",[]),[],[[new Terminal("Cortad")]]), new Rule(30, new FunApp("Cut",[]),[],[[new Terminal("Cortado")]]), new Rule(29, new FunApp("Cut",[]),[],[[new Terminal("Cortados")]]), new Rule(28, new FunApp("Cut",[]),[],[[new Terminal("Cortada")]]), new Rule(27, new FunApp("Cut",[]),[],[[new Terminal("Cortadas")]]), new Rule(26, new FunApp("Cut",[]),[],[[new Terminal("Cortando")]]), new Rule(20, new FunApp("Copy",[]),[],[[new Terminal("Copiar")]]), new Rule(46, new FunApp("Copy",[]),[],[[new Terminal("Copiar")]]), new Rule(45, new FunApp("Copy",[]),[],[[new Terminal("Copío")]]), new Rule(44, new FunApp("Copy",[]),[],[[new Terminal("Copías")]]), new Rule(43, new FunApp("Copy",[]),[],[[new Terminal("Copía")]]), new Rule(42, new FunApp("Copy",[]),[],[[new Terminal("Copiamos")]]), new Rule(41, new FunApp("Copy",[]),[],[[new Terminal("Copiáis")]]), new Rule(40, new FunApp("Copy",[]),[],[[new Terminal("Copían")]]), new Rule(39, new FunApp("Copy",[]),[],[[new Terminal("Copíe")]]), new Rule(38, new FunApp("Copy",[]),[],[[new Terminal("Copíes")]]), new Rule(37, new FunApp("Copy",[]),[],[[new Terminal("Copíe")]]), new Rule(36, new FunApp("Copy",[]),[],[[new Terminal("Copiemos")]]), new Rule(35, new FunApp("Copy",[]),[],[[new Terminal("Copiéis")]]), new Rule(34, new FunApp("Copy",[]),[],[[new Terminal("Copíen")]]), new Rule(33, new FunApp("Copy",[]),[],[[new Terminal("Copía")]]), new Rule(32, new FunApp("Copy",[]),[],[[new Terminal("Copiemos")]]), new Rule(31, new FunApp("Copy",[]),[],[[new Terminal("Copiad")]]), new Rule(30, new FunApp("Copy",[]),[],[[new Terminal("Copiado")]]), new Rule(29, new FunApp("Copy",[]),[],[[new Terminal("Copiados")]]), new Rule(28, new FunApp("Copy",[]),[],[[new Terminal("Copiada")]]), new Rule(27, new FunApp("Copy",[]),[],[[new Terminal("Copiadas")]]), new Rule(26, new FunApp("Copy",[]),[],[[new Terminal("Copiando")]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[21, 23, 13, 22],[[new ArgProj(0, 0), new Terminal("&+"), new Terminal("se"), new ArgProj(1, 0), new ArgProj(3, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[20, 23, 13, 22],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(3, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[21, 19, 15, 17],[[new ArgProj(0, 0), new Terminal("&+"), new Terminal("se"), new ArgProj(1, 0), new ArgProj(3, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[20, 19, 15, 17],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(3, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[21, 23, 25, 22],[[new ArgProj(0, 0), new Terminal("&+"), new Terminal("se"), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[20, 23, 25, 22],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[21, 19, 24, 17],[[new ArgProj(0, 0), new Terminal("&+"), new Terminal("se"), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(18, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[20, 19, 24, 17],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(18, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[21, 23, 22],[[new ArgProj(0, 0), new Terminal("&+"), new Terminal("se"), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[20, 23, 22],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[21, 19, 17],[[new ArgProj(0, 0), new Terminal("&+"), new Terminal("se"), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(18, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[20, 19, 17],[[new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(17, new FunApp("Bulgarian",[]),[],[[new Terminal("Búlgaro")]]), new Rule(16, new FunApp("Bulgarian",[]),[],[[new Terminal("Búlgaros")]]), new Rule(15, new FunApp("Available",[]),[],[[new Terminal("disponible")]]), new Rule(14, new FunApp("Available",[]),[],[[new Terminal("disponibles")]]), new Rule(13, new FunApp("Available",[]),[],[[new Terminal("disponible")]]), new Rule(12, new FunApp("Available",[]),[],[[new Terminal("disponibles")]]), new Rule(11, new FunApp("Available",[]),[],[[new Terminal("disponiblemente")]]), new Rule(10, new FunApp("Available",[]),[],[[new Terminal("más"), new Terminal("disponible")]]), new Rule(9, new FunApp("Available",[]),[],[[new Terminal("más"), new Terminal("disponibles")]]), new Rule(8, new FunApp("Available",[]),[],[[new Terminal("más"), new Terminal("disponible")]]), new Rule(7, new FunApp("Available",[]),[],[[new Terminal("más"), new Terminal("disponibles")]]), new Rule(6, new FunApp("Available",[]),[],[[new Terminal("más"), new Terminal("disponiblemente")]]), new Rule(5, new FunApp("Available",[]),[],[[new Terminal("más"), new Terminal("disponible")]]), new Rule(4, new FunApp("Available",[]),[],[[new Terminal("más"), new Terminal("disponibles")]]), new Rule(3, new FunApp("Available",[]),[],[[new Terminal("más"), new Terminal("disponible")]]), new Rule(2, new FunApp("Available",[]),[],[[new Terminal("más"), new Terminal("disponibles")]]), new Rule(1, new FunApp("Available",[]),[],[[new Terminal("más"), new Terminal("disponiblemente")]])],{Adjective:[24, 15, 10, 5, 14, 9, 4, 25, 13, 8, 3, 12, 7, 2, 11, 6, 1], Determiner:[76, 60, 68, 54, 72, 57, 64, 50, 75, 19, 67, 53, 71, 23, 63, 49, 74, 59, 66, 52, 70, 56, 62, 48, 73, 58, 65, 51, 69, 55, 61, 47], Float:[-3], Int:[-2], Noun:[77, 17, 22, 16, 78], Sentence:[18], String:[-1], Verb:[20, 21, 46, 45, 44, 43, 42, 41, 40, 39, 38, 37, 36, 35, 34, 33, 32, 31, 30, 29, 28, 27, 26], _Var:[-4]})), EditorSwe: new GFConcrete({coding: "utf8"},{Available: function(cs){return new Arr(new Suffix("tillgänglig", Editor.concretes["EditorSwe"].rule("_0", cs)), new Int(1));}, Bulgarian: function(cs){return new Arr(new Arr(new Arr(new Suffix("Bulgariska", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Bulgariskan", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(new Suffix("Bulgariskor", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Bulgariskorna", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(0));}, Command: function(cs){return new Arr(new Seq(Editor.concretes["EditorSwe"].rule("_16", cs), Editor.concretes["EditorSwe"].rule("_17", cs), Editor.concretes["EditorSwe"].rule("_23", cs), Editor.concretes["EditorSwe"].rule("_47", cs), Editor.concretes["EditorSwe"].rule("_62", cs), Editor.concretes["EditorSwe"].rule("_64", cs)));}, CommandAdj: function(cs){return new Arr(new Seq(Editor.concretes["EditorSwe"].rule("_16", cs), Editor.concretes["EditorSwe"].rule("_17", cs), Editor.concretes["EditorSwe"].rule("_67", cs).sel(new Int(1)).sel(Editor.concretes["EditorSwe"].rule("_69", cs)),(new Arr(new Seq(Editor.concretes["EditorSwe"].rule("_75", cs).sel(Editor.concretes["EditorSwe"].rule("_80", cs).sel(Editor.concretes["EditorSwe"].rule("_86", cs).sel(new Int(0))).sel(Editor.concretes["EditorSwe"].rule("_86", cs).sel(new Int(1)))), Editor.concretes["EditorSwe"].rule("_95", cs)), new Seq(Editor.concretes["EditorSwe"].rule("_75", cs).sel(Editor.concretes["EditorSwe"].rule("_80", cs).sel(Editor.concretes["EditorSwe"].rule("_97", cs).sel(new Int(0))).sel(Editor.concretes["EditorSwe"].rule("_97", cs).sel(new Int(1)))), Editor.concretes["EditorSwe"].rule("_95", cs)), new Seq(Editor.concretes["EditorSwe"].rule("_75", cs).sel(Editor.concretes["EditorSwe"].rule("_80", cs).sel(Editor.concretes["EditorSwe"].rule("_105", cs)).sel(Editor.concretes["EditorSwe"].rule("_107", cs))), Editor.concretes["EditorSwe"].rule("_93", cs).sel(new Int(1)).sel(new Int(0))))).sel(Editor.concretes["EditorSwe"].rule("_38", cs).sel(Editor.concretes["EditorSwe"].rule("_114", cs).sel(new Int(0))).sel(Editor.concretes["EditorSwe"].rule("_114", cs).sel(new Int(1))).sel(Editor.concretes["EditorSwe"].rule("_114", cs).sel(new Int(2)))), Editor.concretes["EditorSwe"].rule("_50", cs).sel(Editor.concretes["EditorSwe"].rule("_105", cs)).sel(Editor.concretes["EditorSwe"].rule("_107", cs)), Editor.concretes["EditorSwe"].rule("_64", cs)));}, Copy: function(cs){return new Arr(new Suffix("Kopiera", Editor.concretes["EditorSwe"].rule("_126", cs)), Editor.concretes["EditorSwe"].rule("_48", cs), new Int(0));}, Cut: function(cs){return new Arr(new Suffix("Klipp", Editor.concretes["EditorSwe"].rule("_129", cs)), new Str("ut"), new Int(0));}, Danish: function(cs){return new Arr(new Arr(new Arr(new Suffix("Danska", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Danskan", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(new Suffix("Danskor", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Danskorna", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(0));}, DefPlDet: function(cs){return Editor.concretes["EditorSwe"].rule("_152", cs);}, DefSgDet: function(cs){return Editor.concretes["EditorSwe"].rule("_152", cs);}, Delete: function(cs){return new Arr(new Suffix("Radera", Editor.concretes["EditorSwe"].rule("_126", cs)), Editor.concretes["EditorSwe"].rule("_48", cs), new Int(0));}, English: function(cs){return new Arr(new Arr(new Arr(new Suffix("Engelska", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Engelskan", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(new Suffix("Engelskor", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Engelskorna", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(0));}, Enter: function(cs){return new Arr(new Suffix("Skriv", new Arr(new Str("er"), new Str("s"), new Str(""), new Str("s"), new Str("a"), new Str("as"), new Str("d"), new Str("ds"), new Str("t"), new Str("ts"), new Str("da"), new Str("das"), new Str("da"), new Str("das"), new Str("da"), new Str("das"))), Editor.concretes["EditorSwe"].rule("_48", cs), new Int(0));}, ErrorMessage: function(cs){return new Arr(new Seq(new Str("det"), new Str("finns"), new Str("inte"),(new Arr(new Str("en"), new Str("ett"))).sel(Editor.concretes["EditorSwe"].rule("_39", cs)),(new Arr(new Seq(Editor.concretes["EditorSwe"].rule("_173", cs).sel(Editor.concretes["EditorSwe"].rule("_177", cs).sel(Editor.concretes["EditorSwe"].rule("_183", cs).sel(new Int(0))).sel(Editor.concretes["EditorSwe"].rule("_183", cs).sel(new Int(1)))), Editor.concretes["EditorSwe"].rule("_189", cs)), new Seq(Editor.concretes["EditorSwe"].rule("_173", cs).sel(Editor.concretes["EditorSwe"].rule("_177", cs).sel(Editor.concretes["EditorSwe"].rule("_191", cs).sel(new Int(0))).sel(Editor.concretes["EditorSwe"].rule("_191", cs).sel(new Int(1)))), Editor.concretes["EditorSwe"].rule("_189", cs)), new Seq(Editor.concretes["EditorSwe"].rule("_173", cs).sel(Editor.concretes["EditorSwe"].rule("_177", cs).sel(Editor.concretes["EditorSwe"].rule("_198", cs).sel(new Int(0))).sel(Editor.concretes["EditorSwe"].rule("_198", cs).sel(new Int(1)))), Editor.concretes["EditorSwe"].rule("_20", cs).sel(new Int(0))))).sel(Editor.concretes["EditorSwe"].rule("_38", cs).sel(Editor.concretes["EditorSwe"].rule("_207", cs).sel(new Int(0))).sel(Editor.concretes["EditorSwe"].rule("_207", cs).sel(new Int(1))).sel(Editor.concretes["EditorSwe"].rule("_207", cs).sel(new Int(2))))));}, Finnish: function(cs){return new Arr(new Arr(new Arr(new Suffix("Finska", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Finskan", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(new Suffix("Finskor", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Finskorna", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(0));}, Float_N: function(cs){return new Arr(new Arr(new Arr(Editor.concretes["EditorSwe"].rule("_225", cs), new Suffix("flyttalet", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(Editor.concretes["EditorSwe"].rule("_225", cs), new Suffix("flyttalen", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(1));}, French: function(cs){return new Arr(new Arr(new Arr(new Suffix("Franska", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Franskan", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(new Suffix("Franskor", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Franskorna", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(0));}, German: function(cs){return new Arr(new Arr(new Arr(new Suffix("Tyska", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Tyskan", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(new Suffix("Tyskor", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Tyskorna", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(0));}, IndefPlDet: function(cs){return Editor.concretes["EditorSwe"].rule("_255", cs);}, IndefSgDet: function(cs){return Editor.concretes["EditorSwe"].rule("_255", cs);}, Integer_N: function(cs){return new Arr(new Arr(new Arr(Editor.concretes["EditorSwe"].rule("_256", cs), new Suffix("heltalet", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(Editor.concretes["EditorSwe"].rule("_256", cs), new Suffix("heltalen", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(1));}, Italian: function(cs){return new Arr(new Arr(new Arr(new Suffix("Italienska", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Italienskan", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(new Suffix("Italienskor", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Italienskorna", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(0));}, Label: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_168", cs).sel(new Int(0)).sel(new Int(0)));}, Language: function(cs){return new Arr(new Arr(new Arr(Editor.concretes["EditorSwe"].rule("_274", cs), new Suffix("språket", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(Editor.concretes["EditorSwe"].rule("_274", cs), new Suffix("språken", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(1));}, Next: function(cs){return new Arr(new Suffix("näst", Editor.concretes["EditorSwe"].rule("_0", cs)), new Int(1));}, Node: function(cs){return new Arr(new Arr(new Arr(new Suffix("nod", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("noden", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(new Suffix("nodar", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("nodarna", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(0));}, Norwegian: function(cs){return new Arr(new Arr(new Arr(new Suffix("Norska", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Norskan", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(new Suffix("Norskor", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Norskorna", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(0));}, Page: function(cs){return new Arr(new Arr(new Arr(new Suffix("sida", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("sidan", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(new Suffix("sidor", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("sidorna", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(0));}, Parse: function(cs){return new Arr(new Suffix("Parsa", Editor.concretes["EditorSwe"].rule("_126", cs)), Editor.concretes["EditorSwe"].rule("_48", cs), new Int(0));}, Paste: function(cs){return new Arr(new Suffix("Klistra", Editor.concretes["EditorSwe"].rule("_126", cs)), new Str("in"), new Int(0));}, Previous: function(cs){return new Arr(new Arr(new Str("föregående"), new Str("föregåendes"), new Str("föregående"), new Str("föregåendes"), new Str("föregående"), new Str("föregåendes"), new Str("föregående"), new Str("föregåendes"), new Str("föregående"), new Str("föregåendes"), Editor.concretes["EditorSwe"].rule("_48", cs), new Str("s"), Editor.concretes["EditorSwe"].rule("_48", cs), new Str("s"), new Str("a"), new Str("as")), new Int(1));}, RandomlyCommand: function(cs){return new Arr(new Seq(Editor.concretes["EditorSwe"].rule("_16", cs), Editor.concretes["EditorSwe"].rule("_17", cs), Editor.concretes["EditorSwe"].rule("_23", cs), Editor.concretes["EditorSwe"].rule("_47", cs), Editor.concretes["EditorSwe"].rule("_62", cs), Editor.concretes["EditorSwe"].rule("_64", cs), new Str("slumpmässigt")));}, Redo: function(cs){return new Arr(new Suffix("Upprepa", Editor.concretes["EditorSwe"].rule("_126", cs)), Editor.concretes["EditorSwe"].rule("_48", cs), new Int(0));}, Refine: function(cs){return new Arr(new Suffix("Raffinera", Editor.concretes["EditorSwe"].rule("_126", cs)), Editor.concretes["EditorSwe"].rule("_48", cs), new Int(0));}, Refinement: function(cs){return new Arr(new Arr(new Arr(new Suffix("raffinemang", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("raffinemangen", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(new Suffix("raffinemangar", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("raffinemangarna", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(0));}, Replace: function(cs){return new Arr(new Suffix("Ersätt", Editor.concretes["EditorSwe"].rule("_129", cs)), Editor.concretes["EditorSwe"].rule("_48", cs), new Int(0));}, Russian: function(cs){return new Arr(new Arr(new Arr(new Suffix("Ryska", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Ryskan", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(new Suffix("Ryskor", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Ryskorna", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(0));}, Select: function(cs){return new Arr(new Suffix("Välj", Editor.concretes["EditorSwe"].rule("_129", cs)), Editor.concretes["EditorSwe"].rule("_48", cs), new Int(0));}, Show: function(cs){return new Arr(new Suffix("Visa", Editor.concretes["EditorSwe"].rule("_126", cs)), Editor.concretes["EditorSwe"].rule("_48", cs), new Int(0));}, SingleWordCommand: function(cs){return new Arr(new Seq(Editor.concretes["EditorSwe"].rule("_16", cs), Editor.concretes["EditorSwe"].rule("_17", cs),(new Arr(Editor.concretes["EditorSwe"].rule("_345", cs), Editor.concretes["EditorSwe"].rule("_345", cs), new Arr((new Arr(Editor.concretes["EditorSwe"].rule("_48", cs), Editor.concretes["EditorSwe"].rule("_48", cs), new Str("oss"))).sel(Editor.concretes["EditorSwe"].rule("_14", cs)),(new Arr(Editor.concretes["EditorSwe"].rule("_48", cs), Editor.concretes["EditorSwe"].rule("_48", cs), new Str("er"))).sel(Editor.concretes["EditorSwe"].rule("_14", cs)), Editor.concretes["EditorSwe"].rule("_344", cs)))).sel(Editor.concretes["EditorSwe"].rule("_76", cs).sel(new Int(0))).sel(Editor.concretes["EditorSwe"].rule("_76", cs).sel(new Int(1)))));}, Spanish: function(cs){return new Arr(new Arr(new Arr(new Suffix("Spanska", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Spanskan", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(new Suffix("Spanskor", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Spanskorna", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(0));}, String_N: function(cs){return new Arr(new Arr(new Arr(new Suffix("sträng", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("strängen", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(new Suffix("strängar", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("strängarna", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(0));}, Swedish: function(cs){return new Arr(new Arr(new Arr(new Suffix("Svenska", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Svenskan", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(new Suffix("Svenskor", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("Svenskorna", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(0));}, Tree: function(cs){return new Arr(new Arr(new Arr(Editor.concretes["EditorSwe"].rule("_382", cs), new Suffix("trädet", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(Editor.concretes["EditorSwe"].rule("_382", cs), new Suffix("träden", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(1));}, Undo: function(cs){return new Arr(new Suffix("Ångra", Editor.concretes["EditorSwe"].rule("_126", cs)), Editor.concretes["EditorSwe"].rule("_48", cs), new Int(0));}, Wrap: function(cs){return new Arr(new Suffix("Förpacka", Editor.concretes["EditorSwe"].rule("_126", cs)), Editor.concretes["EditorSwe"].rule("_48", cs), new Int(0));}, Wrapper: function(cs){return new Arr(new Arr(new Arr(new Suffix("förpackning", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("förpackningen", Editor.concretes["EditorSwe"].rule("_3", cs))), new Arr(new Suffix("förpackningar", Editor.concretes["EditorSwe"].rule("_3", cs)), new Suffix("förpackningarna", Editor.concretes["EditorSwe"].rule("_3", cs)))), new Int(0));}, _0: function(cs){return new Arr(new Str(""), new Str("s"), new Str("t"), new Str("ts"), new Str("a"), new Str("as"), new Str("a"), new Str("as"), new Str("a"), new Str("as"), new Str("are"), new Str("ares"), new Str("ast"), new Str("asts"), new Str("aste"), new Str("astes"));}, _104: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_85", cs), new Int(2));}, _105: function(cs){return Editor.concretes["EditorSwe"].rule("_104", cs).sel(new Int(0));}, _107: function(cs){return Editor.concretes["EditorSwe"].rule("_104", cs).sel(new Int(1));}, _114: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_39", cs), new Int(1), new Int(0));}, _12: function(cs){return cs[0].sel(new Int(0));}, _126: function(cs){return new Arr(new Str("r"), new Str("s"), new Str(""), new Str("s"), new Str(""), new Str("s"), new Str("d"), new Str("ds"), new Str("t"), new Str("ts"), new Str("de"), new Str("des"), new Str("de"), new Str("des"), new Str("de"), new Str("des"));}, _129: function(cs){return new Arr(new Str("er"), new Str("s"), new Str(""), new Str("s"), new Str("a"), new Str("as"), new Str("t"), new Str("ts"), new Str("t"), new Str("ts"), new Str("ta"), new Str("tas"), new Str("ta"), new Str("tas"), new Str("ta"), new Str("tas"));}, _13: function(cs){return new Arr(new Int(2), new Int(3), new Int(2));}, _14: function(cs){return cs[0].sel(new Int(2));}, _140: function(cs){return new Arr(new Str("n"), new Str("t"));}, _141: function(cs){return new Suffix("de", Editor.concretes["EditorSwe"].rule("_140", cs));}, _142: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_141", cs), Editor.concretes["EditorSwe"].rule("_141", cs));}, _143: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_48", cs), Editor.concretes["EditorSwe"].rule("_48", cs));}, _144: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_141", cs), Editor.concretes["EditorSwe"].rule("_143", cs));}, _145: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_142", cs), Editor.concretes["EditorSwe"].rule("_144", cs));}, _146: function(cs){return new Arr(new Str(""), new Str(""));}, _147: function(cs){return new Suffix("de", Editor.concretes["EditorSwe"].rule("_146", cs));}, _148: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_147", cs), Editor.concretes["EditorSwe"].rule("_147", cs));}, _149: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_147", cs), Editor.concretes["EditorSwe"].rule("_143", cs));}, _15: function(cs){return Editor.concretes["EditorSwe"].rule("_13", cs).sel(Editor.concretes["EditorSwe"].rule("_14", cs));}, _150: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_148", cs), Editor.concretes["EditorSwe"].rule("_149", cs));}, _151: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_145", cs), Editor.concretes["EditorSwe"].rule("_150", cs));}, _152: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_151", cs), new Int(2));}, _16: function(cs){return Editor.concretes["EditorSwe"].rule("_12", cs).sel(Editor.concretes["EditorSwe"].rule("_15", cs));}, _168: function(cs){return Editor.concretes["EditorSwe"].rule("_12", cs).sel(new Int(0));}, _169: function(cs){return Editor.concretes["EditorSwe"].rule("_12", cs).sel(new Int(2));}, _17: function(cs){return cs[0].sel(new Int(1));}, _170: function(cs){return Editor.concretes["EditorSwe"].rule("_12", cs).sel(new Int(4));}, _171: function(cs){return Editor.concretes["EditorSwe"].rule("_12", cs).sel(new Int(6));}, _172: function(cs){return Editor.concretes["EditorSwe"].rule("_12", cs).sel(new Int(8));}, _173: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_168", cs), Editor.concretes["EditorSwe"].rule("_169", cs), Editor.concretes["EditorSwe"].rule("_170", cs), Editor.concretes["EditorSwe"].rule("_171", cs), Editor.concretes["EditorSwe"].rule("_172", cs));}, _174: function(cs){return Editor.concretes["EditorSwe"].rule("_76", cs).sel(Editor.concretes["EditorSwe"].rule("_39", cs));}, _175: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_174", cs), new Int(3), new Int(3));}, _176: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_174", cs), new Int(4), new Int(4));}, _177: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_175", cs), Editor.concretes["EditorSwe"].rule("_175", cs), Editor.concretes["EditorSwe"].rule("_176", cs));}, _178: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_39", cs), new Int(0));}, _179: function(cs){return Editor.concretes["EditorSwe"].rule("_178", cs).sel(new Int(0));}, _18: function(cs){return cs[1].sel(new Int(0));}, _180: function(cs){return Editor.concretes["EditorSwe"].rule("_52", cs).sel(Editor.concretes["EditorSwe"].rule("_179", cs));}, _181: function(cs){return Editor.concretes["EditorSwe"].rule("_178", cs).sel(new Int(1));}, _182: function(cs){return Editor.concretes["EditorSwe"].rule("_180", cs).sel(Editor.concretes["EditorSwe"].rule("_181", cs));}, _183: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_182", cs), new Int(0));}, _189: function(cs){return Editor.concretes["EditorSwe"].rule("_67", cs).sel(new Int(0));}, _19: function(cs){return Editor.concretes["EditorSwe"].rule("_18", cs).sel(new Int(0));}, _191: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_182", cs), new Int(1));}, _198: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_182", cs), new Int(2));}, _20: function(cs){return Editor.concretes["EditorSwe"].rule("_19", cs).sel(new Int(1));}, _207: function(cs){return new Arr(new Int(0), new Int(1), new Int(0));}, _21: function(cs){return Editor.concretes["EditorSwe"].rule("_20", cs).sel(new Int(1));}, _22: function(cs){return cs[2].sel(new Int(1));}, _225: function(cs){return new Suffix("flyttal", Editor.concretes["EditorSwe"].rule("_3", cs));}, _23: function(cs){return Editor.concretes["EditorSwe"].rule("_21", cs).sel(Editor.concretes["EditorSwe"].rule("_22", cs));}, _24: function(cs){return cs[2].sel(new Int(0));}, _248: function(cs){return new Arr(new Str("n"), new Str("tt"));}, _249: function(cs){return new Suffix("e", Editor.concretes["EditorSwe"].rule("_248", cs));}, _25: function(cs){return Editor.concretes["EditorSwe"].rule("_24", cs).sel(new Int(0));}, _250: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_143", cs), Editor.concretes["EditorSwe"].rule("_249", cs));}, _251: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_250", cs), Editor.concretes["EditorSwe"].rule("_250", cs));}, _252: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_143", cs), Editor.concretes["EditorSwe"].rule("_143", cs));}, _253: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_252", cs), Editor.concretes["EditorSwe"].rule("_252", cs));}, _254: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_251", cs), Editor.concretes["EditorSwe"].rule("_253", cs));}, _255: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_254", cs), new Int(0));}, _256: function(cs){return new Suffix("heltal", Editor.concretes["EditorSwe"].rule("_3", cs));}, _26: function(cs){return Editor.concretes["EditorSwe"].rule("_25", cs).sel(new Int(0));}, _27: function(cs){return Editor.concretes["EditorSwe"].rule("_26", cs).sel(new Int(0));}, _274: function(cs){return new Suffix("språk", Editor.concretes["EditorSwe"].rule("_3", cs));}, _28: function(cs){return Editor.concretes["EditorSwe"].rule("_25", cs).sel(new Int(1));}, _29: function(cs){return Editor.concretes["EditorSwe"].rule("_28", cs).sel(new Int(0));}, _3: function(cs){return new Arr(new Str(""), new Str("s"));}, _30: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_27", cs), Editor.concretes["EditorSwe"].rule("_27", cs), Editor.concretes["EditorSwe"].rule("_29", cs));}, _31: function(cs){return new Arr(new Int(0), new Int(0));}, _32: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_31", cs), Editor.concretes["EditorSwe"].rule("_31", cs));}, _33: function(cs){return new Arr(new Int(1), new Int(1));}, _34: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_33", cs), Editor.concretes["EditorSwe"].rule("_33", cs));}, _341: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_48", cs), Editor.concretes["EditorSwe"].rule("_48", cs), new Str("mig"));}, _342: function(cs){return Editor.concretes["EditorSwe"].rule("_341", cs).sel(Editor.concretes["EditorSwe"].rule("_14", cs));}, _343: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_48", cs), Editor.concretes["EditorSwe"].rule("_48", cs), new Str("sig"));}, _344: function(cs){return Editor.concretes["EditorSwe"].rule("_343", cs).sel(Editor.concretes["EditorSwe"].rule("_14", cs));}, _345: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_342", cs), Editor.concretes["EditorSwe"].rule("_64", cs), Editor.concretes["EditorSwe"].rule("_344", cs));}, _35: function(cs){return new Arr(new Int(1), new Int(2));}, _36: function(cs){return new Arr(new Int(2), new Int(2));}, _37: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_35", cs), Editor.concretes["EditorSwe"].rule("_36", cs));}, _38: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_32", cs), Editor.concretes["EditorSwe"].rule("_34", cs), Editor.concretes["EditorSwe"].rule("_37", cs));}, _382: function(cs){return new Suffix("träd", Editor.concretes["EditorSwe"].rule("_3", cs));}, _39: function(cs){return cs[1].sel(new Int(1));}, _40: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_39", cs), new Int(1), new Int(1));}, _401: function(cs){return new Arr(cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0], cs[0]);}, _403: function(cs){return new Arr(cs[0], cs[0]);}, _404: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_403", cs), Editor.concretes["EditorSwe"].rule("_403", cs));}, _405: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_404", cs), Editor.concretes["EditorSwe"].rule("_404", cs));}, _41: function(cs){return Editor.concretes["EditorSwe"].rule("_40", cs).sel(new Int(0));}, _42: function(cs){return Editor.concretes["EditorSwe"].rule("_38", cs).sel(Editor.concretes["EditorSwe"].rule("_41", cs));}, _43: function(cs){return Editor.concretes["EditorSwe"].rule("_40", cs).sel(new Int(1));}, _44: function(cs){return Editor.concretes["EditorSwe"].rule("_42", cs).sel(Editor.concretes["EditorSwe"].rule("_43", cs));}, _45: function(cs){return Editor.concretes["EditorSwe"].rule("_40", cs).sel(new Int(2));}, _46: function(cs){return Editor.concretes["EditorSwe"].rule("_44", cs).sel(Editor.concretes["EditorSwe"].rule("_45", cs));}, _47: function(cs){return Editor.concretes["EditorSwe"].rule("_30", cs).sel(Editor.concretes["EditorSwe"].rule("_46", cs));}, _48: function(cs){return new Seq();}, _49: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_48", cs), Editor.concretes["EditorSwe"].rule("_48", cs), Editor.concretes["EditorSwe"].rule("_48", cs));}, _50: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_49", cs), Editor.concretes["EditorSwe"].rule("_49", cs), Editor.concretes["EditorSwe"].rule("_49", cs));}, _51: function(cs){return new Arr(new Int(0), new Int(2));}, _52: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_51", cs), Editor.concretes["EditorSwe"].rule("_35", cs));}, _53: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_22", cs), new Int(0));}, _54: function(cs){return Editor.concretes["EditorSwe"].rule("_53", cs).sel(new Int(0));}, _55: function(cs){return Editor.concretes["EditorSwe"].rule("_52", cs).sel(Editor.concretes["EditorSwe"].rule("_54", cs));}, _56: function(cs){return Editor.concretes["EditorSwe"].rule("_53", cs).sel(new Int(1));}, _57: function(cs){return Editor.concretes["EditorSwe"].rule("_55", cs).sel(Editor.concretes["EditorSwe"].rule("_56", cs));}, _58: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_57", cs), new Int(2));}, _59: function(cs){return Editor.concretes["EditorSwe"].rule("_58", cs).sel(new Int(0));}, _60: function(cs){return Editor.concretes["EditorSwe"].rule("_50", cs).sel(Editor.concretes["EditorSwe"].rule("_59", cs));}, _61: function(cs){return Editor.concretes["EditorSwe"].rule("_58", cs).sel(new Int(1));}, _62: function(cs){return Editor.concretes["EditorSwe"].rule("_60", cs).sel(Editor.concretes["EditorSwe"].rule("_61", cs));}, _63: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_48", cs), Editor.concretes["EditorSwe"].rule("_48", cs), new Str("dig"));}, _64: function(cs){return Editor.concretes["EditorSwe"].rule("_63", cs).sel(Editor.concretes["EditorSwe"].rule("_14", cs));}, _67: function(cs){return Editor.concretes["EditorSwe"].rule("_19", cs).sel(new Int(0));}, _69: function(cs){return cs[3].sel(new Int(1));}, _71: function(cs){return Editor.concretes["EditorSwe"].rule("_24", cs).sel(new Int(2));}, _72: function(cs){return Editor.concretes["EditorSwe"].rule("_24", cs).sel(new Int(4));}, _73: function(cs){return Editor.concretes["EditorSwe"].rule("_24", cs).sel(new Int(6));}, _74: function(cs){return Editor.concretes["EditorSwe"].rule("_24", cs).sel(new Int(8));}, _75: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_25", cs), Editor.concretes["EditorSwe"].rule("_71", cs), Editor.concretes["EditorSwe"].rule("_72", cs), Editor.concretes["EditorSwe"].rule("_73", cs), Editor.concretes["EditorSwe"].rule("_74", cs));}, _76: function(cs){return new Arr(new Int(0), new Int(1));}, _77: function(cs){return Editor.concretes["EditorSwe"].rule("_76", cs).sel(Editor.concretes["EditorSwe"].rule("_69", cs));}, _78: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_77", cs), new Int(3), new Int(3));}, _79: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_77", cs), new Int(4), new Int(4));}, _80: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_78", cs), Editor.concretes["EditorSwe"].rule("_78", cs), Editor.concretes["EditorSwe"].rule("_79", cs));}, _81: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_69", cs), new Int(0));}, _82: function(cs){return Editor.concretes["EditorSwe"].rule("_81", cs).sel(new Int(0));}, _83: function(cs){return Editor.concretes["EditorSwe"].rule("_52", cs).sel(Editor.concretes["EditorSwe"].rule("_82", cs));}, _84: function(cs){return Editor.concretes["EditorSwe"].rule("_81", cs).sel(new Int(1));}, _85: function(cs){return Editor.concretes["EditorSwe"].rule("_83", cs).sel(Editor.concretes["EditorSwe"].rule("_84", cs));}, _86: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_85", cs), new Int(0));}, _92: function(cs){return cs[3].sel(new Int(0));}, _93: function(cs){return Editor.concretes["EditorSwe"].rule("_92", cs).sel(new Int(0));}, _94: function(cs){return Editor.concretes["EditorSwe"].rule("_93", cs).sel(new Int(0));}, _95: function(cs){return Editor.concretes["EditorSwe"].rule("_94", cs).sel(new Int(0));}, _97: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_85", cs), new Int(1));}, Adjective: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_401", cs), new Int(0));}, Determiner: function(cs){return new Arr(new Arr(Editor.concretes["EditorSwe"].rule("_405", cs), Editor.concretes["EditorSwe"].rule("_405", cs)), new Int(0));}, Noun: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_405", cs), new Int(0));}, Sentence: function(cs){return new Arr(cs[0]);}, Verb: function(cs){return new Arr(Editor.concretes["EditorSwe"].rule("_401", cs), cs[0], new Int(0));}, "Int": function(cs){return new Arr(cs[0]);}, "Float": function(cs){return new Arr(cs[0]);}, "String": function(cs){return new Arr(cs[0]);}}, new Parser("Sentence",[new Rule(27, new FunApp("Copy",[]),[],[[],[new Terminal("Kopiera")]]), new Rule(27, new FunApp("Cut",[]),[],[[new Terminal("ut")],[new Terminal("Klipp")]]), new Rule(27, new FunApp("Delete",[]),[],[[],[new Terminal("Radera")]]), new Rule(27, new FunApp("Enter",[]),[],[[],[new Terminal("Skriv")]]), new Rule(27, new FunApp("Parse",[]),[],[[],[new Terminal("Parsa")]]), new Rule(27, new FunApp("Paste",[]),[],[[new Terminal("in")],[new Terminal("Klistra")]]), new Rule(27, new FunApp("Redo",[]),[],[[],[new Terminal("Upprepa")]]), new Rule(27, new FunApp("Refine",[]),[],[[],[new Terminal("Raffinera")]]), new Rule(27, new FunApp("Replace",[]),[],[[],[new Terminal("Ersätt")]]), new Rule(27, new FunApp("Select",[]),[],[[],[new Terminal("Välj")]]), new Rule(27, new FunApp("Show",[]),[],[[],[new Terminal("Visa")]]), new Rule(27, new FunApp("Undo",[]),[],[[],[new Terminal("Ångra")]]), new Rule(27, new FunApp("Wrap",[]),[],[[],[new Terminal("Förpacka")]]), new Rule(24, new FunApp("Wrapper",[]),[],[[new Terminal("förpackning")]]), new Rule(23, new FunApp("Wrapper",[]),[],[[new Terminal("förpacknings")]]), new Rule(22, new FunApp("Wrapper",[]),[],[[new Terminal("förpackningen")]]), new Rule(21, new FunApp("Wrapper",[]),[],[[new Terminal("förpackningens")]]), new Rule(20, new FunApp("Wrapper",[]),[],[[new Terminal("förpackningar")]]), new Rule(19, new FunApp("Wrapper",[]),[],[[new Terminal("förpackningars")]]), new Rule(18, new FunApp("Wrapper",[]),[],[[new Terminal("förpackningarna")]]), new Rule(17, new FunApp("Wrapper",[]),[],[[new Terminal("förpackningarnas")]]), new Rule(65, new FunApp("Wrap",[]),[],[[new Terminal("Förpackar")]]), new Rule(64, new FunApp("Wrap",[]),[],[[new Terminal("Förpackas")]]), new Rule(63, new FunApp("Wrap",[]),[],[[new Terminal("Förpacka")]]), new Rule(62, new FunApp("Wrap",[]),[],[[new Terminal("Förpackas")]]), new Rule(61, new FunApp("Wrap",[]),[],[[new Terminal("Förpacka")]]), new Rule(60, new FunApp("Wrap",[]),[],[[new Terminal("Förpackas")]]), new Rule(59, new FunApp("Wrap",[]),[],[[new Terminal("Förpackad")]]), new Rule(58, new FunApp("Wrap",[]),[],[[new Terminal("Förpackads")]]), new Rule(57, new FunApp("Wrap",[]),[],[[new Terminal("Förpackat")]]), new Rule(56, new FunApp("Wrap",[]),[],[[new Terminal("Förpackats")]]), new Rule(55, new FunApp("Wrap",[]),[],[[new Terminal("Förpackade")]]), new Rule(54, new FunApp("Wrap",[]),[],[[new Terminal("Förpackades")]]), new Rule(53, new FunApp("Wrap",[]),[],[[new Terminal("Förpackade")]]), new Rule(52, new FunApp("Wrap",[]),[],[[new Terminal("Förpackades")]]), new Rule(51, new FunApp("Wrap",[]),[],[[new Terminal("Förpackade")]]), new Rule(50, new FunApp("Wrap",[]),[],[[new Terminal("Förpackades")]]), new Rule(49, new FunApp("Wrap",[]),[],[[]]), new Rule(65, new FunApp("Undo",[]),[],[[new Terminal("Ångrar")]]), new Rule(64, new FunApp("Undo",[]),[],[[new Terminal("Ångras")]]), new Rule(63, new FunApp("Undo",[]),[],[[new Terminal("Ångra")]]), new Rule(62, new FunApp("Undo",[]),[],[[new Terminal("Ångras")]]), new Rule(61, new FunApp("Undo",[]),[],[[new Terminal("Ångra")]]), new Rule(60, new FunApp("Undo",[]),[],[[new Terminal("Ångras")]]), new Rule(59, new FunApp("Undo",[]),[],[[new Terminal("Ångrad")]]), new Rule(58, new FunApp("Undo",[]),[],[[new Terminal("Ångrads")]]), new Rule(57, new FunApp("Undo",[]),[],[[new Terminal("Ångrat")]]), new Rule(56, new FunApp("Undo",[]),[],[[new Terminal("Ångrats")]]), new Rule(55, new FunApp("Undo",[]),[],[[new Terminal("Ångrade")]]), new Rule(54, new FunApp("Undo",[]),[],[[new Terminal("Ångrades")]]), new Rule(53, new FunApp("Undo",[]),[],[[new Terminal("Ångrade")]]), new Rule(52, new FunApp("Undo",[]),[],[[new Terminal("Ångrades")]]), new Rule(51, new FunApp("Undo",[]),[],[[new Terminal("Ångrade")]]), new Rule(50, new FunApp("Undo",[]),[],[[new Terminal("Ångrades")]]), new Rule(49, new FunApp("Undo",[]),[],[[]]), new Rule(30, new FunApp("Tree",[]),[],[[new Terminal("träd")]]), new Rule(83, new FunApp("Tree",[]),[],[[new Terminal("träds")]]), new Rule(33, new FunApp("Tree",[]),[],[[new Terminal("trädet")]]), new Rule(82, new FunApp("Tree",[]),[],[[new Terminal("trädets")]]), new Rule(81, new FunApp("Tree",[]),[],[[new Terminal("träd")]]), new Rule(80, new FunApp("Tree",[]),[],[[new Terminal("träds")]]), new Rule(79, new FunApp("Tree",[]),[],[[new Terminal("träden")]]), new Rule(78, new FunApp("Tree",[]),[],[[new Terminal("trädens")]]), new Rule(24, new FunApp("Swedish",[]),[],[[new Terminal("Svenska")]]), new Rule(23, new FunApp("Swedish",[]),[],[[new Terminal("Svenskas")]]), new Rule(22, new FunApp("Swedish",[]),[],[[new Terminal("Svenskan")]]), new Rule(21, new FunApp("Swedish",[]),[],[[new Terminal("Svenskans")]]), new Rule(20, new FunApp("Swedish",[]),[],[[new Terminal("Svenskor")]]), new Rule(19, new FunApp("Swedish",[]),[],[[new Terminal("Svenskors")]]), new Rule(18, new FunApp("Swedish",[]),[],[[new Terminal("Svenskorna")]]), new Rule(17, new FunApp("Swedish",[]),[],[[new Terminal("Svenskornas")]]), new Rule(24, new FunApp("String_N",[]),[],[[new Terminal("sträng")]]), new Rule(23, new FunApp("String_N",[]),[],[[new Terminal("strängs")]]), new Rule(22, new FunApp("String_N",[]),[],[[new Terminal("strängen")]]), new Rule(21, new FunApp("String_N",[]),[],[[new Terminal("strängens")]]), new Rule(20, new FunApp("String_N",[]),[],[[new Terminal("strängar")]]), new Rule(19, new FunApp("String_N",[]),[],[[new Terminal("strängars")]]), new Rule(18, new FunApp("String_N",[]),[],[[new Terminal("strängarna")]]), new Rule(17, new FunApp("String_N",[]),[],[[new Terminal("strängarnas")]]), new Rule(24, new FunApp("Spanish",[]),[],[[new Terminal("Spanska")]]), new Rule(23, new FunApp("Spanish",[]),[],[[new Terminal("Spanskas")]]), new Rule(22, new FunApp("Spanish",[]),[],[[new Terminal("Spanskan")]]), new Rule(21, new FunApp("Spanish",[]),[],[[new Terminal("Spanskans")]]), new Rule(20, new FunApp("Spanish",[]),[],[[new Terminal("Spanskor")]]), new Rule(19, new FunApp("Spanish",[]),[],[[new Terminal("Spanskors")]]), new Rule(18, new FunApp("Spanish",[]),[],[[new Terminal("Spanskorna")]]), new Rule(17, new FunApp("Spanish",[]),[],[[new Terminal("Spanskornas")]]), new Rule(25, new FunApp("SingleWordCommand",[new Arg(0)]),[36],[[new ArgProj(0, 1), new ArgProj(0, 0), new Terminal("dig")]]), new Rule(25, new FunApp("SingleWordCommand",[new Arg(0)]),[35],[[new ArgProj(0, 1), new ArgProj(0, 0)]]), new Rule(25, new FunApp("SingleWordCommand",[new Arg(0)]),[27],[[new ArgProj(0, 1), new ArgProj(0, 0)]]), new Rule(65, new FunApp("Show",[]),[],[[new Terminal("Visar")]]), new Rule(64, new FunApp("Show",[]),[],[[new Terminal("Visas")]]), new Rule(63, new FunApp("Show",[]),[],[[new Terminal("Visa")]]), new Rule(62, new FunApp("Show",[]),[],[[new Terminal("Visas")]]), new Rule(61, new FunApp("Show",[]),[],[[new Terminal("Visa")]]), new Rule(60, new FunApp("Show",[]),[],[[new Terminal("Visas")]]), new Rule(59, new FunApp("Show",[]),[],[[new Terminal("Visad")]]), new Rule(58, new FunApp("Show",[]),[],[[new Terminal("Visads")]]), new Rule(57, new FunApp("Show",[]),[],[[new Terminal("Visat")]]), new Rule(56, new FunApp("Show",[]),[],[[new Terminal("Visats")]]), new Rule(55, new FunApp("Show",[]),[],[[new Terminal("Visade")]]), new Rule(54, new FunApp("Show",[]),[],[[new Terminal("Visades")]]), new Rule(53, new FunApp("Show",[]),[],[[new Terminal("Visade")]]), new Rule(52, new FunApp("Show",[]),[],[[new Terminal("Visades")]]), new Rule(51, new FunApp("Show",[]),[],[[new Terminal("Visade")]]), new Rule(50, new FunApp("Show",[]),[],[[new Terminal("Visades")]]), new Rule(49, new FunApp("Show",[]),[],[[]]), new Rule(65, new FunApp("Select",[]),[],[[new Terminal("Väljer")]]), new Rule(64, new FunApp("Select",[]),[],[[new Terminal("Väljs")]]), new Rule(63, new FunApp("Select",[]),[],[[new Terminal("Välj")]]), new Rule(62, new FunApp("Select",[]),[],[[new Terminal("Väljs")]]), new Rule(61, new FunApp("Select",[]),[],[[new Terminal("Välja")]]), new Rule(60, new FunApp("Select",[]),[],[[new Terminal("Väljas")]]), new Rule(59, new FunApp("Select",[]),[],[[new Terminal("Väljt")]]), new Rule(58, new FunApp("Select",[]),[],[[new Terminal("Väljts")]]), new Rule(57, new FunApp("Select",[]),[],[[new Terminal("Väljt")]]), new Rule(56, new FunApp("Select",[]),[],[[new Terminal("Väljts")]]), new Rule(55, new FunApp("Select",[]),[],[[new Terminal("Väljta")]]), new Rule(54, new FunApp("Select",[]),[],[[new Terminal("Väljtas")]]), new Rule(53, new FunApp("Select",[]),[],[[new Terminal("Väljta")]]), new Rule(52, new FunApp("Select",[]),[],[[new Terminal("Väljtas")]]), new Rule(51, new FunApp("Select",[]),[],[[new Terminal("Väljta")]]), new Rule(50, new FunApp("Select",[]),[],[[new Terminal("Väljtas")]]), new Rule(49, new FunApp("Select",[]),[],[[]]), new Rule(24, new FunApp("Russian",[]),[],[[new Terminal("Ryska")]]), new Rule(23, new FunApp("Russian",[]),[],[[new Terminal("Ryskas")]]), new Rule(22, new FunApp("Russian",[]),[],[[new Terminal("Ryskan")]]), new Rule(21, new FunApp("Russian",[]),[],[[new Terminal("Ryskans")]]), new Rule(20, new FunApp("Russian",[]),[],[[new Terminal("Ryskor")]]), new Rule(19, new FunApp("Russian",[]),[],[[new Terminal("Ryskors")]]), new Rule(18, new FunApp("Russian",[]),[],[[new Terminal("Ryskorna")]]), new Rule(17, new FunApp("Russian",[]),[],[[new Terminal("Ryskornas")]]), new Rule(65, new FunApp("Replace",[]),[],[[new Terminal("Ersätter")]]), new Rule(64, new FunApp("Replace",[]),[],[[new Terminal("Ersätts")]]), new Rule(63, new FunApp("Replace",[]),[],[[new Terminal("Ersätt")]]), new Rule(62, new FunApp("Replace",[]),[],[[new Terminal("Ersätts")]]), new Rule(61, new FunApp("Replace",[]),[],[[new Terminal("Ersätta")]]), new Rule(60, new FunApp("Replace",[]),[],[[new Terminal("Ersättas")]]), new Rule(59, new FunApp("Replace",[]),[],[[new Terminal("Ersättt")]]), new Rule(58, new FunApp("Replace",[]),[],[[new Terminal("Ersättts")]]), new Rule(57, new FunApp("Replace",[]),[],[[new Terminal("Ersättt")]]), new Rule(56, new FunApp("Replace",[]),[],[[new Terminal("Ersättts")]]), new Rule(55, new FunApp("Replace",[]),[],[[new Terminal("Ersättta")]]), new Rule(54, new FunApp("Replace",[]),[],[[new Terminal("Ersätttas")]]), new Rule(53, new FunApp("Replace",[]),[],[[new Terminal("Ersättta")]]), new Rule(52, new FunApp("Replace",[]),[],[[new Terminal("Ersätttas")]]), new Rule(51, new FunApp("Replace",[]),[],[[new Terminal("Ersättta")]]), new Rule(50, new FunApp("Replace",[]),[],[[new Terminal("Ersätttas")]]), new Rule(49, new FunApp("Replace",[]),[],[[]]), new Rule(24, new FunApp("Refinement",[]),[],[[new Terminal("raffinemang")]]), new Rule(23, new FunApp("Refinement",[]),[],[[new Terminal("raffinemangs")]]), new Rule(22, new FunApp("Refinement",[]),[],[[new Terminal("raffinemangen")]]), new Rule(21, new FunApp("Refinement",[]),[],[[new Terminal("raffinemangens")]]), new Rule(20, new FunApp("Refinement",[]),[],[[new Terminal("raffinemangar")]]), new Rule(19, new FunApp("Refinement",[]),[],[[new Terminal("raffinemangars")]]), new Rule(18, new FunApp("Refinement",[]),[],[[new Terminal("raffinemangarna")]]), new Rule(17, new FunApp("Refinement",[]),[],[[new Terminal("raffinemangarnas")]]), new Rule(65, new FunApp("Refine",[]),[],[[new Terminal("Raffinerar")]]), new Rule(64, new FunApp("Refine",[]),[],[[new Terminal("Raffineras")]]), new Rule(63, new FunApp("Refine",[]),[],[[new Terminal("Raffinera")]]), new Rule(62, new FunApp("Refine",[]),[],[[new Terminal("Raffineras")]]), new Rule(61, new FunApp("Refine",[]),[],[[new Terminal("Raffinera")]]), new Rule(60, new FunApp("Refine",[]),[],[[new Terminal("Raffineras")]]), new Rule(59, new FunApp("Refine",[]),[],[[new Terminal("Raffinerad")]]), new Rule(58, new FunApp("Refine",[]),[],[[new Terminal("Raffinerads")]]), new Rule(57, new FunApp("Refine",[]),[],[[new Terminal("Raffinerat")]]), new Rule(56, new FunApp("Refine",[]),[],[[new Terminal("Raffinerats")]]), new Rule(55, new FunApp("Refine",[]),[],[[new Terminal("Raffinerade")]]), new Rule(54, new FunApp("Refine",[]),[],[[new Terminal("Raffinerades")]]), new Rule(53, new FunApp("Refine",[]),[],[[new Terminal("Raffinerade")]]), new Rule(52, new FunApp("Refine",[]),[],[[new Terminal("Raffinerades")]]), new Rule(51, new FunApp("Refine",[]),[],[[new Terminal("Raffinerade")]]), new Rule(50, new FunApp("Refine",[]),[],[[new Terminal("Raffinerades")]]), new Rule(49, new FunApp("Refine",[]),[],[[]]), new Rule(65, new FunApp("Redo",[]),[],[[new Terminal("Upprepar")]]), new Rule(64, new FunApp("Redo",[]),[],[[new Terminal("Upprepas")]]), new Rule(63, new FunApp("Redo",[]),[],[[new Terminal("Upprepa")]]), new Rule(62, new FunApp("Redo",[]),[],[[new Terminal("Upprepas")]]), new Rule(61, new FunApp("Redo",[]),[],[[new Terminal("Upprepa")]]), new Rule(60, new FunApp("Redo",[]),[],[[new Terminal("Upprepas")]]), new Rule(59, new FunApp("Redo",[]),[],[[new Terminal("Upprepad")]]), new Rule(58, new FunApp("Redo",[]),[],[[new Terminal("Upprepads")]]), new Rule(57, new FunApp("Redo",[]),[],[[new Terminal("Upprepat")]]), new Rule(56, new FunApp("Redo",[]),[],[[new Terminal("Upprepats")]]), new Rule(55, new FunApp("Redo",[]),[],[[new Terminal("Upprepade")]]), new Rule(54, new FunApp("Redo",[]),[],[[new Terminal("Upprepades")]]), new Rule(53, new FunApp("Redo",[]),[],[[new Terminal("Upprepade")]]), new Rule(52, new FunApp("Redo",[]),[],[[new Terminal("Upprepades")]]), new Rule(51, new FunApp("Redo",[]),[],[[new Terminal("Upprepade")]]), new Rule(50, new FunApp("Redo",[]),[],[[new Terminal("Upprepades")]]), new Rule(49, new FunApp("Redo",[]),[],[[]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[36, 34, 33],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("dig"), new Terminal("slumpmässigt")]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[36, 32, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("dig"), new Terminal("slumpmässigt")]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[36, 31, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("dig"), new Terminal("slumpmässigt")]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[36, 29, 22],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("dig"), new Terminal("slumpmässigt")]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[36, 28, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("dig"), new Terminal("slumpmässigt")]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[36, 26, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("dig"), new Terminal("slumpmässigt")]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[35, 34, 33],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("slumpmässigt")]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[35, 32, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("slumpmässigt")]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[35, 31, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("slumpmässigt")]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[35, 29, 22],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("slumpmässigt")]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[35, 28, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("slumpmässigt")]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[35, 26, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("slumpmässigt")]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[27, 34, 33],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("slumpmässigt")]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[27, 32, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("slumpmässigt")]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[27, 31, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("slumpmässigt")]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[27, 29, 22],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("slumpmässigt")]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[27, 28, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("slumpmässigt")]]), new Rule(25, new FunApp("RandomlyCommand",[new Arg(0), new Arg(1), new Arg(2)]),[27, 26, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("slumpmässigt")]]), new Rule(16, new FunApp("Previous",[]),[],[[new Terminal("föregående")]]), new Rule(15, new FunApp("Previous",[]),[],[[new Terminal("föregåendes")]]), new Rule(14, new FunApp("Previous",[]),[],[[new Terminal("föregående")]]), new Rule(13, new FunApp("Previous",[]),[],[[new Terminal("föregåendes")]]), new Rule(12, new FunApp("Previous",[]),[],[[new Terminal("föregående")]]), new Rule(11, new FunApp("Previous",[]),[],[[new Terminal("föregåendes")]]), new Rule(10, new FunApp("Previous",[]),[],[[new Terminal("föregående")]]), new Rule(9, new FunApp("Previous",[]),[],[[new Terminal("föregåendes")]]), new Rule(8, new FunApp("Previous",[]),[],[[new Terminal("föregående")]]), new Rule(7, new FunApp("Previous",[]),[],[[new Terminal("föregåendes")]]), new Rule(6, new FunApp("Previous",[]),[],[[]]), new Rule(5, new FunApp("Previous",[]),[],[[new Terminal("s")]]), new Rule(4, new FunApp("Previous",[]),[],[[]]), new Rule(3, new FunApp("Previous",[]),[],[[new Terminal("s")]]), new Rule(2, new FunApp("Previous",[]),[],[[new Terminal("a")]]), new Rule(1, new FunApp("Previous",[]),[],[[new Terminal("as")]]), new Rule(65, new FunApp("Paste",[]),[],[[new Terminal("Klistrar")]]), new Rule(64, new FunApp("Paste",[]),[],[[new Terminal("Klistras")]]), new Rule(63, new FunApp("Paste",[]),[],[[new Terminal("Klistra")]]), new Rule(62, new FunApp("Paste",[]),[],[[new Terminal("Klistras")]]), new Rule(61, new FunApp("Paste",[]),[],[[new Terminal("Klistra")]]), new Rule(60, new FunApp("Paste",[]),[],[[new Terminal("Klistras")]]), new Rule(59, new FunApp("Paste",[]),[],[[new Terminal("Klistrad")]]), new Rule(58, new FunApp("Paste",[]),[],[[new Terminal("Klistrads")]]), new Rule(57, new FunApp("Paste",[]),[],[[new Terminal("Klistrat")]]), new Rule(56, new FunApp("Paste",[]),[],[[new Terminal("Klistrats")]]), new Rule(55, new FunApp("Paste",[]),[],[[new Terminal("Klistrade")]]), new Rule(54, new FunApp("Paste",[]),[],[[new Terminal("Klistrades")]]), new Rule(53, new FunApp("Paste",[]),[],[[new Terminal("Klistrade")]]), new Rule(52, new FunApp("Paste",[]),[],[[new Terminal("Klistrades")]]), new Rule(51, new FunApp("Paste",[]),[],[[new Terminal("Klistrade")]]), new Rule(50, new FunApp("Paste",[]),[],[[new Terminal("Klistrades")]]), new Rule(49, new FunApp("Paste",[]),[],[[new Terminal("in")]]), new Rule(65, new FunApp("Parse",[]),[],[[new Terminal("Parsar")]]), new Rule(64, new FunApp("Parse",[]),[],[[new Terminal("Parsas")]]), new Rule(63, new FunApp("Parse",[]),[],[[new Terminal("Parsa")]]), new Rule(62, new FunApp("Parse",[]),[],[[new Terminal("Parsas")]]), new Rule(61, new FunApp("Parse",[]),[],[[new Terminal("Parsa")]]), new Rule(60, new FunApp("Parse",[]),[],[[new Terminal("Parsas")]]), new Rule(59, new FunApp("Parse",[]),[],[[new Terminal("Parsad")]]), new Rule(58, new FunApp("Parse",[]),[],[[new Terminal("Parsads")]]), new Rule(57, new FunApp("Parse",[]),[],[[new Terminal("Parsat")]]), new Rule(56, new FunApp("Parse",[]),[],[[new Terminal("Parsats")]]), new Rule(55, new FunApp("Parse",[]),[],[[new Terminal("Parsade")]]), new Rule(54, new FunApp("Parse",[]),[],[[new Terminal("Parsades")]]), new Rule(53, new FunApp("Parse",[]),[],[[new Terminal("Parsade")]]), new Rule(52, new FunApp("Parse",[]),[],[[new Terminal("Parsades")]]), new Rule(51, new FunApp("Parse",[]),[],[[new Terminal("Parsade")]]), new Rule(50, new FunApp("Parse",[]),[],[[new Terminal("Parsades")]]), new Rule(49, new FunApp("Parse",[]),[],[[]]), new Rule(24, new FunApp("Page",[]),[],[[new Terminal("sida")]]), new Rule(23, new FunApp("Page",[]),[],[[new Terminal("sidas")]]), new Rule(22, new FunApp("Page",[]),[],[[new Terminal("sidan")]]), new Rule(21, new FunApp("Page",[]),[],[[new Terminal("sidans")]]), new Rule(20, new FunApp("Page",[]),[],[[new Terminal("sidor")]]), new Rule(19, new FunApp("Page",[]),[],[[new Terminal("sidors")]]), new Rule(18, new FunApp("Page",[]),[],[[new Terminal("sidorna")]]), new Rule(17, new FunApp("Page",[]),[],[[new Terminal("sidornas")]]), new Rule(24, new FunApp("Norwegian",[]),[],[[new Terminal("Norska")]]), new Rule(23, new FunApp("Norwegian",[]),[],[[new Terminal("Norskas")]]), new Rule(22, new FunApp("Norwegian",[]),[],[[new Terminal("Norskan")]]), new Rule(21, new FunApp("Norwegian",[]),[],[[new Terminal("Norskans")]]), new Rule(20, new FunApp("Norwegian",[]),[],[[new Terminal("Norskor")]]), new Rule(19, new FunApp("Norwegian",[]),[],[[new Terminal("Norskors")]]), new Rule(18, new FunApp("Norwegian",[]),[],[[new Terminal("Norskorna")]]), new Rule(17, new FunApp("Norwegian",[]),[],[[new Terminal("Norskornas")]]), new Rule(24, new FunApp("Node",[]),[],[[new Terminal("nod")]]), new Rule(23, new FunApp("Node",[]),[],[[new Terminal("nods")]]), new Rule(22, new FunApp("Node",[]),[],[[new Terminal("noden")]]), new Rule(21, new FunApp("Node",[]),[],[[new Terminal("nodens")]]), new Rule(20, new FunApp("Node",[]),[],[[new Terminal("nodar")]]), new Rule(19, new FunApp("Node",[]),[],[[new Terminal("nodars")]]), new Rule(18, new FunApp("Node",[]),[],[[new Terminal("nodarna")]]), new Rule(17, new FunApp("Node",[]),[],[[new Terminal("nodarnas")]]), new Rule(16, new FunApp("Next",[]),[],[[new Terminal("näst")]]), new Rule(15, new FunApp("Next",[]),[],[[new Terminal("nästs")]]), new Rule(14, new FunApp("Next",[]),[],[[new Terminal("nästt")]]), new Rule(13, new FunApp("Next",[]),[],[[new Terminal("nästts")]]), new Rule(12, new FunApp("Next",[]),[],[[new Terminal("nästa")]]), new Rule(11, new FunApp("Next",[]),[],[[new Terminal("nästas")]]), new Rule(10, new FunApp("Next",[]),[],[[new Terminal("nästa")]]), new Rule(9, new FunApp("Next",[]),[],[[new Terminal("nästas")]]), new Rule(8, new FunApp("Next",[]),[],[[new Terminal("nästa")]]), new Rule(7, new FunApp("Next",[]),[],[[new Terminal("nästas")]]), new Rule(6, new FunApp("Next",[]),[],[[new Terminal("nästare")]]), new Rule(5, new FunApp("Next",[]),[],[[new Terminal("nästares")]]), new Rule(4, new FunApp("Next",[]),[],[[new Terminal("nästast")]]), new Rule(3, new FunApp("Next",[]),[],[[new Terminal("nästasts")]]), new Rule(2, new FunApp("Next",[]),[],[[new Terminal("nästaste")]]), new Rule(1, new FunApp("Next",[]),[],[[new Terminal("nästastes")]]), new Rule(30, new FunApp("Language",[]),[],[[new Terminal("språk")]]), new Rule(83, new FunApp("Language",[]),[],[[new Terminal("språks")]]), new Rule(33, new FunApp("Language",[]),[],[[new Terminal("språket")]]), new Rule(82, new FunApp("Language",[]),[],[[new Terminal("språkets")]]), new Rule(81, new FunApp("Language",[]),[],[[new Terminal("språk")]]), new Rule(80, new FunApp("Language",[]),[],[[new Terminal("språks")]]), new Rule(79, new FunApp("Language",[]),[],[[new Terminal("språken")]]), new Rule(78, new FunApp("Language",[]),[],[[new Terminal("språkens")]]), new Rule(25, new FunApp("Label",[new Arg(0)]),[96],[[new ArgProj(0, 0)]]), new Rule(96, new Arg(0),[30],[[new ArgProj(0, 0)]]), new Rule(96, new Arg(0),[24],[[new ArgProj(0, 0)]]), new Rule(24, new FunApp("Italian",[]),[],[[new Terminal("Italienska")]]), new Rule(23, new FunApp("Italian",[]),[],[[new Terminal("Italienskas")]]), new Rule(22, new FunApp("Italian",[]),[],[[new Terminal("Italienskan")]]), new Rule(21, new FunApp("Italian",[]),[],[[new Terminal("Italienskans")]]), new Rule(20, new FunApp("Italian",[]),[],[[new Terminal("Italienskor")]]), new Rule(19, new FunApp("Italian",[]),[],[[new Terminal("Italienskors")]]), new Rule(18, new FunApp("Italian",[]),[],[[new Terminal("Italienskorna")]]), new Rule(17, new FunApp("Italian",[]),[],[[new Terminal("Italienskornas")]]), new Rule(30, new FunApp("Integer_N",[]),[],[[new Terminal("heltal")]]), new Rule(83, new FunApp("Integer_N",[]),[],[[new Terminal("heltals")]]), new Rule(33, new FunApp("Integer_N",[]),[],[[new Terminal("heltalet")]]), new Rule(82, new FunApp("Integer_N",[]),[],[[new Terminal("heltalets")]]), new Rule(81, new FunApp("Integer_N",[]),[],[[new Terminal("heltal")]]), new Rule(80, new FunApp("Integer_N",[]),[],[[new Terminal("heltals")]]), new Rule(79, new FunApp("Integer_N",[]),[],[[new Terminal("heltalen")]]), new Rule(78, new FunApp("Integer_N",[]),[],[[new Terminal("heltalens")]]), new Rule(95, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(94, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(39, new FunApp("IndefSgDet",[]),[],[[new Terminal("en")]]), new Rule(46, new FunApp("IndefSgDet",[]),[],[[new Terminal("ett")]]), new Rule(93, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(92, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(26, new FunApp("IndefSgDet",[]),[],[[new Terminal("en")]]), new Rule(31, new FunApp("IndefSgDet",[]),[],[[new Terminal("ett")]]), new Rule(91, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(90, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(89, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(88, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(87, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(86, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(85, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(84, new FunApp("IndefSgDet",[]),[],[[]]), new Rule(95, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(94, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(39, new FunApp("IndefPlDet",[]),[],[[new Terminal("en")]]), new Rule(46, new FunApp("IndefPlDet",[]),[],[[new Terminal("ett")]]), new Rule(93, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(92, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(26, new FunApp("IndefPlDet",[]),[],[[new Terminal("en")]]), new Rule(31, new FunApp("IndefPlDet",[]),[],[[new Terminal("ett")]]), new Rule(91, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(90, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(89, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(88, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(87, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(86, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(85, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(84, new FunApp("IndefPlDet",[]),[],[[]]), new Rule(24, new FunApp("German",[]),[],[[new Terminal("Tyska")]]), new Rule(23, new FunApp("German",[]),[],[[new Terminal("Tyskas")]]), new Rule(22, new FunApp("German",[]),[],[[new Terminal("Tyskan")]]), new Rule(21, new FunApp("German",[]),[],[[new Terminal("Tyskans")]]), new Rule(20, new FunApp("German",[]),[],[[new Terminal("Tyskor")]]), new Rule(19, new FunApp("German",[]),[],[[new Terminal("Tyskors")]]), new Rule(18, new FunApp("German",[]),[],[[new Terminal("Tyskorna")]]), new Rule(17, new FunApp("German",[]),[],[[new Terminal("Tyskornas")]]), new Rule(24, new FunApp("French",[]),[],[[new Terminal("Franska")]]), new Rule(23, new FunApp("French",[]),[],[[new Terminal("Franskas")]]), new Rule(22, new FunApp("French",[]),[],[[new Terminal("Franskan")]]), new Rule(21, new FunApp("French",[]),[],[[new Terminal("Franskans")]]), new Rule(20, new FunApp("French",[]),[],[[new Terminal("Franskor")]]), new Rule(19, new FunApp("French",[]),[],[[new Terminal("Franskors")]]), new Rule(18, new FunApp("French",[]),[],[[new Terminal("Franskorna")]]), new Rule(17, new FunApp("French",[]),[],[[new Terminal("Franskornas")]]), new Rule(30, new FunApp("Float_N",[]),[],[[new Terminal("flyttal")]]), new Rule(83, new FunApp("Float_N",[]),[],[[new Terminal("flyttals")]]), new Rule(33, new FunApp("Float_N",[]),[],[[new Terminal("flyttalet")]]), new Rule(82, new FunApp("Float_N",[]),[],[[new Terminal("flyttalets")]]), new Rule(81, new FunApp("Float_N",[]),[],[[new Terminal("flyttal")]]), new Rule(80, new FunApp("Float_N",[]),[],[[new Terminal("flyttals")]]), new Rule(79, new FunApp("Float_N",[]),[],[[new Terminal("flyttalen")]]), new Rule(78, new FunApp("Float_N",[]),[],[[new Terminal("flyttalens")]]), new Rule(24, new FunApp("Finnish",[]),[],[[new Terminal("Finska")]]), new Rule(23, new FunApp("Finnish",[]),[],[[new Terminal("Finskas")]]), new Rule(22, new FunApp("Finnish",[]),[],[[new Terminal("Finskan")]]), new Rule(21, new FunApp("Finnish",[]),[],[[new Terminal("Finskans")]]), new Rule(20, new FunApp("Finnish",[]),[],[[new Terminal("Finskor")]]), new Rule(19, new FunApp("Finnish",[]),[],[[new Terminal("Finskors")]]), new Rule(18, new FunApp("Finnish",[]),[],[[new Terminal("Finskorna")]]), new Rule(17, new FunApp("Finnish",[]),[],[[new Terminal("Finskornas")]]), new Rule(25, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[44, 30],[[new Terminal("det"), new Terminal("finns"), new Terminal("inte"), new Terminal("ett"), new ArgProj(0, 0), new ArgProj(1, 0)]]), new Rule(25, new FunApp("ErrorMessage",[new Arg(0), new Arg(1)]),[37, 24],[[new Terminal("det"), new Terminal("finns"), new Terminal("inte"), new Terminal("en"), new ArgProj(0, 0), new ArgProj(1, 0)]]), new Rule(65, new FunApp("Enter",[]),[],[[new Terminal("Skriver")]]), new Rule(64, new FunApp("Enter",[]),[],[[new Terminal("Skrivs")]]), new Rule(63, new FunApp("Enter",[]),[],[[new Terminal("Skriv")]]), new Rule(62, new FunApp("Enter",[]),[],[[new Terminal("Skrivs")]]), new Rule(61, new FunApp("Enter",[]),[],[[new Terminal("Skriva")]]), new Rule(60, new FunApp("Enter",[]),[],[[new Terminal("Skrivas")]]), new Rule(59, new FunApp("Enter",[]),[],[[new Terminal("Skrivd")]]), new Rule(58, new FunApp("Enter",[]),[],[[new Terminal("Skrivds")]]), new Rule(57, new FunApp("Enter",[]),[],[[new Terminal("Skrivt")]]), new Rule(56, new FunApp("Enter",[]),[],[[new Terminal("Skrivts")]]), new Rule(55, new FunApp("Enter",[]),[],[[new Terminal("Skrivda")]]), new Rule(54, new FunApp("Enter",[]),[],[[new Terminal("Skrivdas")]]), new Rule(53, new FunApp("Enter",[]),[],[[new Terminal("Skrivda")]]), new Rule(52, new FunApp("Enter",[]),[],[[new Terminal("Skrivdas")]]), new Rule(51, new FunApp("Enter",[]),[],[[new Terminal("Skrivda")]]), new Rule(50, new FunApp("Enter",[]),[],[[new Terminal("Skrivdas")]]), new Rule(49, new FunApp("Enter",[]),[],[[]]), new Rule(24, new FunApp("English",[]),[],[[new Terminal("Engelska")]]), new Rule(23, new FunApp("English",[]),[],[[new Terminal("Engelskas")]]), new Rule(22, new FunApp("English",[]),[],[[new Terminal("Engelskan")]]), new Rule(21, new FunApp("English",[]),[],[[new Terminal("Engelskans")]]), new Rule(20, new FunApp("English",[]),[],[[new Terminal("Engelskor")]]), new Rule(19, new FunApp("English",[]),[],[[new Terminal("Engelskors")]]), new Rule(18, new FunApp("English",[]),[],[[new Terminal("Engelskorna")]]), new Rule(17, new FunApp("English",[]),[],[[new Terminal("Engelskornas")]]), new Rule(65, new FunApp("Delete",[]),[],[[new Terminal("Raderar")]]), new Rule(64, new FunApp("Delete",[]),[],[[new Terminal("Raderas")]]), new Rule(63, new FunApp("Delete",[]),[],[[new Terminal("Radera")]]), new Rule(62, new FunApp("Delete",[]),[],[[new Terminal("Raderas")]]), new Rule(61, new FunApp("Delete",[]),[],[[new Terminal("Radera")]]), new Rule(60, new FunApp("Delete",[]),[],[[new Terminal("Raderas")]]), new Rule(59, new FunApp("Delete",[]),[],[[new Terminal("Raderad")]]), new Rule(58, new FunApp("Delete",[]),[],[[new Terminal("Raderads")]]), new Rule(57, new FunApp("Delete",[]),[],[[new Terminal("Raderat")]]), new Rule(56, new FunApp("Delete",[]),[],[[new Terminal("Raderats")]]), new Rule(55, new FunApp("Delete",[]),[],[[new Terminal("Raderade")]]), new Rule(54, new FunApp("Delete",[]),[],[[new Terminal("Raderades")]]), new Rule(53, new FunApp("Delete",[]),[],[[new Terminal("Raderade")]]), new Rule(52, new FunApp("Delete",[]),[],[[new Terminal("Raderades")]]), new Rule(51, new FunApp("Delete",[]),[],[[new Terminal("Raderade")]]), new Rule(50, new FunApp("Delete",[]),[],[[new Terminal("Raderades")]]), new Rule(49, new FunApp("Delete",[]),[],[[]]), new Rule(77, new FunApp("DefSgDet",[]),[],[[new Terminal("den")]]), new Rule(76, new FunApp("DefSgDet",[]),[],[[new Terminal("det")]]), new Rule(43, new FunApp("DefSgDet",[]),[],[[new Terminal("den")]]), new Rule(48, new FunApp("DefSgDet",[]),[],[[new Terminal("det")]]), new Rule(75, new FunApp("DefSgDet",[]),[],[[new Terminal("den")]]), new Rule(74, new FunApp("DefSgDet",[]),[],[[new Terminal("det")]]), new Rule(29, new FunApp("DefSgDet",[]),[],[[]]), new Rule(34, new FunApp("DefSgDet",[]),[],[[]]), new Rule(73, new FunApp("DefSgDet",[]),[],[[new Terminal("de")]]), new Rule(72, new FunApp("DefSgDet",[]),[],[[new Terminal("de")]]), new Rule(71, new FunApp("DefSgDet",[]),[],[[new Terminal("de")]]), new Rule(70, new FunApp("DefSgDet",[]),[],[[new Terminal("de")]]), new Rule(69, new FunApp("DefSgDet",[]),[],[[new Terminal("de")]]), new Rule(68, new FunApp("DefSgDet",[]),[],[[new Terminal("de")]]), new Rule(67, new FunApp("DefSgDet",[]),[],[[]]), new Rule(66, new FunApp("DefSgDet",[]),[],[[]]), new Rule(77, new FunApp("DefPlDet",[]),[],[[new Terminal("den")]]), new Rule(76, new FunApp("DefPlDet",[]),[],[[new Terminal("det")]]), new Rule(43, new FunApp("DefPlDet",[]),[],[[new Terminal("den")]]), new Rule(48, new FunApp("DefPlDet",[]),[],[[new Terminal("det")]]), new Rule(75, new FunApp("DefPlDet",[]),[],[[new Terminal("den")]]), new Rule(74, new FunApp("DefPlDet",[]),[],[[new Terminal("det")]]), new Rule(29, new FunApp("DefPlDet",[]),[],[[]]), new Rule(34, new FunApp("DefPlDet",[]),[],[[]]), new Rule(73, new FunApp("DefPlDet",[]),[],[[new Terminal("de")]]), new Rule(72, new FunApp("DefPlDet",[]),[],[[new Terminal("de")]]), new Rule(71, new FunApp("DefPlDet",[]),[],[[new Terminal("de")]]), new Rule(70, new FunApp("DefPlDet",[]),[],[[new Terminal("de")]]), new Rule(69, new FunApp("DefPlDet",[]),[],[[new Terminal("de")]]), new Rule(68, new FunApp("DefPlDet",[]),[],[[new Terminal("de")]]), new Rule(67, new FunApp("DefPlDet",[]),[],[[]]), new Rule(66, new FunApp("DefPlDet",[]),[],[[]]), new Rule(24, new FunApp("Danish",[]),[],[[new Terminal("Danska")]]), new Rule(23, new FunApp("Danish",[]),[],[[new Terminal("Danskas")]]), new Rule(22, new FunApp("Danish",[]),[],[[new Terminal("Danskan")]]), new Rule(21, new FunApp("Danish",[]),[],[[new Terminal("Danskans")]]), new Rule(20, new FunApp("Danish",[]),[],[[new Terminal("Danskor")]]), new Rule(19, new FunApp("Danish",[]),[],[[new Terminal("Danskors")]]), new Rule(18, new FunApp("Danish",[]),[],[[new Terminal("Danskorna")]]), new Rule(17, new FunApp("Danish",[]),[],[[new Terminal("Danskornas")]]), new Rule(65, new FunApp("Cut",[]),[],[[new Terminal("Klipper")]]), new Rule(64, new FunApp("Cut",[]),[],[[new Terminal("Klipps")]]), new Rule(63, new FunApp("Cut",[]),[],[[new Terminal("Klipp")]]), new Rule(62, new FunApp("Cut",[]),[],[[new Terminal("Klipps")]]), new Rule(61, new FunApp("Cut",[]),[],[[new Terminal("Klippa")]]), new Rule(60, new FunApp("Cut",[]),[],[[new Terminal("Klippas")]]), new Rule(59, new FunApp("Cut",[]),[],[[new Terminal("Klippt")]]), new Rule(58, new FunApp("Cut",[]),[],[[new Terminal("Klippts")]]), new Rule(57, new FunApp("Cut",[]),[],[[new Terminal("Klippt")]]), new Rule(56, new FunApp("Cut",[]),[],[[new Terminal("Klippts")]]), new Rule(55, new FunApp("Cut",[]),[],[[new Terminal("Klippta")]]), new Rule(54, new FunApp("Cut",[]),[],[[new Terminal("Klipptas")]]), new Rule(53, new FunApp("Cut",[]),[],[[new Terminal("Klippta")]]), new Rule(52, new FunApp("Cut",[]),[],[[new Terminal("Klipptas")]]), new Rule(51, new FunApp("Cut",[]),[],[[new Terminal("Klippta")]]), new Rule(50, new FunApp("Cut",[]),[],[[new Terminal("Klipptas")]]), new Rule(49, new FunApp("Cut",[]),[],[[new Terminal("ut")]]), new Rule(65, new FunApp("Copy",[]),[],[[new Terminal("Kopierar")]]), new Rule(64, new FunApp("Copy",[]),[],[[new Terminal("Kopieras")]]), new Rule(63, new FunApp("Copy",[]),[],[[new Terminal("Kopiera")]]), new Rule(62, new FunApp("Copy",[]),[],[[new Terminal("Kopieras")]]), new Rule(61, new FunApp("Copy",[]),[],[[new Terminal("Kopiera")]]), new Rule(60, new FunApp("Copy",[]),[],[[new Terminal("Kopieras")]]), new Rule(59, new FunApp("Copy",[]),[],[[new Terminal("Kopierad")]]), new Rule(58, new FunApp("Copy",[]),[],[[new Terminal("Kopierads")]]), new Rule(57, new FunApp("Copy",[]),[],[[new Terminal("Kopierat")]]), new Rule(56, new FunApp("Copy",[]),[],[[new Terminal("Kopierats")]]), new Rule(55, new FunApp("Copy",[]),[],[[new Terminal("Kopierade")]]), new Rule(54, new FunApp("Copy",[]),[],[[new Terminal("Kopierades")]]), new Rule(53, new FunApp("Copy",[]),[],[[new Terminal("Kopierade")]]), new Rule(52, new FunApp("Copy",[]),[],[[new Terminal("Kopierades")]]), new Rule(51, new FunApp("Copy",[]),[],[[new Terminal("Kopierade")]]), new Rule(50, new FunApp("Copy",[]),[],[[new Terminal("Kopierades")]]), new Rule(49, new FunApp("Copy",[]),[],[[]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[36, 48, 40, 33],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0), new Terminal("dig")]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[36, 47, 40, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0), new Terminal("dig")]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[36, 46, 44, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0), new Terminal("dig")]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[36, 43, 40, 22],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0), new Terminal("dig")]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[36, 42, 40, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0), new Terminal("dig")]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[36, 39, 37, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0), new Terminal("dig")]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[35, 48, 40, 33],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[35, 47, 40, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[35, 46, 44, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[35, 43, 40, 22],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[35, 42, 40, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[35, 39, 37, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[27, 48, 40, 33],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[27, 47, 40, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[27, 46, 44, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(44, new Arg(0),[14],[[new ArgProj(0, 0)]]), new Rule(44, new Arg(0),[45],[[new ArgProj(0, 0)]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[27, 43, 40, 22],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[27, 42, 40, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(40, new Arg(0),[10],[[new ArgProj(0, 0)]]), new Rule(40, new Arg(0),[41],[[new ArgProj(0, 0)]]), new Rule(25, new FunApp("CommandAdj",[new Arg(0), new Arg(1), new Arg(2), new Arg(3)]),[27, 39, 37, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new ArgProj(3, 0)]]), new Rule(37, new Arg(0),[16],[[new ArgProj(0, 0)]]), new Rule(37, new Arg(0),[38],[[new ArgProj(0, 0)]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[36, 34, 33],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("dig")]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[36, 32, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("dig")]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[36, 31, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("dig")]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[36, 29, 22],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("dig")]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[36, 28, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("dig")]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[36, 26, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0), new Terminal("dig")]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[35, 34, 33],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[35, 32, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[35, 31, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[35, 29, 22],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[35, 28, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[35, 26, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[27, 34, 33],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[27, 32, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[27, 31, 30],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[27, 29, 22],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[27, 28, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(25, new FunApp("Command",[new Arg(0), new Arg(1), new Arg(2)]),[27, 26, 24],[[new ArgProj(0, 1), new ArgProj(0, 0), new ArgProj(1, 0), new ArgProj(2, 0)]]), new Rule(24, new FunApp("Bulgarian",[]),[],[[new Terminal("Bulgariska")]]), new Rule(23, new FunApp("Bulgarian",[]),[],[[new Terminal("Bulgariskas")]]), new Rule(22, new FunApp("Bulgarian",[]),[],[[new Terminal("Bulgariskan")]]), new Rule(21, new FunApp("Bulgarian",[]),[],[[new Terminal("Bulgariskans")]]), new Rule(20, new FunApp("Bulgarian",[]),[],[[new Terminal("Bulgariskor")]]), new Rule(19, new FunApp("Bulgarian",[]),[],[[new Terminal("Bulgariskors")]]), new Rule(18, new FunApp("Bulgarian",[]),[],[[new Terminal("Bulgariskorna")]]), new Rule(17, new FunApp("Bulgarian",[]),[],[[new Terminal("Bulgariskornas")]]), new Rule(16, new FunApp("Available",[]),[],[[new Terminal("tillgänglig")]]), new Rule(15, new FunApp("Available",[]),[],[[new Terminal("tillgängligs")]]), new Rule(14, new FunApp("Available",[]),[],[[new Terminal("tillgängligt")]]), new Rule(13, new FunApp("Available",[]),[],[[new Terminal("tillgängligts")]]), new Rule(12, new FunApp("Available",[]),[],[[new Terminal("tillgängliga")]]), new Rule(11, new FunApp("Available",[]),[],[[new Terminal("tillgängligas")]]), new Rule(10, new FunApp("Available",[]),[],[[new Terminal("tillgängliga")]]), new Rule(9, new FunApp("Available",[]),[],[[new Terminal("tillgängligas")]]), new Rule(8, new FunApp("Available",[]),[],[[new Terminal("tillgängliga")]]), new Rule(7, new FunApp("Available",[]),[],[[new Terminal("tillgängligas")]]), new Rule(6, new FunApp("Available",[]),[],[[new Terminal("tillgängligare")]]), new Rule(5, new FunApp("Available",[]),[],[[new Terminal("tillgängligares")]]), new Rule(4, new FunApp("Available",[]),[],[[new Terminal("tillgängligast")]]), new Rule(3, new FunApp("Available",[]),[],[[new Terminal("tillgängligasts")]]), new Rule(2, new FunApp("Available",[]),[],[[new Terminal("tillgängligaste")]]), new Rule(1, new FunApp("Available",[]),[],[[new Terminal("tillgängligastes")]])],{Adjective:[37, 38, 16, 15, 44, 45, 14, 13, 12, 11, 40, 41, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1], Determiner:[95, 77, 91, 73, 93, 75, 87, 69, 39, 42, 43, 89, 71, 26, 28, 29, 85, 67, 94, 76, 90, 72, 92, 74, 86, 68, 46, 47, 48, 88, 70, 31, 32, 34, 84, 66], Float:[-3], Int:[-2], Noun:[96, 24, 30, 20, 81, 22, 33, 18, 79, 23, 83, 19, 80, 21, 82, 17, 78], Sentence:[25], String:[-1], Verb:[65, 49, 27, 36, 35, 64, 63, 62, 61, 60, 59, 58, 57, 56, 55, 54, 53, 52, 51, 50], _Var:[-4]}))}); diff --git a/src/runtime/javascript/empty.png b/src/runtime/javascript/empty.png new file mode 100644 index 000000000..35d9875df Binary files /dev/null and b/src/runtime/javascript/empty.png differ diff --git a/src/runtime/javascript/gfjseditor.js b/src/runtime/javascript/gfjseditor.js new file mode 100644 index 000000000..5deb86160 --- /dev/null +++ b/src/runtime/javascript/gfjseditor.js @@ -0,0 +1,1267 @@ + +//Variable and Constant definitions + +var expColImg = new Array(2); +expColImg[0] = new Image(12,12); +expColImg[0].src = "minus.png"; +expColImg[1] = new Image(12,12); +expColImg[1].src = "plus.png"; +expColImg[2] = new Image(12,12); +expColImg[2].src = "empty.png"; + +// Grammars +var grammar = undefined; +var editorGrammar = Editor; + +var selectedLanguage = "EditorEng"; +var selectedNode = ""; +var collapseBuffer = new Array(); +var abstractTree = new Fun ("?"); + +var navigationControlString = new Array(); +var undoArray = new Array(); +var redoArray = new Array(); +var clipBoard; +var refPageCounter = 0; + +var stringAbstractTree = undefined; +var myTree = undefined; +var parseTrees = undefined; + +var keys = new Array(); +keys ["Z"] = function() { clickUndo('actUndo'); } +keys ["Y"] = function() { clickRedo('actRedo'); } +keys ["R"] = function() { clickRefine('actRefine'); }; +keys ["V"] = function() { clickPaste('actPaste'); }; +keys ["X"] = function() { clickCut('actCut'); }; +keys ["C"] = function() { clickCopy('actCopy'); }; +keys ["D"] = function() { clickDelete('actDelete'); }; +keys ["E"] = function() { clickReplace('actReplace'); }; +keys ["W"] = function() { clickWrap('actWrap'); }; +keys ["P"] = function() { clickParse('actParse'); }; +keys ["N"] = function() { clickRandomNode('actRandomNode'); }; +keys ["T"] = function() { clickRandomTree('actRandomTree'); }; +keys ["%"] = function() { leftArrowKey(); }; +keys ["&"] = function() { upDownArrowKey(-1); }; +keys ["'"] = function() { rightArrowKey(); }; +keys ["("] = function() { upDownArrowKey( 1); }; +keys ["27"] = function() { clickEsc(); }; + +function state(selectedNode, tree, collapseBuffer) { + this.selectedNode = selectedNode; + this.tree = grammar.abstract.copyTree(tree); + this.collapseBuffer = collapseBuffer; + return this; +} + +function treeNode(name, caption) { + this.name = name; + this.caption = caption; + this.cat = ""; + this.children = new Array(); + this.collapsed = false; + return this; +} + +treeNode.prototype.addChild = function (i, c) { + this.children[i] = c; +} + +treeNode.prototype.hasChildren = function() { + return this.children.length; +} + +/* -------------------------------------------------------------------------- */ +/* ----------------------------- GUI functions ----------------------------- */ +/* -------------------------------------------------------------------------- */ + + +// Creates an instance of the editor and stores it in the given HTML container. +// Previous content is destroyed. +function mkEditor(container, myGrammar) { + grammar = myGrammar; + myTree = treeFromAbstract(grammar.abstract.annotate(abstractTree, grammar.abstract.startcat), "0"); + var holder = document.getElementById(container); + holder.innerHTML = "
"; + nodeClick('0', '?'); +} + +// Generates a tree from the string representation of an abstract tree contained in the element elementToParse +function parseStringTree(elementToParse) { + stringAbstractTree = elementToParse; + abstractTree = grammar.abstract.handleLiterals(grammar.abstract.parseTree(document.getElementById(elementToParse).value, grammar.abstract.startcat)); + myTree = treeFromAbstract(abstractTree, "0"); + nodeClick("0"); +} + +// If a key is pressed and a function assigned to that key, calls the function +function hotKeys(event) { + event = (event) ? event : ((window.event) ? event : null); + if (event) { + var charCode = (event.charCode) ? event.charCode : ((event.which) ? event.which : event.keyCode); + if (keys[String.fromCharCode(charCode).toUpperCase()] && + !event.ctrlKey && !event.altKey && !event.shiftKey && !event.metaKey) { + keys[String.fromCharCode(charCode).toUpperCase()](); + } + else if (keys["" + charCode] && + !event.ctrlKey && !event.altKey && !event.shiftKey && !event.metaKey) { + keys["" + charCode](); + } + else if (charCode >= "96" && charCode <= "105" && + !event.ctrlKey && !event.altKey && !event.shiftKey && !event.metaKey) { + keys["" + (charCode - 96)](); + } + } +} + +// Clears "numeric" hotkeys +function clearHotKeys() { + for (var key in keys) { + if ((parseInt(key) + 1) && (key != "27")) { keys[key] = function() { }; } + } +} + +// Action to be performed when the up/down arrow key is pressed +function upDownArrowKey(pos) { + var nodePos = getNavPos(selectedNode); + if ((nodePos > 0 && pos < 0) || (nodePos < navigationControlString.length - 1 && pos > 0)) { + nodeClick(navigationControlString[nodePos + pos]); + } +} + +// Gets the position of a given node in the navigationControlString +function getNavPos(nodeName) { + for (var i = 0, j = navigationControlString.length; i < j; i++) { + if (navigationControlString[i] == nodeName) { return i; }; + } + return undefined; +} + +// Given a name and a tree, gets the node in the tree with that name +function getNode(nodeName, node) { + if (nodeName == node.name) { + return node; + } + else { + for (var i = 0, j = node.children.length; i < j; i++) { + var found = getNode(nodeName, node.children[i]); + if (found) { return found; } + } + } +} + +// Action to be performed when the left arrow key is pressed +function leftArrowKey() { + var node = getNode(selectedNode, myTree); + if (!node.collapsed && node.hasChildren()) { + signClick(node.name, node.caption); + } + else { + var parentNode = getParent(node.name, myTree); + if (parentNode) { nodeClick(parentNode.name); } + } +} + +// Gets the parent of the selected node +function getParent(nodeName, node) { + if (node.name == nodeName) { + return undefined; + } + else { + for (var i = 0, j = node.children.length; i < j; i++) { + if (node.children[i].name == nodeName) { return node; } + } + for (var i = 0, j = node.children.length; i < j; i++) { + var found = getParent(nodeName, node.children[i]); + if (found) { return found; } + } + } +} + +// Action to be performed when the right arrow key is pressed +function rightArrowKey() { + var node = getNode(selectedNode, myTree); + if (node.collapsed) { + signClick(node.name, node.caption); + } + else { + var firstDescendant = getfirstDescendant(node); + if (firstDescendant) { + nodeClick(firstDescendant.name); + } + } +} + +// Gets the first descendant child of a node +function getfirstDescendant(node) { + if (node.hasChildren() && !node.collapsed) { return node.children[0]; } + return undefined; +} + +// Produces and displays an HTML representation of the tree +function drawTree() { + var frame = document.getElementById("absFrame"); + navigationControlString = new Array(); + frame.innerHTML = "
    " + getTree(myTree, 0) + "
"; + document.getElementById("link" + selectedNode).scrollIntoView(false); +} + +// Produces an HTML representation of the tree +function getTree(tree, level) { + navigationControlString[navigationControlString.length] = tree.name; + var htmlTree = new Array(); + htmlTree.push("
  • "); + if (tree.hasChildren()) { + htmlTree.push(""); + } + else { + htmlTree.push(""); + } + htmlTree.push(""); + if (tree.cat == "String" || tree.cat == "Int" || tree.cat == "Float") { + htmlTree.push(tree.caption.substring(tree.caption.lastIndexOf("_") + 1)); + } else { + htmlTree.push(tree.caption); + } + htmlTree.push(" : ", tree.cat, "
      • "); + if (tree.hasChildren() && !tree.collapsed) { + for (var i = 0, j = tree.children.length; i < j; i++) { + htmlTree.push(getTree(tree.children[i], level + 1)); + } + } + htmlTree.push("
    "); + return htmlTree.join(""); +} + +// Linearizes and displays the abstract tree +function drawLinearizedFrame() { + var frame = document.getElementById("conFrame"); + frame.innerHTML = getLinearizedFrame(); +} + +// Linearizes the abstract tree and returns it in HTML form +function getLinearizedFrame() { + var linearizedFrame = new Array(); + for (var i in grammar.concretes) { + linearizedFrame.push("

    ", i, "

    "); + linearizedFrame.push("

    "); + var tokens = grammar.concretes[i].tagAndLinearize(abstractTree); + for (var j = 0, k = tokens.length; j < k; j++) { + linearizedFrame.push(createLinearized(tokens[j])); + } + linearizedFrame.push("

    "); + } + linearizedFrame.push("

    Abstract

    "); + linearizedFrame.push("

    ", createLinearizedFromAbstract(myTree, "0"), "

    "); + return linearizedFrame.join(""); +} + +// Creates an HTML representation of a linearization of an abstract tree +function createLinearized(token) { + var node = getNode(token.tag, myTree); + var linearized = new Array() + linearized.push(""); } + else { linearized.push(" onclick='nodeClick(\"", node.name, "\");'> ", token, " "); } + return linearized.join(""); +} + +// Creates an HTML representation of the abstract tree +function createLinearizedFromAbstract(node, path, prec) { + var linearized = new Array(); + linearized.push(""); + if (node.children.length) { linearized.push(" ("); } + if (node.cat == "String" || node.cat == "Int" || node.cat == "Float") { + linearized.push(" ", node.caption.substring(node.caption.lastIndexOf("_") + 1), " "); + } else { + linearized.push(" ", node.caption, " "); + } + for (var i = 0, j = node.children.length; i < j; i++) { + linearized.push(createLinearizedFromAbstract(node.children[i], path + "-" + i, 1)); + } + if (node.children.length) { linearized.push(") "); } + linearized.push(""); + return linearized.join(""); +} + +// Expands/Collapses node +function signClick(name, caption) { + myTree = expandCollapse(myTree, name); + nodeClick(name); +} + +// Sets the "collapsed" property of a given node +function expandCollapse(node, name) { + if (node.name == name) { + if (wasCollapsed(node.name)) { removeFromCollapseBuffer(node.name); } + else { collapseBuffer[collapseBuffer.length] = node.name; } + node.collapsed ^= true; + } + else { + for (var i = 0, j = node.children.length; i < j; i++) { + expandCollapse(node.children[i], name); + } + } + return node; +} + +// Checks if a node was collapsed on the previous cycle +function wasCollapsed(nodeName) { + for (var i = 0, j = collapseBuffer.length; i < j; i++) { + if (nodeName == collapseBuffer[i]) { + return true; + } + } + return false; +} + +// Removes a node from the collapseBuffer array +function removeFromCollapseBuffer(nodeName) { + var newBuffer = new Array(); + for (var i = 0, j = collapseBuffer.length; i < j; i++) { + if (nodeName != collapseBuffer[i]) { + newBuffer[newBuffer.length] = collapseBuffer[i]; + } + } + collapseBuffer = newBuffer; +} + +// Selects a node +function nodeClick(name) { + if ((document.getElementById("actRefine") && document.getElementById("actRefine").className == "selected") || + (document.getElementById("actReplace") && document.getElementById("actReplace").className == "selected") || + (document.getElementById("actWrap") && document.getElementById("actWrap").className == "selected") || + (document.getElementById("actTree") && document.getElementById("actTree").className == "selected")) { + return; } + selectedNode = name; + if (stringAbstractTree) { + document.getElementById(stringAbstractTree).value = abstractTree.show(); + } + document.getElementById("actFrame").innerHTML = showActions(); + document.getElementById("refFrame").innerHTML = ""; + document.getElementById("messageFrame").innerHTML = showLanguages(); + document.getElementById(selectedLanguage).className = "selected"; + applyLanguage(); + drawTree(); + drawLinearizedFrame(); +} + +// Shows the available languages for the editor +function showLanguages() { + var languages = new Array(); + languages.push("", + "", + "", + "", + "", + "", + "", + "", + "", + "", + "", + "", + "", + "
    BulgarianDanishEnglishFinnishFrenchGermanItalianNorwegianRussianSpanishSwedish
    "); + return languages.join(""); +} + +// Selects the language to use in the editor +function clickLanguage(lang) { + if (lang) { + var tdsToClear = document.getElementById("languagesTable").getElementsByTagName("td"); + for (var i = 0, j = tdsToClear.length; i < j; i++) { + if (tdsToClear[i].className == "selected") { tdsToClear[i].className = "language"; } + } + document.getElementById(lang).className = "selected"; + selectedLanguage = lang; + applyLanguage(); + } +} + +// Applies a language to the editor +function applyLanguage() { + var langsToLinearize = document.getElementById("languagesTable").getElementsByTagName("td"); + for (var i = 0, j = langsToLinearize.length; i < j; i++) { + var absStr = langsToLinearize[i].getAttribute("title"); + var lin = editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree(absStr, editorGrammar.abstract.startcat)); + lin = lin.substring(0,1).toUpperCase().concat(lin.substring(1)) + if (!langsToLinearize[i].firstChild) { + var txt = document.createTextNode(lin); + langsToLinearize[i].appendChild(txt); + } + else { + langsToLinearize[i].firstChild.nodeValue = lin; + } + } + var actionsToLinearize = document.getElementById("actionsTable").getElementsByTagName("td"); + for (var i = 0, j = actionsToLinearize.length; i < j; i++) { + if (actionsToLinearize[i].className == "action") { + var absStr = actionsToLinearize[i].getAttribute("title"); + var lin = editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree(absStr, editorGrammar.abstract.startcat)); + lin = lin.substring(0,1).toUpperCase().concat(lin.substring(1)) + if (!actionsToLinearize[i].firstChild) { + var txt = document.createTextNode(lin); + actionsToLinearize[i].appendChild(txt); + } + else { + actionsToLinearize[i].firstChild.nodeValue = lin; + } + } + } + var messageToLinearize = document.getElementById("refgenRefRandom"); + if (messageToLinearize) { + var msg = editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree("RandomlyCommand Select IndefSgDet Refinement", editorGrammar.abstract.startcat)); + messageToLinearize.firstChild.firstChild.nodeValue = msg.substring(0,1).toUpperCase().concat(msg.substring(1)); + } + var messageToLinearize = document.getElementById("nextRefsNext"); + if (messageToLinearize) { + var msg = editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree("CommandAdj Show DefSgDet Next Page", editorGrammar.abstract.startcat)); + messageToLinearize.firstChild.firstChild.nodeValue = msg.substring(0,1).toUpperCase().concat(msg.substring(1)); + } + messageToLinearize = document.getElementById("nextRefsPrevious"); + if (messageToLinearize) { + var msg = editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree("CommandAdj Show DefSgDet Previous Page", editorGrammar.abstract.startcat)); + messageToLinearize.firstChild.firstChild.nodeValue = msg.substring(0,1).toUpperCase().concat(msg.substring(1)); + } + var messageToLinearize = document.getElementById("nextWrapsNext"); + if (messageToLinearize) { + var msg = editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree("CommandAdj Show DefSgDet Next Page", editorGrammar.abstract.startcat)); + messageToLinearize.firstChild.firstChild.nodeValue = msg.substring(0,1).toUpperCase().concat(msg.substring(1)); + } + messageToLinearize = document.getElementById("nextWrapsPrevious"); + if (messageToLinearize) { + var msg = editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree("CommandAdj Show DefSgDet Previous Page", editorGrammar.abstract.startcat)); + messageToLinearize.firstChild.firstChild.nodeValue = msg.substring(0,1).toUpperCase().concat(msg.substring(1)); + } +} + +// Shows the available actions for a node +function showActions(caption) { + var node = getNode(selectedNode, myTree); + var abstractNode = getNodeFromAbstract(abstractTree, node.name, "0"); + var actions = new Array(); + actions.push(""); + if (undoArray.length) { + actions.push(createAction("Undo", "action", "SingleWordCommand Undo", "Z")); } + else { actions.push(createAction("Undo", "unavailable", "SingleWordCommand Undo", "Z")); }; + if (redoArray.length) { + actions.push(createAction("Redo", "action", "SingleWordCommand Redo", "Y")); } + else { actions.push(createAction("Redo", "unavailable", "SingleWordCommand Redo", "Y")); } + if (node.caption == "?") { + actions.push(createAction("Cut", "unavailable", "SingleWordCommand Cut", "X")); + actions.push(createAction("Copy", "unavailable", "SingleWordCommand Copy", "C")); + var AbsNodeType = abstractNode.type; + if (clipBoard && (AbsNodeType == grammar.abstract.getCat(clipBoard.name))) { + actions.push(createAction("Paste", "action", "SingleWordCommand Paste", "V")); + } + else { actions.push(createAction("Paste", "unavailable", "SingleWordCommand Paste", "V")); } + actions.push(createAction("Delete", "unavailable", "SingleWordCommand Delete", "D")); + actions.push(createAction("Refine", "action", "SingleWordCommand Refine", "R")); + actions.push(createAction("Replace", "unavailable", "SingleWordCommand Replace", "E")); + actions.push(createAction("Wrap", "unavailable", "SingleWordCommand Wrap", "W")); + for (var i in grammar.concretes) { + if (grammar.concretes[i].parser) { + actions.push(createAction("Parse", "action", "Command Parse IndefSgDet String_N", "P")); + } else { actions.push(createAction("Parse", "unavailable", "Command Parse IndefSgDet String_N", "P")); } + break; + } + } + else if (node.caption) { + actions.push(createAction("Cut", "action", "SingleWordCommand Cut", "X")); + actions.push(createAction("Copy", "action", "SingleWordCommand Copy", "C")); + actions.push(createAction("Paste", "unavailable", "SingleWordCommand Paste", "V")); + actions.push(createAction("Delete", "action", "SingleWordCommand Delete", "D")); + actions.push(createAction("Refine", "unavailable", "SingleWordCommand Refine", "R")); + actions.push(createAction("Replace", "action", "SingleWordCommand Replace", "E")); + actions.push(createAction("Wrap", "action", "SingleWordCommand Wrap", "W")); + actions.push(createAction("Parse", "unavailable", "Command Parse IndefSgDet String_N", "P")); + } + if (node && !abstractNode.isComplete()) { + actions.push(createAction("RandomNode", "action", "RandomlyCommand Refine DefSgDet Node", "N")); + } + else { + actions.push(createAction("RandomNode", "unavailable", "RandomlyCommand Refine DefSgDet Node", "N")); + } + if (!abstractTree.isComplete()) { + actions.push(createAction("RandomTree", "action", "RandomlyCommand Refine DefSgDet Tree", "T")); + } + else { + actions.push(createAction("RandomTree", "unavailable", "RandomlyCommand Refine DefSgDet Tree", "T")); + } + actions.push("
    "); + return actions.join(""); + +} + +// Creates an action +function createAction(actionName, className, caption, hotKey) { + return "" + caption + "(" + hotKey + ")"; +} + +// When the "Refine" action is selected, gets the appropriate refinements for a node +function clickRefine(actName) { + if (document.getElementById(actName).className == "action") { + highlightSelectedAction(actName); + pushUndoClearRedo(); + if (selectedNode) { + refPageCounter = 0; + var node = getNodeFromAbstract(abstractTree, selectedNode, "0"); + if (node.type == "String" || node.type == "Int" || node.type == "Float") { + var newType = undefined; + var newTypeCat = node.type + "_Literal_"; + switch(node.type) + { + case "String": + var msg = editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree("Command Enter IndefSgDet String_N", editorGrammar.abstract.startcat)); + newType = prompt(msg.substring(0,1).toUpperCase().concat(msg.substring(1)),'String'); + if (!newType) { newType = "AutoString"; } + break; + case "Int": + while (isNaN(newType) || (newType && newType.indexOf(".") != -1)) { + var msg = editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree("Command Enter IndefSgDet Integer_N", editorGrammar.abstract.startcat)); + newType = prompt(msg.substring(0,1).toUpperCase().concat(msg.substring(1)),'Int'); + } + if (!newType) { newType = "8"; } + break; + case "Float": + while (isNaN(newType)) { + var msg = editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree("Command Enter IndefSgDet Float_N", editorGrammar.abstract.startcat)); + newType = prompt(msg.substring(0,1).toUpperCase().concat(msg.substring(1)),'Float'); + } + if (!newType) { newType = "8.0"; } + if (newType.indexOf(".") == -1) { newType += ".0"; } + break; + } + if (node.type == "String") { + newTypeCat += "\"" + newType + "\""; + } else { + newTypeCat += newType; + } + if (!grammar.abstract.types[newTypeCat]) { + grammar.abstract.addType(newTypeCat, [], node.type); + for (var i in grammar.concretes) { + grammar.concretes[i].addRule(newTypeCat, function(cs){ return new Arr(new Str(newType));}); + } + } + node.name = newTypeCat; + abstractTree = insertNode(abstractTree, selectedNode, "0", node); + document.getElementById("actFrame").innerHTML = showActions(); + document.getElementById("refFrame").innerHTML = ""; + clearHotKeys(); + concludeAction(); + } else { + document.getElementById("refFrame").innerHTML = showRefinements(selectedNode); + } + } + } +} + +// Sets the className of actName to "selected" and grays out the other selections +function highlightSelectedAction(actName) { + graySelections(actName); + document.getElementById(actName).className = "selected"; + drawTree(); +} + +// Grays out all actions except one +function graySelections(except) { + var refs = document.getElementById("actFrame").getElementsByTagName("tr"); + for (var i = 0, j = refs.length; i < j; i++) { + if (refs[i].id != except) { refs[i].className = "closed"; } + } +} + +// Pushes the abstract tree into the undo array and clears the redo array +function pushUndoClearRedo() { + undoArray.push(new state(selectedNode, abstractTree, collapseBuffer)); + redoArray.length = 0; +} + +// Gets the refinements to display +function showRefinements(nodeName) { + var refs = getAvailableRefinements(nodeName, abstractTree, grammar); + var rowsPerPage = 9; + var pages = Math.floor(refs.length / rowsPerPage); + var upperLimit; + if (pages != refPageCounter) { upperLimit = (rowsPerPage * refPageCounter) + rowsPerPage; } + else { upperLimit = refs.length; } + var refinements = new Array(); + refinements.push(""); + var keyPos = 0; + refinements.push(ref_wrapToHtml("ref", "genRefRandom", "refinement", "", keyPos, "RandomlyCommand Select IndefSgDet Refinement")); + keys["" + keyPos] = mkRefHotKey("genRefRandom"); + keyPos++; + for (var i = (rowsPerPage * refPageCounter), j = upperLimit; i < j; i++) { + refinements.push(ref_wrapToHtml("ref", refs[i], "refinement", "", keyPos, "")); + keys["" + keyPos] = mkRefHotKey(refs[i]); + keyPos++; + } + if (((refs.length % rowsPerPage == 0) && (pages - 1) > refPageCounter) || + ((refs.length % rowsPerPage != 0) && pages > refPageCounter) ) { + refinements.push(ref_wrapNextRefsToHtml("nextRefs", "Next", "refinement", "+", editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree("CommandAdj Show DefSgDet Next Page", editorGrammar.abstract.startcat)))); + keys["107"] = mkRefNextRefsHotKey("Next"); + } + if (0 < refPageCounter) { + refinements.push(ref_wrapNextRefsToHtml("nextRefs", "Previous", "refinement", "-", editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree("CommandAdj Show DefSgDet Previous Page", editorGrammar.abstract.startcat)))); + keys["109"] = mkRefNextRefsHotKey("Previous"); + } + refinements.push("
    "); + return refinements.join(""); +} + +// Creates an HTML representation of a Refinement/Wrap +function ref_wrapToHtml(funct, name, className, arg, hotKeyPos, caption) { + var ref_wrapHtml = new Array(); + ref_wrapHtml.push(""); + if (caption) { ref_wrapHtml.push(editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree(caption, editorGrammar.abstract.startcat))); } + else { ref_wrapHtml.push(name, " : ", refArgsToHtml(name), grammar.abstract.getCat(name)); } + ref_wrapHtml.push("(", hotKeyPos, ")"); + return ref_wrapHtml.join(""); +} + +// Creates the function to be used by a "numeric" hot key +function mkRefHotKey(refName) { + return function() { if (document.getElementById("ref" + refName)) { refClick(refName); } } +} + +// Creates an HTML representation of the Next/Previous Refinement/Wrap page +function ref_wrapNextRefsToHtml(funct, name, className, hotKeyPos, caption) { + var ref_wrapHtml = new Array(); + ref_wrapHtml.push(""); + ref_wrapHtml.push(caption); + ref_wrapHtml.push("(", hotKeyPos, ")"); + return ref_wrapHtml.join(""); +} + +// Creates the function to be used by a "+"/"-" hot key +function mkRefNextRefsHotKey(refName) { + return function() { if (document.getElementById("nextRefs" + refName)) { nextRefsClick(refName); } } +} + +// Creates a string representation of the arguments of a refinement +function refArgsToHtml(fun) { + var args = new Array(); + for (var i = 0, j = grammar.abstract.types[fun].args.length; i < j; i++) { + args.push(grammar.abstract.types[fun].args[i], " -> "); + } + return args.join(""); +} + +// Gets the type of a meta variable +function getMetaType(absNode, route, currRoute) { + if (route == currRoute && absNode.isMeta()) { + return absNode.type; + } + else { + for (var i = 0, j = absNode.args.length; i < j; i++) { + var found = getMetaType(absNode.args[i], route, currRoute + "-" + i); + if (found) { return found }; + } + } +} + +// When the "Undo" action is selected, undoes the last action +function clickUndo(actName) { + if (document.getElementById(actName).className == "action" && undoArray.length) { + highlightSelectedAction(actName); + redoArray.push(new state(selectedNode, abstractTree, collapseBuffer)); + var prevState = undoArray.pop(); + selectedNode = prevState.selectedNode; + abstractTree = grammar.abstract.copyTree(prevState.tree); + collapseBuffer = prevState.collapseBuffer; + if (abstractTree.isComplete()) { selectedNode = "0"; } + abstractTree = grammar.abstract.annotate(abstractTree, grammar.abstract.startcat); + myTree = treeFromAbstract(abstractTree, "0"); + nodeClick(selectedNode); + } +} + +// When the "Redo" action is selected, redoes the last action +function clickRedo(actName) { + if (document.getElementById(actName).className == "action" && redoArray.length) { + highlightSelectedAction(actName); + undoArray.push(new state(selectedNode, abstractTree, collapseBuffer)); + var nextState = redoArray.pop(); + selectedNode = nextState.selectedNode; + abstractTree = grammar.abstract.copyTree(nextState.tree); + collapseBuffer = nextState.collapseBuffer; + abstractTree = grammar.abstract.annotate(abstractTree, grammar.abstract.startcat); + myTree = treeFromAbstract(abstractTree, "0"); + nodeClick(selectedNode); + } +} + +// When the "Copy" action is selected, copies the selected node to the clipboard +function clickCopy(actName) { + if (document.getElementById(actName).className == "action") { + highlightSelectedAction(actName); + if (selectedNode) { + clipBoard = grammar.abstract.copyTree(getNodeFromAbstract(abstractTree, selectedNode, "0")); + document.getElementById("clipboardFrame").innerHTML = clipBoard.name + " : " + grammar.abstract.getCat(clipBoard.name); + nodeClick(selectedNode); + } + } +} + +// When the "Cut" action is selected, deletes the selected node and copies it to the clipboard +function clickCut(actName) { + if (document.getElementById(actName).className == "action") { + highlightSelectedAction(actName); + pushUndoClearRedo(); + if (selectedNode) { + clipBoard = grammar.abstract.copyTree(getNodeFromAbstract(abstractTree, selectedNode, "0")); + document.getElementById("clipboardFrame").innerHTML = clipBoard.name + " : " + grammar.abstract.getCat(clipBoard.name); + abstractTree = deleteNode(abstractTree, selectedNode, "0"); + concludeAction(); + } + } +} + +// Annotates the abstract tree, creates a tree from the abstract tree and selects the next meta variable +function concludeAction() { + abstractTree = grammar.abstract.annotate(abstractTree, grammar.abstract.startcat); + myTree = treeFromAbstract(abstractTree, "0"); + selectNextMeta(); +} + +// Selects the next meta variable available +function selectNextMeta() { + nodeClick(selectedNode); + if (!abstractTree.isComplete()) { + var pathToNextMeta = ""; + var nodePos = getNavPos(selectedNode); + while (1) { + if (nodePos == navigationControlString.length) { nodePos = 0; } + var node = getNode(navigationControlString[nodePos], myTree); + if (node.caption == "?") { pathToNextMeta = node.name; break; } + nodePos++; + } + expandAscendants(pathToNextMeta); + nodeClick(pathToNextMeta); + } +} + +// Expands the ascendants of a given node +function expandAscendants(nodeName) { + var nodePath = nodeName.split("-"); + var currAscendant = nodePath.shift(); + while (nodePath.length > 0) { + var node = getNode(currAscendant, myTree); + if (node.collapsed) { + myTree = expandCollapse(myTree, currAscendant); + } + currAscendant += "-" + nodePath.shift(); + } +} + +// When the "Paste" action is selected, pastes the contents of the clipboard into the selected node +function clickPaste(actName) { + if (document.getElementById(actName).className == "action") { + highlightSelectedAction(actName); + pushUndoClearRedo(); + if (selectedNode) { + abstractTree = insertNode(abstractTree, selectedNode, "0", grammar.abstract.copyTree(clipBoard)); + concludeAction(); + } + } +} + +// When the "Delete" action is selected, deletes the selected node +function clickDelete(actName) { + if (document.getElementById(actName).className == "action") { + highlightSelectedAction(actName); + pushUndoClearRedo(); + if (selectedNode) { + abstractTree = deleteNode(abstractTree, selectedNode, "0"); + abstractTree = grammar.abstract.annotate(abstractTree, grammar.abstract.startcat); + myTree = treeFromAbstract(abstractTree, "0"); + nodeClick(selectedNode); + } + } +} + +// When the "Replace" action is selected, replaces the selected node with another refinement +function clickReplace(actName) { + if (document.getElementById(actName).className == "action") { + highlightSelectedAction(actName); + pushUndoClearRedo(); + if (selectedNode) { + refPageCounter = 0; + abstractTree = deleteNode(abstractTree, selectedNode, "0"); + abstractTree = grammar.abstract.annotate(abstractTree, grammar.abstract.startcat); + myTree = treeFromAbstract(abstractTree, "0"); + drawTree(); + document.getElementById("refFrame").innerHTML = showRefinements(selectedNode); + } + } +} + +// When the "Wrap" action is selected, wraps around the selected node with another refinement +function clickWrap(actName) { + if (document.getElementById(actName).className == "action") { + highlightSelectedAction(actName); + pushUndoClearRedo(); + var node = getNode(selectedNode, myTree); + if (selectedNode) { + refPageCounter = 0; + var wrappers = showWrappers(node.caption); + document.getElementById("refFrame").innerHTML = wrappers; + if (wrappers.length <= 31) { + var lin = editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree("ErrorMessage Available Wrapper", editorGrammar.abstract.startcat)); + alert(lin.substring(0,1).toUpperCase().concat(lin.substring(1))); + document.getElementById("actFrame").innerHTML = showActions(); + nodeClick(selectedNode); + } + } + } +} + +// Gets the wrappers to display +function showWrappers(nodeCaption) { + var nodeType = grammar.abstract.types[nodeCaption].cat; + var rowsPerPage = 10; + var availWrappers = getAvailableWrappers(nodeType, grammar, selectedNode); + var pages = Math.floor(availWrappers.length / rowsPerPage); + var upperLimit; + if (pages != refPageCounter) { upperLimit = (rowsPerPage * refPageCounter) + rowsPerPage; } + else { upperLimit = availWrappers.length; } + var wrappers = new Array(); + wrappers.push(""); + var keyPos = 0; + for (var i = (rowsPerPage * refPageCounter), j = upperLimit; i < j; i++) { + wrappers.push(ref_wrapToHtml("wrap", availWrappers[i][0], "wrapper", ", " + availWrappers[i][1], keyPos, "")); + keys["" + keyPos] = mkWrapHotKey(availWrappers[i][0], availWrappers[i][1]); + keyPos++; + } + if (((availWrappers.length % rowsPerPage == 0) && (pages - 1) > refPageCounter) || + ((availWrappers.length % rowsPerPage != 0) && pages > refPageCounter) ) { + wrappers.push(ref_wrapNextRefsToHtml("nextWraps", "Next", "wrapper", "+", editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree("CommandAdj Show DefSgDet Next Page", editorGrammar.abstract.startcat)))); + keys["107"] = mkWrapNextRefsHotKey("Next"); + } + if (0 < refPageCounter) { + wrappers.push(ref_wrapNextRefsToHtml("nextWraps", "Previous", "wrapper", "-", editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree("CommandAdj Show DefSgDet Previous Page", editorGrammar.abstract.startcat)))); + keys["109"] = mkWrapNextRefsHotKey("Previous"); + } + wrappers.push("
    "); + return wrappers.join(""); +} + +// Creates the function to be used by a "numeric" hot key +function mkWrapHotKey(wrapName, argPos) { + return function() { if (document.getElementById("wrap" + wrapName)) { wrapClick(wrapName, argPos); } } +} + +// Creates the function to be used by a "+"/"-" hot key +function mkWrapNextRefsHotKey(wrapName) { + return function() { if (document.getElementById("nextWraps" + wrapName)) { nextWrapsClick(wrapName); } } +} + +// When the "Parse" action is selected, asks the user for a string and parses it +// to generate the subnode +function clickParse(actName) { + if (document.getElementById(actName).className == "action") { + highlightSelectedAction(actName); + var node = getNode(selectedNode, myTree); + if (selectedNode) { + refPageCounter = 0; + parseTrees = undefined; + var msg = editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree("Command Enter IndefSgDet String_N", editorGrammar.abstract.startcat)); + var string = prompt(msg.substring(0,1).toUpperCase().concat(msg.substring(1)),'String'); + if (string || string == "") { + for (var i in grammar.concretes) { + parseTrees = grammar.concretes[i].parser.parseString(string, node.cat); + if (parseTrees.length == 1) { + pushUndoClearRedo(); + abstractTree = insertNode(abstractTree, selectedNode, "0", grammar.abstract.copyTree(grammar.abstract.handleLiterals(parseTrees[0], node.cat))); + document.getElementById("actFrame").innerHTML = showActions(); + document.getElementById("refFrame").innerHTML = ""; + clearHotKeys(); + concludeAction(); + return false; + } else if (parseTrees.length > 1) { + document.getElementById("refFrame").innerHTML = showTrees(); + return false; + } + } + } else { nodeClick(selectedNode); return false; } + var lin = editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree("ErrorMessage Available Tree", editorGrammar.abstract.startcat)); + alert(lin.substring(0,1).toUpperCase().concat(lin.substring(1))); + } + nodeClick(selectedNode); + } +} + +// Displays the parse trees in the refinements panel +function showTrees() { + var rowsPerPage = 10; + var pages = Math.floor(parseTrees.length / rowsPerPage); + var upperLimit; + if (pages != refPageCounter) { upperLimit = (rowsPerPage * refPageCounter) + rowsPerPage; } + else { upperLimit = parseTrees.length; } + var htmlTrees = new Array(); + htmlTrees.push(""); + var keyPos = 0; + for (var i = (rowsPerPage * refPageCounter), j = upperLimit; i < j; i++) { + htmlTrees.push(treeToHtml(i, keyPos, "")); + keys["" + keyPos] = mkTreeHotKey(i, keyPos); + keyPos++; + } + if (((parseTrees.length % rowsPerPage == 0) && (pages - 1) > refPageCounter) || + ((parseTrees.length % rowsPerPage != 0) && pages > refPageCounter) ) { + htmlTrees.push(ref_wrapNextRefsToHtml("nextTrees", "Next", "tree", "+", editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree("CommandAdj Show DefSgDet Next Page", editorGrammar.abstract.startcat)))); + keys["107"] = mkTreeNextRefsHotKey("Next"); + } + if (refPageCounter > 0) { + htmlTrees.push(ref_wrapNextRefsToHtml("nextTrees", "Previous", "tree", "-", editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree("CommandAdj Show DefSgDet Previous Page", editorGrammar.abstract.startcat)))); + keys["109"] = mkTreeNextRefsHotKey("Previous"); + } + htmlTrees.push("
    "); + return htmlTrees.join(""); +} + +// Creates an HTML representation of a parse Tree to be shown in the refinements panel +function treeToHtml(i, hotKeyPos, caption) { + var htmlTree = new Array(); + htmlTree.push(""); + if (caption) { htmlTree.push(editorGrammar.concretes[selectedLanguage].linearize(editorGrammar.abstract.parseTree(caption, editorGrammar.abstract.startcat))); } + else { htmlTree.push(parseTrees[i].show()); } + htmlTree.push("(", hotKeyPos, ")"); + return htmlTree.join(""); +} + +// Creates the function to be used by a "numeric" hot key +function mkTreeHotKey(i, keyPos) { + return function() { if (document.getElementById("tree" + keyPos)) { treeClick(i); } } +} + +// Creates the function to be used by a "+"/"-" hot key +function mkTreeNextRefsHotKey(treeName) { + return function() { if (document.getElementById("nextTrees" + treeName)) { nextTreesClick(treeName); } } +} + + +// When the "RandomNode" action is selected, refines the node at random +function clickRandomNode(actName) { + if (document.getElementById(actName).className == "action") { + highlightSelectedAction(actName); + pushUndoClearRedo(); + if (selectedNode) { + var tempTree = grammar.abstract.copyTree(abstractTree); + abstractTree = insertNode(tempTree, selectedNode, "0", grammar.abstract.copyTree(fillSubTree(grammar.abstract.copyTree(getNodeFromAbstract(abstractTree, selectedNode, "0")), grammar))); + concludeAction(); + } + } +} + +// When the "RandomTree" action is selected, refines the tree at random +function clickRandomTree(actName) { + if (document.getElementById(actName).className == "action") { + highlightSelectedAction(actName); + pushUndoClearRedo(); + abstractTree = grammar.abstract.copyTree(fillSubTree(abstractTree, grammar)); + concludeAction(); + } +} + +// If a node is selected and is of type meta, it refines the node with a type refName +function refClick(refName) { + if (selectedNode) { + if (refName == "genRefRandom") { + var refs = getAvailableRefinements(selectedNode, abstractTree, grammar); + refName = refs[Math.floor(refs.length * Math.random())]; + } + abstractTree = refineAbstractTree(abstractTree, selectedNode, "0", refName); + document.getElementById("actFrame").innerHTML = showActions(); + document.getElementById("refFrame").innerHTML = ""; + clearHotKeys(); + concludeAction(); + } +} + +// Creates a tree from an abstract tree +function treeFromAbstract(abstractNode, name) { + var node = new treeNode(name, abstractNode.name); + if (node.caption == "?") { + node.cat = abstractNode.type; } + else { + if (grammar.abstract.types[node.caption]) { + node.cat = grammar.abstract.getCat(node.caption); + } else { + node.cat = node.caption.substring(0, node.caption.indexOf("_")); + grammar.abstract.addType(node.caption, [], node.cat); + var linStr = undefined; + if (node.cat == "String") { + linStr = node.caption.substring(node.caption.indexOf("\"") + 1, node.caption.length - 1); + } else { + linStr = node.caption.substring(node.caption.lastIndexOf("_") + 1) + } + for (var i in grammar.concretes) { + grammar.concretes[i].addRule(node.caption, function(cs){ return new Arr(new Str(linStr));}); + } + } + } + if (wasCollapsed(node.name)) { node.collapsed = true; } + for (var i = 0, j = abstractNode.args.length; i < j; i++) { + node.addChild(i, treeFromAbstract(abstractNode.args[i], name + "-" + i)); + } + return node +} + +// Wraps a refinement around a node +function wrapClick(wrapName, argPos) { + if (selectedNode) { + var tempNode = createRefinement(wrapName); + tempNode.setArg(argPos, grammar.abstract.copyTree(getNodeFromAbstract(abstractTree, selectedNode, "0"))); + abstractTree = insertNode(abstractTree, selectedNode, "0", tempNode); + var cat = grammar.abstract.getCat(tempNode.name); + if (selectedNode == "0" && cat != grammar.abstract.startcat) { + grammar.abstract.startcat = cat; + } + document.getElementById("actFrame").innerHTML = showActions(); + document.getElementById("refFrame").innerHTML = ""; + clearHotKeys(); + concludeAction(); + } +} + +// Wraps a refinement around a node +function treeClick(i) { + if (selectedNode) { + pushUndoClearRedo(); + var node = getNode(selectedNode, myTree); + var tempNode = grammar.abstract.copyTree(grammar.abstract.handleLiterals(parseTrees[i], node.cat)); + abstractTree = insertNode(abstractTree, selectedNode, "0", tempNode); + document.getElementById("actFrame").innerHTML = showActions(); + document.getElementById("refFrame").innerHTML = ""; + clearHotKeys(); + concludeAction(); + } +} + +// Handler for the escape key +function clickEsc() { + if ((document.getElementById("actRefine").className == "selected" || + document.getElementById("actReplace").className == "selected" || + document.getElementById("actWrap").className == "selected" || + document.getElementById("actParse").className == "selected") && undoArray.length) { + var prevState = undoArray.pop(); + selectedNode = prevState.selectedNode; + abstractTree = grammar.abstract.copyTree(prevState.tree); + collapseBuffer = prevState.collapseBuffer; + abstractTree = grammar.abstract.annotate(abstractTree, grammar.abstract.startcat); + myTree = treeFromAbstract(abstractTree, "0"); + document.getElementById("actFrame").innerHTML = showActions(); + if (selectedNode) { nodeClick(selectedNode) } + } +} + +// If there are over ten refinements available shows only the selected nine +function nextRefsClick(refName) { + if (refName == "Next") { refPageCounter++; } else { refPageCounter--; } + clearHotKeys(); + document.getElementById("refFrame").innerHTML = showRefinements(selectedNode); +} + +// If there are over ten wrappers available shows only the selected nine +function nextWrapsClick(wrapName) { + if (wrapName == "Next") { refPageCounter++; } else { refPageCounter--; } + clearHotKeys(); + var node = getNode(selectedNode, myTree); + document.getElementById("refFrame").innerHTML = showWrappers(node.caption); +} + +// If there are over ten parse trees available shows only the selected nine +function nextTreesClick(treeName) { + if (treeName == "Next") { refPageCounter++; } else { refPageCounter--; } + clearHotKeys(); + document.getElementById("refFrame").innerHTML = showTrees(); +} + +/* -------------------------------------------------------------------------- */ +/* ---------- GUI independent functions to handle syntax editing ---------- */ +/* -------------------------------------------------------------------------- */ + +// Gets the node rooted at the indicated path (route) in the tree absNode +function getNodeFromAbstract(absNode, route, currRoute) { + if (route == currRoute) { + return absNode; + } + else { + for (var i = 0, j = absNode.args.length; i < j; i++) { + var found = getNodeFromAbstract(absNode.args[i], route, currRoute + "-" + i); + if (found) { return found; } + } + } +} + +// Gets the first metavariable from the abstract tree rooted at the path route +function getNextMetaFromAbstract(node, route) { + if (node.isMeta()) { return route; } + for (var i = 0, j = node.args.length; i < j; i++) { + var found = getNextMetaFromAbstract(node.args[i], route + "-" + i); + if (found) { return found; } + } +} + +// Inserts the node into the abstract tree absNode at the path route +function insertNode(absNode, route, currRoute, node) { + if (route == currRoute) { + return node; + } + else { + for (var i = 0, j = absNode.args.length; i < j; i++) { + absNode.setArg(i, insertNode(absNode.args[i], route, currRoute + "-" + i, node)); + } + return absNode; + } +} + +// Deletes the node rooted at the path route from the abstract tree absNode +function deleteNode(absNode, route, currRoute) { + if (route == currRoute) { + return new Fun("?"); + } + else { + for (var i = 0, j = absNode.args.length; i < j; i++) { + absNode.setArg(i, deleteNode(absNode.args[i], route, currRoute + "-" + i)); + } + return absNode; + } +} + +// Gets the available refinements for the node nodeName, which is in the tree +// abstractTree, from those found in the grammar. +function getAvailableRefinements(nodeName, abstractTree, grammar) { + var node = getNodeFromAbstract(abstractTree, nodeName, "0"); + var metaType = node.type; + var refinements = new Array(); + for (var fun in grammar.abstract.types) { + if (grammar.abstract.types[fun].cat == metaType) { + refinements[refinements.length] = fun; + } + } + return refinements; +} + +// It refines the node rooted at the path route in the abstract tree absNode +// with the refinement refName. Returns the refined abstract tree. +function refineAbstractTree(absNode, route, currRoute, refName) { + if (route == currRoute && absNode.isMeta()) { + return createRefinement(refName); + } + else { + for (var i = 0, j = absNode.args.length; i < j; i++) { + absNode.setArg(i, refineAbstractTree(absNode.args[i], route, currRoute + "-" + i, refName)); + } + return absNode; + } +} + +// Creates a node of type refName object with the appropriate number of arguments +function createRefinement(refName) { + var newRef = new Fun(refName); + for (var i = 0, j = grammar.abstract.types[refName].args.length; i < j; i++) { + newRef.setArg(i, new Fun("?")); + } + return newRef; +} + +// Gets the available wrappers for a node of type nodeType found in the grammar +function getAvailableWrappers(nodeType, grammar, top) { + var wrappers = new Array(); + for (var fun in grammar.abstract.types) { + for (var i = 0, j = grammar.abstract.types[fun].args.length; i < j; i++) { + if (top != "0") { + if (grammar.abstract.types[fun].args[i] == nodeType && grammar.abstract.types[fun].cat == nodeType) { + wrappers[wrappers.length] = new Array(fun, i); + break; + } + } else { + if (grammar.abstract.types[fun].args[i] == nodeType) { + wrappers[wrappers.length] = new Array(fun, i); + break; + } + } + } + } + return wrappers; +} + +// Instantiates metavariables found in the tree abstractTree with refinements +// selected at random from those found in the grammar +function fillSubTree(abstractTree, grammar) { + while (!abstractTree.isComplete()) { + var nodeToRefine = getNextMetaFromAbstract(abstractTree, "0"); + if (nodeToRefine) { + var refs = getAvailableRefinements(nodeToRefine, abstractTree, grammar); + if (refs.length == 0) { + var node = getNodeFromAbstract(abstractTree, nodeToRefine, "0"); + if (node.type == "String" || node.type == "Int" || node.type == "Float") { + var newType = undefined; + var newTypeCat = node.type + "_Literal_"; + switch(node.type) + { + case "String": + newType = "AutoString"; + break; + case "Int": + newType = "8"; + break; + case "Float": + newType = "8.0"; + break; + } + if (node.type == "String") { + newTypeCat += "\"" + newType + "\""; + } else { + newTypeCat += newType; + } + if (!grammar.abstract.types[newTypeCat]) { + grammar.abstract.addType(newTypeCat, [], node.type); + for (var i in grammar.concretes) { + grammar.concretes[i].addRule(newTypeCat, function(cs){ return new Arr(new Str(newType));}); + } + } + node.name = newTypeCat; + abstractTree = insertNode(abstractTree, nodeToRefine, "0", node); + abstractTree = grammar.abstract.annotate(abstractTree, grammar.abstract.startcat); + } + } + else { + var selectedRef = refs[Math.floor(refs.length * Math.random())]; + abstractTree = refineAbstractTree(abstractTree, nodeToRefine, "0", selectedRef); + abstractTree = grammar.abstract.annotate(abstractTree, grammar.abstract.startcat); + } + } + } + return abstractTree; +} diff --git a/src/runtime/javascript/gflib-xhtml-voice.js b/src/runtime/javascript/gflib-xhtml-voice.js new file mode 100644 index 000000000..fd8660100 --- /dev/null +++ b/src/runtime/javascript/gflib-xhtml-voice.js @@ -0,0 +1,54 @@ +/* Output */ + +function sayText(text) { + document.voice_output_text = text; + activateForm("voice_output"); +} + +/* XHTML+Voice Utilities */ + +function activateForm(formid) { + var form = document.getElementById(formid); + var e = document.createEvent("UIEvents"); + e.initEvent("DOMActivate","true","true"); + form.dispatchEvent(e); +} + + +/* DOM utilities */ + +/* Gets the head element of the document. */ +function getHeadElement() { + var hs = document.getElementsByTagName("head"); + if (hs.length == 0) { + var head = document.createElement("head"); + document.documentElement.insertBefore(head, document.documentElement.firstChild); + return head; + } else { + return hs[0]; + } +} + +/* Gets the body element of the document. */ +function getBodyElement() { + var bs = document.getElementsByTagName("body"); + if (bs.length == 0) { + var body = document.createElement("body"); + document.documentElement.appendChild(body); + return body; + } else { + return bs[0]; + } +} + +/* Removes all the children of a node */ +function removeChildren(node) { + while (node.hasChildNodes()) { + node.removeChild(node.firstChild); + } +} + +function setText(node, text) { + removeChildren(node); + node.appendChild(document.createTextNode(text)); +} diff --git a/src/runtime/javascript/gflib.js b/src/runtime/javascript/gflib.js new file mode 100644 index 000000000..728655469 --- /dev/null +++ b/src/runtime/javascript/gflib.js @@ -0,0 +1,1128 @@ + +function GFGrammar(abstract, concretes) { + this.abstract = abstract; + this.concretes = concretes; +} + +/* Translates a string from any concrete syntax to all concrete syntaxes. + Uses the start category of the grammar. +*/ +GFGrammar.prototype.translate = function (input, fromLang, toLang) { + var outputs = new Object(); + var fromConcs = this.concretes; + if (fromLang) { + fromConcs = new Object(); + fromConcs[fromLang] = this.concretes[fromLang]; + } + var toConcs = this.concretes; + if (toLang) { + toConcs = new Object(); + toConcs[toLang] = this.concretes[toLang]; + } + for (var c1 in fromConcs) { + var p = this.concretes[c1].parser; + if (p) { + var trees = p.parseString(input, this.abstract.startcat); + if (trees.length > 0) { + outputs[c1] = new Array(); + for (var i in trees) { + outputs[c1][i] = new Object(); + for (var c2 in toConcs) { + outputs[c1][i][c2] = this.concretes[c2].linearize(trees[i]); + } + } + } + } + } + return outputs; +} + + +/* ------------------------------------------------------------------------- */ +/* ----------------------------- LINEARIZATION ----------------------------- */ +/* ------------------------------------------------------------------------- */ + +/* Extension to the String object */ + +String.prototype.tag = ""; +String.prototype.setTag = function (tag) { this.tag = tag; }; + +/* Abstract syntax trees */ +function Fun(name) { + this.name = name; + this.args = copy_arguments(arguments, 1); +} +Fun.prototype.print = function () { return this.show(0); } ; +Fun.prototype.show = function (prec) { + if (this.isMeta()) { + if (isUndefined(this.type)) { + return '?'; + } else { + var s = '?:' + this.type; + if (prec > 0) { + s = "(" + s + ")" ; + } + return s; + } + } else { + var s = this.name; + var cs = this.args; + for (var i in cs) { + s += " " + (isUndefined(cs[i]) ? "undefined" : cs[i].show(1)); + } + if (prec > 0 && cs.length > 0) { + s = "(" + s + ")" ; + } + return s; + } +}; +Fun.prototype.getArg = function (i) { + return this.args[i]; +}; +Fun.prototype.setArg = function (i,c) { + this.args[i] = c; +}; +Fun.prototype.isMeta = function() { + return this.name == '?'; +} ; +Fun.prototype.isComplete = function() { + if (this.isMeta()) { + return false; + } else { + for (var i in this.args) { + if (!this.args[i].isComplete()) { + return false; + } + } + return true; + } +} ; +Fun.prototype.isLiteral = function() { + return (/^[\"\d]/).test(this.name); +} ; + +/* Concrete syntax terms */ + +function Arr() { this.arr = copy_arguments(arguments, 0); } +Arr.prototype.tokens = function() { return this.arr[0].tokens(); }; +Arr.prototype.sel = function(i) { return this.arr[i.toIndex()]; }; +Arr.prototype.setTag = function(tag) { + for (var i = 0, j = this.arr.length; i < j; i++) { + this.arr[i].setTag(tag); + } +}; + +function Seq() { this.seq = copy_arguments(arguments, 0); } +Seq.prototype.tokens = function() { + var xs = new Array(); + for (var i in this.seq) { + var ys = this.seq[i].tokens(); + for (var j in ys) { + xs.push(ys[j]); + } + } + return xs; +}; +Seq.prototype.setTag = function(tag) { + for (var i = 0, j = this.seq.length; i < j; i++) { + this.seq[i].setTag(tag); + } +}; + +function Variants() { this.variants = copy_arguments(arguments, 0); } +Variants.prototype.tokens = function() { return this.variants[0].tokens(); }; +Variants.prototype.sel = function(i) { return this.variants[0].sel(i); }; +Variants.prototype.toIndex = function() { return this.variants[0].toIndex(); }; +Variants.prototype.setTag = function(tag) { + for (var i = 0, j = this.variants.length; i < j; i++) { + this.variants[i].setTag(tag); + } +}; + +function Rp(index,value) { this.index = index; this.value = value; } +Rp.prototype.tokens = function() { return new Array(this.index.tokens()); }; +Rp.prototype.sel = function(i) { return this.value.arr[i.toIndex()]; }; +Rp.prototype.toIndex = function() { return this.index.toIndex(); }; +Rp.prototype.setTag = function(tag) { this.index.setTag(tag) }; + +function Suffix(prefix,suffix) { + this.prefix = new String(prefix); + if (prefix.tag) { this.prefix.tag = prefix.tag; } + this.suffix = suffix; +}; +Suffix.prototype.tokens = function() { + var xs = this.suffix.tokens(); + for (var i in xs) { + xs[i] = new String(this.prefix + xs[i]); + xs[i].setTag(this.prefix.tag); + } + return xs; +}; +Suffix.prototype.sel = function(i) { return new Suffix(this.prefix, this.suffix.sel(i)); }; +Suffix.prototype.setTag = function(tag) { if (!this.prefix.tag) { this.prefix.setTag(tag); } }; + +function Meta() { } +Meta.prototype.tokens = function() { + var newString = new String("?"); + newString.setTag(this.tag); + return new Array(newString); +}; +Meta.prototype.toIndex = function() { return 0; }; +Meta.prototype.sel = function(i) { return this; }; +Meta.prototype.setTag = function(tag) { if (!this.tag) { this.tag = tag; } }; + +function Str(value) { this.value = value; } +Str.prototype.tokens = function() { + var newString = new String(this.value); + newString.setTag(this.tag); + return new Array(newString); +}; +Str.prototype.setTag = function(tag) { if (!this.tag) { this.tag = tag; } }; + +function Int(value) { this.value = value; } +Int.prototype.tokens = function() { + var newString = new String(this.value.toString()); + newString.setTag(this.tag); + return new Array(newString); +}; +Int.prototype.toIndex = function() { return this.value; }; +Int.prototype.setTag = function(tag) { if (!this.tag) { this.tag = tag; } }; + +/* Type annotation */ + +function GFAbstract(startcat, types) { + this.startcat = startcat; + this.types = types; +} +GFAbstract.prototype.addType = function(fun, args, cat) { + this.types[fun] = new Type(args, cat); +} ; +GFAbstract.prototype.getArgs = function(fun) { + return this.types[fun].args; +} +GFAbstract.prototype.getCat = function(fun) { + return this.types[fun].cat; +}; +GFAbstract.prototype.annotate = function(tree, type) { + if (tree.name == '?') { + tree.type = type; + } else { + var typ = this.types[tree.name]; + for (var i in tree.args) { + this.annotate(tree.args[i], typ.args[i]); + } + } + return tree; +} ; +GFAbstract.prototype.handleLiterals = function(tree, type) { + if (tree.name != '?') { + if (type == "String" || type == "Int" || type == "Float") { + tree.name = type + "_Literal_" + tree.name; + } else { + var typ = this.types[tree.name]; + for (var i in tree.args) { + this.handleLiterals(tree.args[i], typ.args[i]); + } + } + } + return tree; +} ; +/* Hack to get around the fact that our SISR doesn't build real Fun objects. */ +GFAbstract.prototype.copyTree = function(x) { + var t = new Fun(x.name); + if (!isUndefined(x.type)) { + t.type = x.type; + } + var cs = x.args; + if (!isUndefined(cs)) { + for (var i in cs) { + t.setArg(i, this.copyTree(cs[i])); + } + } + return t; +} ; +GFAbstract.prototype.parseTree = function(str, type) { + return this.annotate(this.parseTree_(str.match(/[\w\'\.\"]+|\(|\)|\?|\:/g), 0), type); +} ; +GFAbstract.prototype.parseTree_ = function(tokens, prec) { + if (tokens.length == 0 || tokens[0] == ")") { return null; } + var t = tokens.shift(); + if (t == "(") { + var tree = this.parseTree_(tokens, 0); + tokens.shift(); + return tree; + } else if (t == '?') { + var tree = this.parseTree_(tokens, 0); + return new Fun('?'); + } else { + var tree = new Fun(t); + if (prec == 0) { + var c, i; + for (i = 0; (c = this.parseTree_(tokens, 1)) !== null; i++) { + tree.setArg(i,c); + } + } + return tree; + } +} ; + +function Type(args, cat) { + this.args = args; + this.cat = cat; +} + +/* Linearization */ + +function GFConcrete(flags, rules, parser) { + this.flags = flags; + this.rules = rules; + if (parser) { + this.parser = parser; + } else { + this.parser = undefined; + } +} +GFConcrete.prototype.rule = function (name, cs) { + var r = this.rules[name]; + if (r) { + return this.rules[name](cs); + } else { + window.alert("Missing rule " + name); + } +}; +GFConcrete.prototype.addRule = function (name, f) { this.rules[name] = f; }; +GFConcrete.prototype.lindef = function (cat, v) { return this.rules[cat]([new Str(v)]); } ; +GFConcrete.prototype.linearize = function (tree) { + return this.unlex(this.linearizeToTerm(tree).tokens()); +}; +GFConcrete.prototype.linearizeToTerm = function (tree) { + if (tree.isMeta()) { + if (isUndefined(tree.type)) { + return new Meta(); + } else { + return this.lindef(tree.type, tree.name); + } + } else { + var cs = new Array(); + for (var i in tree.args) { + cs.push(this.linearizeToTerm(tree.args[i])); + } + if (tree.isLiteral()) { + return new Arr(new Str(tree.name)); + } else { + return this.rule(tree.name, cs); + } + } +}; +GFConcrete.prototype.unlex = function (ts) { + if (ts.length == 0) { + return ""; + } + + var noSpaceAfter = /^[\(\-\[]/; + var noSpaceBefore = /^[\.\,\?\!\)\:\;\-\]]/; + + var s = ""; + for (var i = 0; i < ts.length; i++) { + var t = ts[i]; + var after = i < ts.length-1 ? ts[i+1] : null; + s += t; + if (after != null && !t.match(noSpaceAfter) + && !after.match(noSpaceBefore)) { + s += " "; + } + } + return s; +}; +GFConcrete.prototype.tagAndLinearize = function (tree) { + return this.tagAndLinearizeToTerm(tree, "0").tokens(); +}; +GFConcrete.prototype.tagAndLinearizeToTerm = function (tree, route) { + if (tree.isMeta()) { + if (isUndefined(tree.type)) { + var newMeta = new Meta(); + newMeta.setTag(route); + return newMeta; + } else { + var newTerm = this.lindef(tree.type, tree.name); + newTerm.setTag(route); + return newTerm; + } + } else { + var cs = new Array(); + for (var i in tree.args) { + cs.push(this.tagAndLinearizeToTerm(tree.args[i], route + "-" + i)); + } + var newTerm = this.rule(tree.name, cs); + newTerm.setTag(route); + return newTerm; + } +}; + +/* Utilities */ + +/* from Remedial JavaScript by Douglas Crockford, http://javascript.crockford.com/remedial.html */ +function isString(a) { return typeof a == 'string'; } +function isArray(a) { return a && typeof a == 'object' && a.constructor == Array; } +function isUndefined(a) { return typeof a == 'undefined'; } +function isBoolean(a) { return typeof a == 'boolean'; } +function isNumber(a) { return typeof a == 'number' && isFinite(a); } +function isFunction(a) { return typeof a == 'function'; } + +function dumpObject (obj) { + if (isUndefined(obj)) { + return "undefined"; + } else if (isString(obj)) { + return '"' + obj.toString() + '"'; // FIXME: escape + } else if (isBoolean(obj) || isNumber(obj)) { + return obj.toString(); + } else if (isArray(obj)) { + var x = "["; + for (var i in obj) { + x += dumpObject(obj[i]); + if (i < obj.length-1) { + x += ","; + } + } + return x + "]"; + } else { + var x = "{"; + for (var y in obj) { + x += y + "=" + dumpObject(obj[y]) + ";" ; + } + return x + "}"; + } +} + + +function copy_arguments(args, start) { + var arr = new Array(); + for (var i = 0; i < args.length - start; i++) { + arr[i] = args[i + start]; + } + return arr; +} + +/* ------------------------------------------------------------------------- */ +/* -------------------------------- PARSING -------------------------------- */ +/* ------------------------------------------------------------------------- */ + + +function Parser(startcat, rules, cats) { + this.startcat = startcat; + this.rules = rules; + this.cats = cats; +} +Parser.prototype.showRules = function () { + var ruleStr = new Array(); + ruleStr.push(""); + for (i = 0, j = this.rules.length; i < j; i++) { + ruleStr.push(this.rules[i].show()); + } + return ruleStr.join(""); +}; +Parser.prototype.parseString = function (string, cat) { + var tokens = string.split(" "); + // remove empty tokens + for (var i = tokens.length - 1; i >= 0; i--) { + if (tokens[i] == "") { tokens.splice(i, 1); } + } + chart = new Chart(true); + predict(this.rules, tokens); + while (chart.updated) { + chart.updated = false; + completeAndConvert(); + scan(); + combine(); + } + var catToParse = this.startcat; + if (cat) { catToParse = cat; } + var goalRange = new Range(0, tokens.length); + if (tokens.length == 1 && tokens[0] == "") { goalRange = new EmptyRange(); } + var activeEdges = filterActiveEdges(); + var trees = new Array(); + for (var i = 0, j = this.cats[catToParse].length; i < j; i++) { + if (foundTarget(this.cats[catToParse][i], new Array(new Array(goalRange)))) { + trees = trees.concat(extractTrees(this.cats[catToParse][i], new Array(new Array(goalRange)), activeEdges, "")); + } + } + for (var i = trees.length - 1; i >= 0; i--) { + if (trees[i] == undefined) { trees.splice(i, 1); } + } + return trees; +}; + +// Rule Object Definition + +function Rule(cat, profile, args, linRec) { + this.cat = cat; + this.profile = profile; + this.args = args; + this.linRec = linRec; +} +Rule.prototype.show = function () { + var recStr = new Array(); + recStr.push(this.cat, " -> ", this.profile.show(), " [", this.args, "] = ", showLinRec(this.linRec, "")); + return recStr.join(""); +}; + +// Profile definitions + +// Function application +// The function (name) is applied to its arguments (args) +function FunApp(name, args) { + this.id = "FunApp"; + this.name = name; + this.args = args.slice(0); +} +FunApp.prototype.show = function () { + var funAppStr = new Array(); + funAppStr.push("(", this.name); + for (var i = 0, j = this.args.length; i < j; i++) { + funAppStr.push(this.args[i].show()); + } + funAppStr.push(")"); + return funAppStr.join(" "); +}; + +// Literal +function Lit(name) { + this.id = "Lit"; + this.name = name; +} +Lit.prototype.show = function () { return this.name; }; + +// Metavariable +function MetaVar() { this.id = "MetaVar"; } +MetaVar.prototype.show = function () { return "?"; }; + +// Argument +function Arg(i) { + this.id = "Arg"; + this.name = "_"; + this.i = i; +} +Arg.prototype.show = function () { + var argStr = new Array(); + argStr.push(this.id, "(", this.i, ")"); + return argStr.join(""); +}; + +// Unification +// The arguments (args) must be unified +function Unify(args){ + this.id = "Unify"; + this.args = args.slice(0); +} +Unify.prototype.show = function () { + var unifyStr = new Array(); + unifyStr.push("(", this.id); + for (var i = 0, j = this.args.length; i < j; i++) { + unifyStr.push(this.args[i].show()); + } + unifyStr.push(")"); + return unifyStr.join(" "); +}; + +// Definition of symbols present in linearization records + +// Object to represent argument projections in grammar rules +function ArgProj(i, label) { + this.id = "argProj"; + this.i = i; + this.label = label; +} +ArgProj.prototype.getId = function () { return this.id; }; +ArgProj.prototype.getArgNum = function () { return this.i }; +ArgProj.prototype.show = function () { + var argStr = new Array(); + argStr.push(this.i, this.label); + return argStr.join("."); +}; +ArgProj.prototype.isEqual = function (obj) { + return (this.id == obj.id && this.i == obj.i && this.label == obj.label); +} + +// Object to represent terminals in grammar rules +function Terminal (str) { + this.id = "terminal"; + this.str = str; +} +Terminal.prototype.getId = function () { return this.id; }; +Terminal.prototype.show = function () { + var terminalStr = new Array(); + terminalStr.push('"', this.str, '"'); + return terminalStr.join(""); +}; +Terminal.prototype.isEqual = function (obj) { + return (this.id == obj.id && this.str == obj.str); +} + +// Object to represent ranges in grammar rules +function Range (i, j) { + this.id = "range"; + this.i = i; + this.j = j; +} +Range.prototype.getId = function () { return this.id; }; +Range.prototype.show = function () { + var terminalStr = new Array(); + terminalStr.push("(", this.i, ",", this.j, ")"); + return terminalStr.join(""); +}; +Range.prototype.isEqual = function (obj) { + return (this.id == obj.id && this.i == obj.i && this.j == obj.j); +} + +// Object to represent the empty range in grammar rules +function EmptyRange () { + this.id = "emptyRange"; +} +EmptyRange.prototype.getId = function () { return this.id; }; +EmptyRange.prototype.show = function () { return "emptyRange" }; +EmptyRange.prototype.isEqual = function (obj) { + return (this.id == obj.id); +} + +// Chart Object Definition +function Chart(updated) { + this.passive = new Array(); + this.active = new Array(); + this.updated = updated; +} +Chart.prototype.show = function () { + var chartStr = new Array(); + chartStr.push("(", this.showPassive(), ", ", this.showActive(), ")"); + return chartStr.join(""); +}; +Chart.prototype.addPassiveEdge = function (cat, linRec) { + if (!this.passive[cat] || !this.passive[cat].length) { + this.passive[cat] = new Array(); + } + this.passive[cat].push(linRec); +}; +Chart.prototype.isPassiveElem = function (cat, linRec) { + if (this.passive[cat]) { + for (var i = 0, j = this.passive[cat].length; i < j; i++) { + if (linRecsAreEqual(this.passive[cat][i], linRec)) { + return true; + } + } + } + return false; +}; +Chart.prototype.showPassive = function () { + var edgesStr = new Array(); + edgesStr.push("[ "); + for (var cat in this.passive) { + for (var i = 0, j = this.passive[cat].length; i < j; i++) { + edgesStr.push("( ", cat, ", ", showLinRec(this.passive[cat][i], ""), ")"); + if (i != j - 1) { edgesStr.push(", "); }; + } + edgesStr.push(", "); + } + edgesStr.push(" ]"); + return edgesStr.join(""); + return edgesStr.join("") + "
    "; +}; +Chart.prototype.addActiveEdge = function (cat, edge) { + if (!this.active[cat] || !this.active[cat].length) { + this.active[cat] = new Array(); + } + this.active[cat].push(edge); +}; +Chart.prototype.isActiveElem = function (cat, edge) { + if (this.active[cat]) { + for (var i = 0, j = this.active[cat].length; i < j; i++) { + var currentEdge = this.active[cat][i]; + if (currentEdge.name == edge.name && (areArgsEqual(currentEdge.args, edge.args)) && + currentEdge.currLabel == edge.currLabel && currentEdge.currLin.isEqual(edge.currLin) && + linRecsAreEqual(currentEdge.linFound, edge.linFound) && linRowsAreEqual(currentEdge.remLin, edge.remLin) && + linRecsAreEqual(currentEdge.remLinRows, edge.remLinRows) && + arraysOfLinRecsAreEqual(currentEdge.children, edge.children)) { + return true; + } + } + } + return false; +}; +Chart.prototype.showActive = function () { + var edgesStr = new Array() + edgesStr.push("[ "); + for (var cat in this.active) { + for (var i = 0, j = this.active[cat].length; i < j; i++) { + edgesStr.push("( ", this.active[cat][i].show(), " )"); + if (i != j - 1) { edgesStr.push(", "); }; + } + edgesStr.push(", "); + } + edgesStr.push(" ]"); + return edgesStr.join(""); +}; + +// Object to represent the active edges in a chart +function ActiveEdge(profile, cat, name, args, linFound, currLabel, currLin, remLin, remLinRows, children) { + this.profile = profile; + this.cat = cat; + this.name = name; + this.args = args; + this.linFound = linFound; + this.currLabel = currLabel; + this.currLin = currLin; + this.remLin = remLin; + this.remLinRows = remLinRows; + this.children = children.slice(0); +} +ActiveEdge.prototype.show = function () { + var linRecStr = new Array(); + linRecStr.push(this.profile.show(), ", ", this.cat, ", ", this.name, ", [ ", this.args, " ], ", showLinRec(this.linFound, ""), + ", ", this.currLabel, ", ", this.currLin.show(), ", ", showLinRow(this.remLin, " ++ "), + ", ", showLinRec(this.remLinRows, ""), ", [ "); + for (var i = 0, j = this.children.length; i < j; i++) { + linRecStr.push(showLinRec(this.children[i], "")); + if (i != j - 1) { linRecStr.push(", "); }; + } + linRecStr.push(" ]"); + return linRecStr.join(""); +}; + +function areArgsEqual(args1, args2) { + if (args1.length == args1.length && args1.join() == args2.join()) { + return true + } + return false; +} + +// Functions to manipulate linearization records + +// Returns a string representation of a linearization row +function showLinRow(linRow, separator) { + var linRowStr = new Array(); + linRowStr.push(" [ "); + for (var i = 0, j = linRow.length; i < j; i ++) { + linRowStr.push(linRow[i].show()); + if (i != j - 1) { linRowStr.push(separator) }; + } + linRowStr.push(" ] "); + return linRowStr.join(""); +} + +// Returns a string representation of a linearization record +function showLinRec(linRec, separator) { + var linRecStr = new Array(); + linRecStr.push(" [ "); + for (var i = 0, j = linRec.length; i < j; i ++) { + linRecStr.push(showLinRow(linRec[i], " ++ ")); + if (i != j - 1) { linRecStr.push(separator); }; + } + linRecStr.push(" ] "); + return linRecStr.join(""); +} + +// Checks if two linearization rows are equal +function linRowsAreEqual(linRow1, linRow2) { + if (linRow1.length == linRow2.length) { + for (var i = 0, j = linRow1.length; i < j; i++) { + if (linRow1[i].id && linRow2[i].id && !linRow1[i].isEqual(linRow2[i])) { + return false; + } + } + return true; + } + return false; +} + +// Checks if two linearization records are equal +function linRecsAreEqual(linRec1, linRec2) { + if (linRec1.length == linRec2.length) { + for (var i = 0, j = linRec1.length; i < j; i++) { + if (!linRowsAreEqual(linRec1[i], linRec2[i])) { return false; } + } + return true; + } + return false; +} + +// Checks if two arrays of linearization records are equal +function arraysOfLinRecsAreEqual(array1, array2) { + if (array1.length == array2.length) { + for (var i = 0, j = array1.length; i < j; i++) { + if (!linRecsAreEqual(array1[i], array2[i])) { return false; } + } + return true; + } + return false; +} + +// Functions to manipulate ranges (restriction and concatenation) + +// Concatenates two ranges +function rangeConcatLin (lin1, lin2) { + if (lin1.id == "range" && lin2.id == "range") { + if (lin1.j == lin2.i) { return (new Range(lin1.i, lin2.j)) } + } else if (lin1.id == "range" && lin2.id == "emptyRange") { return lin1; } + else if (lin1.id == "emptyRange" && lin2.id == "range") { return lin2; } + else if (lin1.id == "emptyRange" && lin2.id == "emptyRange") { return lin1; } + return undefined; +} + +// Performs range concatenation on a linearization row +function rangeConcatLins (lins) { + var newLins = new Array(); + newLins.push(lins.shift()); + while (lins.length > 0) { + if (!newLins[newLins.length - 1]) { return new Array(); } + if (newLins[newLins.length - 1].id == "range" && lins[0].id == "range") { + var rangeConcat = rangeConcatLin(newLins.pop(), lins[0]); + if (typeof rangeConcat == 'undefined') { return new Array(); } + newLins.push(rangeConcat); + lins.shift(); + } else { + newLins.push(lins.shift()); + } + } + return newLins; +} + +// Performs range restriction on an element of a linearization row +// while keeping track of the tokens that have been used +function rangeRestLinTerm(tokens, lin, rangesNotConsumed) { + if (lin.id == "argProj") { return new Array(lin); } + else if (lin.id == "terminal") { + var ranges = new Array(); + for (var i = 0, j = tokens.length; i < j; i++) { + if (tokens[i] == lin.str) { + ranges.push(new Range(i, i + 1)); + rangesNotConsumed[i] = undefined; + } + } + if (ranges.length == 0) { + return undefined; + } else { + return ranges; + } + } + else { return new Array(); } +} + +// Performs range restriction on a linearization record +// while keeping track of the tokens that have been used +function rangeRestRecTerm(linRec, tokens, rangesNotConsumed) { + var ranges = new Array(); + for (var i = 0, j = linRec.length; i < j; i++) { + var rangeRestLins = new Array(); + for (var k = 0, l = linRec[i].length; k < l; k++) { + rangeRestLins.push(rangeRestLinTerm(tokens, linRec[i][k], rangesNotConsumed)); + } + var combinedLins = combineLins(rangeRestLins); + if (typeof combinedLins != 'undefined') { + var filteredLins = new Array(); + if (combinedLins.length == 0) { + filteredLins.push(new Array()); + } else { + for (var m = 0, n = combinedLins.length; m < n; m++) { + var temp = rangeConcatLins(combinedLins[m]); + if (temp.length != 0) { + filteredLins.push(temp); + } + } + } + ranges.push(filteredLins); + } else { ranges.push(undefined); } + } + for (var k = 0, l = ranges.length; k < l; k++) { + if (ranges[k] == undefined) { return undefined; } + } + return combineLins(ranges); +} + +// Returns the combinations of the elements of an array of arrays +function combineLins(linss) { + if (linss.length > 0) { + var combinedLins = new Array(); + var lins = linss.shift(); + if (lins) { + if (lins.length != 0) { + var tail = combineLins(linss); + if (typeof tail == 'undefined') { return undefined; } + for (var i = 0, j = lins.length; i < j; i++) { + var head = new Array(); + head.push(lins[i]); + if (tail.length == 0) { combinedLins.push(head); } + else { + for (var k = 0, l = tail.length; k < l; k++) { + combinedLins.push(head.concat(tail[k])); + } + } + } + } else { return new Array(); } + } else { return undefined; } + return combinedLins; + } else { return new Array(); } +} + +// Inference Rules + +function predict(rules, tokens) { + var rangesNotConsumed = genRanges(tokens.length); + for (var i = 0, j = rules.length; i < j; i++) { + var currentRule = rules[i]; + var linRec = rangeRestRecTerm(currentRule.linRec, tokens, rangesNotConsumed); + if (linRec) { + for (var k = 0, l = linRec.length; k < l; k++) { + var currentRow = linRec[k].shift(); + var remlinRows = linRec[k]; + var children = new Array(); + for (var m = 0, n = currentRule.args.length; m < n; m++) { + children.push(new Array()); + } + var newActive = new ActiveEdge(currentRule.profile, currentRule.cat, currentRule.profile.name, currentRule.args, new Array(), 0, new EmptyRange(), currentRow, remlinRows, children); + if (!chart.isActiveElem(currentRule.cat, newActive)) { + chart.addActiveEdge(currentRule.cat, newActive); + chart.updated = true; + } + } + } + } + for (var i = 0, j = rangesNotConsumed.length; i < j; i++) { + if (rangesNotConsumed[i] != undefined) { + var cat = undefined; + if (isNaN(tokens[i])) { + cat = "-1"; + } else if (tokens[i].lastIndexOf(".") == -1) { + cat = "-2"; + } else { + cat = "-3"; + } + var lit = undefined; + if (cat == "-1") { + lit = "\"" + tokens[i] + "\""; + } else { + lit = tokens[i]; + } + var newActive = new ActiveEdge(new Lit(lit), cat, tokens[i], new Array(), new Array(), 0, new Range(i, i + 1), new Array(), new Array(), new Array()); + if (!chart.isActiveElem(cat, newActive)) { + chart.addActiveEdge(cat, newActive); + chart.updated = true; + } + } + } +} + +function genRanges(inputLength) { + var ranges = new Array(); + for (var i = 0; i < inputLength; i++) { + ranges.push(i); + } + return ranges; +} + +function completeAndConvert() { + for (var cat in chart.active) { + var currentEdge = chart.active[cat]; + for (var i = 0, j = currentEdge.length; i < j; i++) { + if (currentEdge[i].remLin.length == 0) { + if (currentEdge[i].remLinRows.length == 0) { + var linFound = currentEdge[i].linFound.slice(0); + linFound.push(new Array(currentEdge[i].currLin)); + if (!chart.isPassiveElem(cat, linFound)) { + chart.addPassiveEdge(cat, linFound); + chart.updated = true; + } + } else { + var linFound = currentEdge[i].linFound.slice(0); + linFound.push(new Array(currentEdge[i].currLin)); + var remLinRows = currentEdge[i].remLinRows.slice(0); + var currentRow = remLinRows.shift(); + var newActive = new ActiveEdge(currentEdge[i].profile, cat, currentEdge[i].name, currentEdge[i].args, linFound, linFound.length, new EmptyRange(), currentRow, remLinRows, currentEdge[i].children); + if (!chart.isActiveElem(cat, newActive)) { + chart.active[cat].push(newActive); + chart.updated = true; + } + } + } + } + } +} + +function scan() { + for (var cat in chart.active) { + var currentEdge = chart.active[cat]; + for (var i = 0, j = currentEdge.length; i < j; i++) { + if (currentEdge[i].remLin.length > 0 && currentEdge[i].remLin[0].id == "range") { + var newRange = rangeConcatLin(currentEdge[i].currLin, currentEdge[i].remLin[0]); + if (typeof newRange != 'undefined') { + var remLin = currentEdge[i].remLin.slice(0); + remLin.shift(); + var newActive = new ActiveEdge(currentEdge[i].profile, cat, currentEdge[i].name, currentEdge[i].args, currentEdge[i].linFound, currentEdge[i].currLabel, newRange, remLin, currentEdge[i].remLinRows, currentEdge[i].children); + if (!chart.isActiveElem(cat, newActive)) { + chart.active[cat].push(newActive); + chart.updated = true; + } + } + } + } + } +} + +function combine() { + for (var cat in chart.active) { + for (var i = 0; i < chart.active[cat].length; i++) { + var currentEdge = chart.active[cat][i]; + if (currentEdge.remLin.length && currentEdge.remLin[0].id == "argProj") { + var argNumber = currentEdge.remLin[0].i; + var catToCombine = currentEdge.args[argNumber]; + if (chart.passive[catToCombine]) { + for (var k = 0, l = chart.passive[catToCombine].length; k < l; k++) { + var currentPassive = chart.passive[catToCombine][k]; + var remLin = currentEdge.remLin.slice(0); + var linRow = currentPassive[remLin[0].label]; + if (typeof linRow != 'undefined') { + var newLinRow = linRow.slice(0); + if (currentEdge.children[argNumber].length == 0) { + var newRange = rangeConcatLin(currentEdge.currLin, newLinRow.shift()); + if (typeof newRange != 'undefined') { + remLin.shift(); + var children = currentEdge.children.slice(0); + children[argNumber] = currentPassive.slice(0); + var newActive = new ActiveEdge(currentEdge.profile, currentEdge.cat, currentEdge.name, currentEdge.args, currentEdge.linFound, currentEdge.currLabel, newRange, remLin, currentEdge.remLinRows, children); + if (!chart.isActiveElem(cat, newActive)) { + chart.active[cat].push(newActive); + chart.updated = true; + } + } + } else { + var child = currentEdge.children[argNumber]; + if (linRecsAreEqual(currentPassive, child)) { + var newRange = rangeConcatLin(currentEdge.currLin, newLinRow.shift()); + if (typeof newRange != 'undefined') { + remLin.shift(); + var children = currentEdge.children.slice(0); + children[argNumber] = currentPassive.slice(0); + var newActive = new ActiveEdge(currentEdge.profile, currentEdge.cat, currentEdge.name, currentEdge.args, currentEdge.linFound, currentEdge.currLabel, newRange, remLin, currentEdge.remLinRows, children); + if (!chart.isActiveElem(cat, newActive)) { + chart.active[cat].push(newActive); + chart.updated = true; + } + } + } + } + } + } + } + } + } + } +} + +// Checks if the parsing goal is in the chart +function foundTarget(cat, linRec) { + if (chart.passive[cat]) { + for (var i = 0, j = chart.passive[cat].length; i < j; i++) { + if (linRecsAreEqual(linRec, chart.passive[cat][i])) { + return true; + } + } + } + return false; +} + +// Filters the active edges that are relevant for tree extraction +function filterActiveEdges() { + var activeEdges = new Array(); + for (var cat in chart.active) { + activeEdges[cat] = new Array(); + for (var i = 0, j = chart.active[cat].length; i < j; i++) { + var currentEdge = chart.active[cat][i]; + if (currentEdge.remLin.length == 0 && currentEdge.remLinRows.length == 0) { + var linFound = currentEdge.linFound.slice(0); + linFound.push(new Array(currentEdge.currLin)); + var newActive = new ActiveEdge(currentEdge.profile, currentEdge.cat, currentEdge.name, currentEdge.args, linFound, "", "", "", "", currentEdge.children); + activeEdges[cat].push(newActive); + } + } + } + return activeEdges; +} + +// Extracts the parse trees from the chart +function extractTrees(cat, linRec, activeEdges, currentTree) { + var trees = new Array(); + for (var i = 0, j = activeEdges[cat].length; i < j; i++) { + var currentEdge = activeEdges[cat][i]; + var currentNode = "(" + cat + "-" + i + ")"; + if (currentTree.indexOf(currentNode) == -1 && cat == currentEdge.cat && linRecsAreEqual(linRec, currentEdge.linFound)) { + var subTrees = new Array(); + for (var k = 0, l = currentEdge.children.length; k < l; k++) { + subTrees.push(extractTrees(currentEdge.args[k], currentEdge.children[k].slice(0), activeEdges, currentTree + currentNode)); + } + var combinedSubTrees = combineLins(subTrees); + if (combinedSubTrees) { + if (currentEdge.children.length == 0) { combinedSubTrees.push(new Array()); } + for (var m = 0, n = combinedSubTrees.length; m < n; m++) { + var tree = buildTree(currentEdge.profile, combinedSubTrees[m]); + if (tree) { + trees.push(tree); + } + } + } + } + } + if (trees.length == 0) { + return undefined; + } else { + return trees; + } +} + +// Builds a tree according to the profile +function buildTree(profile, args) { + switch(profile.id) + { + case "FunApp": + var tree = new Fun(profile.name); + for (var i = 0, j = profile.args.length; i < j; i++) { + var subTree = buildTree(profile.args[i], args); + if (subTree) { + tree.setArg(i, subTree); + } else { + return undefined; + } + } + return tree; + case "Lit": + return new Fun(profile.name); + case "MetaVar": + return new Fun("?"); + case "Arg": + return args[profile.i]; + case "Unify": + var subTrees = new Array(); + for (var i = 0, j = profile.args.length; i < j; i++) { + subTrees.push(buildTree(profile.args[i], args)) + } + return unifySubTrees(subTrees); + } +} + +// Tree unification functions +function unifySubTrees(subTrees) { + var t = subTrees[0]; + for (var i = 1, j = subTrees.length; i < j; i++) { + t = unify(t, subTrees[i]); + if (!t) { return undefined; } + } + return t; +} + +function unify(a, b) { + if (a.isMeta()) { return b }; + if (b.isMeta()) { return a }; + if (a.name == b.name && a.args.length == b.args.length) { + for (var i = 0, j = a.args.length; i < j; i++) { + if (!unify(a.args[i], b.args[i])) { return undefined; } + } + return a + }; + return undefined; +} diff --git a/src/runtime/javascript/grammar.js b/src/runtime/javascript/grammar.js new file mode 100644 index 000000000..69175bba4 --- /dev/null +++ b/src/runtime/javascript/grammar.js @@ -0,0 +1 @@ +var Food = new GFGrammar(new GFAbstract("Phrase",{Boring: new Type([], "Quality"), Cheese: new Type([], "Kind"), Delicious: new Type([], "Quality"), Expensive: new Type([], "Quality"), Fish: new Type([], "Kind"), Fresh: new Type([], "Quality"), Is: new Type(["Item", "Quality"], "Phrase"), Italian: new Type([], "Quality"), QKind: new Type(["Quality", "Kind"], "Kind"), That: new Type(["Kind"], "Item"), This: new Type(["Kind"], "Item"), Very: new Type(["Quality"], "Quality"), Warm: new Type([], "Quality"), Wine: new Type([], "Kind")}),{FoodEng: new GFConcrete({},{Boring: function(cs){return new Arr(new Str("boring"));}, Cheese: function(cs){return new Arr(new Str("cheese"));}, Delicious: function(cs){return new Arr(new Str("delicious"));}, Expensive: function(cs){return new Arr(new Str("expensive"));}, Fish: function(cs){return new Arr(new Str("fish"));}, Fresh: function(cs){return new Arr(new Str("fresh"));}, Is: function(cs){return new Arr(new Seq(cs[0].sel(new Int(0)), new Str("is"), cs[1].sel(new Int(0))));}, Italian: function(cs){return new Arr(new Str("Italian"));}, QKind: function(cs){return new Arr(new Seq(cs[0].sel(new Int(0)), cs[1].sel(new Int(0))));}, That: function(cs){return new Arr(new Seq(new Str("that"), cs[0].sel(new Int(0))));}, This: function(cs){return new Arr(new Seq(new Str("this"), cs[0].sel(new Int(0))));}, Very: function(cs){return new Arr(new Seq(new Str("very"), cs[0].sel(new Int(0))));}, Warm: function(cs){return new Arr(new Str("warm"));}, Wine: function(cs){return new Arr(new Str("wine"));}, Item: function(cs){return new Arr(cs[0]);}, Kind: function(cs){return new Arr(cs[0]);}, Phrase: function(cs){return new Arr(cs[0]);}, Quality: function(cs){return new Arr(cs[0]);}, "Int": function(cs){return new Arr(cs[0]);}, "Float": function(cs){return new Arr(cs[0]);}, "String": function(cs){return new Arr(cs[0]);}}, new Parser("Phrase",[new Rule(1, new FunApp("Boring",[]),[],[[new Terminal("boring")]]), new Rule(1, new FunApp("Delicious",[]),[],[[new Terminal("delicious")]]), new Rule(1, new FunApp("Expensive",[]),[],[[new Terminal("expensive")]]), new Rule(1, new FunApp("Fresh",[]),[],[[new Terminal("fresh")]]), new Rule(1, new FunApp("Italian",[]),[],[[new Terminal("Italian")]]), new Rule(1, new FunApp("Very",[new Arg(0)]),[1],[[new Terminal("very"), new ArgProj(0, 0)]]), new Rule(1, new FunApp("Warm",[]),[],[[new Terminal("warm")]]), new Rule(2, new FunApp("Cheese",[]),[],[[new Terminal("cheese")]]), new Rule(2, new FunApp("Fish",[]),[],[[new Terminal("fish")]]), new Rule(2, new FunApp("QKind",[new Arg(0), new Arg(1)]),[1, 2],[[new ArgProj(0, 0), new ArgProj(1, 0)]]), new Rule(2, new FunApp("Wine",[]),[],[[new Terminal("wine")]]), new Rule(3, new FunApp("Is",[new Arg(0), new Arg(1)]),[4, 1],[[new ArgProj(0, 0), new Terminal("is"), new ArgProj(1, 0)]]), new Rule(4, new FunApp("That",[new Arg(0)]),[2],[[new Terminal("that"), new ArgProj(0, 0)]]), new Rule(4, new FunApp("This",[new Arg(0)]),[2],[[new Terminal("this"), new ArgProj(0, 0)]])],{Float:[-3], Int:[-2], Item:[4], Kind:[2], Phrase:[3], Quality:[1], String:[-1], _Var:[-4]})), FoodIta: new GFConcrete({},{Boring: function(cs){return new Arr(new Str("noioso"));}, Cheese: function(cs){return new Arr(new Str("formaggio"));}, Delicious: function(cs){return new Arr(new Str("delizioso"));}, Expensive: function(cs){return new Arr(new Str("caro"));}, Fish: function(cs){return new Arr(new Str("pesce"));}, Fresh: function(cs){return new Arr(new Str("fresco"));}, Is: function(cs){return new Arr(new Seq(cs[0].sel(new Int(0)), new Str("è"), cs[1].sel(new Int(0))));}, Italian: function(cs){return new Arr(new Str("italiano"));}, QKind: function(cs){return new Arr(new Seq(cs[1].sel(new Int(0)), cs[0].sel(new Int(0))));}, That: function(cs){return new Arr(new Seq(new Str("quel"), cs[0].sel(new Int(0))));}, This: function(cs){return new Arr(new Seq(new Str("questo"), cs[0].sel(new Int(0))));}, Very: function(cs){return new Arr(new Seq(new Str("molto"), cs[0].sel(new Int(0))));}, Warm: function(cs){return new Arr(new Str("caldo"));}, Wine: function(cs){return new Arr(new Str("vino"));}, Item: function(cs){return new Arr(cs[0]);}, Kind: function(cs){return new Arr(cs[0]);}, Phrase: function(cs){return new Arr(cs[0]);}, Quality: function(cs){return new Arr(cs[0]);}, "Int": function(cs){return new Arr(cs[0]);}, "Float": function(cs){return new Arr(cs[0]);}, "String": function(cs){return new Arr(cs[0]);}}, new Parser("Phrase",[new Rule(1, new FunApp("Boring",[]),[],[[new Terminal("noioso")]]), new Rule(1, new FunApp("Delicious",[]),[],[[new Terminal("delizioso")]]), new Rule(1, new FunApp("Expensive",[]),[],[[new Terminal("caro")]]), new Rule(1, new FunApp("Fresh",[]),[],[[new Terminal("fresco")]]), new Rule(1, new FunApp("Italian",[]),[],[[new Terminal("italiano")]]), new Rule(1, new FunApp("Very",[new Arg(0)]),[1],[[new Terminal("molto"), new ArgProj(0, 0)]]), new Rule(1, new FunApp("Warm",[]),[],[[new Terminal("caldo")]]), new Rule(2, new FunApp("Cheese",[]),[],[[new Terminal("formaggio")]]), new Rule(2, new FunApp("Fish",[]),[],[[new Terminal("pesce")]]), new Rule(2, new FunApp("QKind",[new Arg(0), new Arg(1)]),[1, 2],[[new ArgProj(1, 0), new ArgProj(0, 0)]]), new Rule(2, new FunApp("Wine",[]),[],[[new Terminal("vino")]]), new Rule(3, new FunApp("Is",[new Arg(0), new Arg(1)]),[4, 1],[[new ArgProj(0, 0), new Terminal("è"), new ArgProj(1, 0)]]), new Rule(4, new FunApp("That",[new Arg(0)]),[2],[[new Terminal("quel"), new ArgProj(0, 0)]]), new Rule(4, new FunApp("This",[new Arg(0)]),[2],[[new Terminal("questo"), new ArgProj(0, 0)]])],{Float:[-3], Int:[-2], Item:[4], Kind:[2], Phrase:[3], Quality:[1], String:[-1], _Var:[-4]}))}); diff --git a/src/runtime/javascript/minus.png b/src/runtime/javascript/minus.png new file mode 100644 index 000000000..84cc2a9ba Binary files /dev/null and b/src/runtime/javascript/minus.png differ diff --git a/src/runtime/javascript/plus.png b/src/runtime/javascript/plus.png new file mode 100644 index 000000000..4d2e8ee83 Binary files /dev/null and b/src/runtime/javascript/plus.png differ diff --git a/src/runtime/javascript/style.css b/src/runtime/javascript/style.css new file mode 100644 index 000000000..962c3701f --- /dev/null +++ b/src/runtime/javascript/style.css @@ -0,0 +1,241 @@ +body { + font-family:arial,helvetica,sans-serif; + font-size:12px; + background-color: white; +} + +#wrapper { + width:740px; + height:520px; + margin:auto 50px; + border:1px solid gray; + padding:10px; + +} + +#absFrame { + width:250px; + height:250px; + padding:10px; + border:1px solid gray; + float:left; + white-space: nowrap; +} + +#conFrame { + width:436px; + height:250px; + margin-left:10px; + padding:10px; + border:1px solid gray; + float:left; + white-space: normal; + overflow:auto; +} + +#actFrame { + width:250px; + height:170px; + margin-top:10px; + padding:10px; + border:1px solid gray; + float:left; + overflow:auto; +} + +#refFrame { + width:436px; + height:170px; + margin-left:10px; + margin-top:10px; + padding:10px; + border:1px solid gray; + float:left; + overflow:auto; +} + +#messageFrame { + width:506px; + height:15px; + margin-top:10px; + margin-right:10px; + padding:10px; + border:1px solid gray; + float:left; + overflow:hidden; +} + +#clipboardFrame { + width:180px; + height:15px; + margin-top:10px; + padding:10px; + border:1px solid gray; + float:left; + overflow:auto; +} + +#tree { + left: -10px; + top: -10px; + width: 250px; + height: 250px; + margin: 0px; + padding: 10px; + overflow: auto; +} + +ul { + position: relative; + list-style: none; + margin-left: 20px; + padding: 0px; +} + +li { + position: relative; +} + +img.tree-menu { + margin-right: 5px; +} + +a.tree:link, a.tree:visited, a.tree:active { + color: black; + background-color: white; + text-decoration: none; + margin-right:10px; +} + +a.tree:hover { + color: blue; + background-color: white; + text-decoration: underline; + margin-right:10px; +} + +a.treeSelected:link, a.treeSelected:visited, a.treeSelected:active { + color: white; + background-color: #3366CC; + text-decoration: none; + margin-right:10px; +} + +a.treeSelected:hover { + color: white; + background-color: #3366CC; + text-decoration: underline; + margin-right:10px; +} + +a.treeGray:link, a.treeGray:visited, a.treeGray:active { + color: silver; + background-color: white; + text-decoration: none; + margin-right:10px; +} + +a.treeGray:hover { + color: silver; + background-color: white; + text-decoration: none; + margin-right:10px; +} + +table.action, table.refinement, table.wrapper, table.tree, table.language { + margin: 0px; + padding: 0px; + border-style: none; + border-collapse: collapse; + border-spacing: 0px; +} + +tr.selected { + color: white; + background-color: #3366CC; +} + +tr.unavailable, tr.closed { + color: silver; + background-color: white; +} + +tr.unavailable:hover { + color: silver; + background-color: #3366CC; +} + +tr.action, tr.refinement, tr.wrapper, tr.tree { + color: black; + background-color: white; +} + +tr.action:hover, tr.refinement:hover, tr.wrapper:hover, tr.tree:hover { + color: white; + background-color: #3366CC; +} + +td.action { + width: 220px; + margin: 0px; + padding: 0px; +} + +td.refinement, td.wrapper, td.tree { + width: 515px; + margin: 0px; + padding: 0px; +} + +td.hotKey { + width: 30px; + margin: 0px; + padding: 0px; + text-align: right; +} + +td.language { + color: black; + background-color: white; + margin: 1px; + padding: 1px; +} + +td.language:hover { + color: blue; + background-color: white; + text-decoration: underline; + margin: 1px; + padding: 1px; +} + +td.selected { + color: white; + background-color: #3366CC; + margin: 1px; + padding: 1px; +} + +td.selected:hover { + color: white; + background-color: #3366CC; + text-decoration: underline; + margin: 1px; + padding: 1px; +} + +p { + margin-bottom: 40px; +} + +span.normal { + color: black; + background-color: white; + text-decoration: none; +} + +span.selected { + color: white; + background-color: #3366CC; + text-decoration: none; +} diff --git a/src/runtime/javascript/translator.css b/src/runtime/javascript/translator.css new file mode 100644 index 000000000..f7f771927 --- /dev/null +++ b/src/runtime/javascript/translator.css @@ -0,0 +1,54 @@ +body { + color: black; + background-color: white; +} + +dl { + +} + +dt { + margin: 0; + padding: 0; +} + +dl dd { + margin: 0; + padding: 0; +} + +dl.fromLang dt { + display: none; +} + +dl.toLang { + border-width: 1px 0 0 0; + border-style: solid; + border-color: #c0c0c0; +} + +dl.toLang dt { + color: #c0c0c0; + display: block; + float: left; + width: 5em; +} + + +dl.toLang dd { + border-width: 0 0 1px 0; + border-style: solid; + border-color: #c0c0c0; +} + + +ul { + margin: 0; + padding: 0; +} + +li { + list-style-type: none; + margin: 0; + padding: 0; +} \ No newline at end of file diff --git a/src/runtime/javascript/translator.html b/src/runtime/javascript/translator.html new file mode 100644 index 000000000..b6fd37086 --- /dev/null +++ b/src/runtime/javascript/translator.html @@ -0,0 +1,48 @@ + + + + + + + + + + + Web-based GF Translator + + +
    +

    + +

    +

    + From: + To: + +

    +
    +
    + + diff --git a/src/runtime/javascript/translator.js b/src/runtime/javascript/translator.js new file mode 100644 index 000000000..31da04290 --- /dev/null +++ b/src/runtime/javascript/translator.js @@ -0,0 +1,51 @@ +function formatTranslation (outputs) { + var dl1 = document.createElement("dl"); + dl1.className = "fromLang"; + for (var fromLang in outputs) { + var ul = document.createElement("ul"); + addDefinition(dl1, document.createTextNode(fromLang), ul); + for (var i in outputs[fromLang]) { + var dl2 = document.createElement("dl"); + dl2.className = "toLang"; + for (var toLang in outputs[fromLang][i]) { + addDefinition(dl2, document.createTextNode(toLang), document.createTextNode(outputs[fromLang][i][toLang])); + } + addItem(ul, dl2); + } + } + + return dl1; +} + +/* DOM utilities for specific tags */ + +function addDefinition (dl, t, d) { + var dt = document.createElement("dt"); + dt.appendChild(t); + dl.appendChild(dt); + var dd = document.createElement("dd"); + dd.appendChild(d); + dl.appendChild(dd); +} + +function addItem (ul, i) { + var li = document.createElement("li"); + li.appendChild(i); + ul.appendChild(li); +} + +function addOption (select, value, content) { + var option = document.createElement("option"); + option.value = value; + option.appendChild(document.createTextNode(content)); + select.appendChild(option); +} + +/* General DOM utilities */ + +/* Removes all the children of a node */ +function removeChildren(node) { + while (node.hasChildNodes()) { + node.removeChild(node.firstChild); + } +} diff --git a/src/server/Makefile b/src/server/Makefile deleted file mode 100644 index 7dcf29215..000000000 --- a/src/server/Makefile +++ /dev/null @@ -1,59 +0,0 @@ -GFCFLAGS = +RTS -K100M -RTS --cpu - -.PHONY: pgf.fcgi run gwt gf-gwt.jar - -pgf.fcgi: - cabal install - cp dist/build/pgf.fcgi/pgf.fcgi . - -gwt-translate: - chmod a+x gwt/Translate-compile - gwt/Translate-compile - -gwt-fridge: - chmod a+x gwt/Fridge-compile - gwt/Fridge-compile - -gwt-morpho: - chmod a+x gwt/Morpho-compile - gwt/Morpho-compile - -gf-gwt.jar: - mkdir -p gwt/bin/se/chalmers/cs/gf/gwt/client - javac -classpath "$(GWT_CLASSPATH):gwt/lib/gwt-dnd-2.5.6.jar" -sourcepath gwt/src gwt/src/se/chalmers/cs/gf/gwt/client/*.java - jar -cf $@ -C gwt/src se - cp $@ ../../lib/java - -food.pgf: - gfc --make --name=food ../../examples/tutorial/resource-foods/Foods{Eng,Fin,Fre,Ger,Ita,Swe}.gf - -Demo%-parse.pgf: ../../next-lib/src/demo/Demo%.gf - gfc $(GFCFLAGS) --make --erasing=on --name=Demo$*-parse $^ - -Demo%-noparse.pgf: ../../next-lib/src/demo/Demo%.gf - gfc $(GFCFLAGS) --make --parser=off --name=Demo$*-noparse $^ - -Lang%-parse.pgf: ../../next-lib/alltenses/Lang%.gfo - gfc $(GFCFLAGS) --make --erasing=on --name=Lang$*-parse $^ - -Lang%-noparse.pgf: ../../next-lib/alltenses/Lang%.gfo - gfc $(GFCFLAGS) --make --parser=off --name=Lang$*-noparse $^ - -demo.pgf: DemoBul-noparse.pgf DemoCat-noparse.pgf DemoDan-noparse.pgf DemoEng-parse.pgf DemoFin-noparse.pgf DemoFre-noparse.pgf DemoGer-noparse.pgf DemoIta-noparse.pgf DemoNor-noparse.pgf DemoRus-noparse.pgf DemoSpa-noparse.pgf DemoSwe-parse.pgf - gfc $(GFCFLAGS) --name=demo $^ - -lang.pgf: LangBul-noparse.pgf LangCat-noparse.pgf LangDan-parse.pgf LangEng-parse.pgf LangFin-noparse.pgf LangFre-noparse.pgf LangGer-noparse.pgf LangIta-noparse.pgf LangNor-parse.pgf LangRus-noparse.pgf LangSpa-noparse.pgf LangSwe-parse.pgf - gfc $(GFCFLAGS) --name=lang $^ - -test.pgf: LangEng-parse.pgf LangGer-parse.pgf - gfc $(GFCFLAGS) --name=test $^ - -run: pgf.fcgi - @echo '*********************************************' - @echo 'See http://localhost:41296/' - @echo '*********************************************' - lighttpd -f lighttpd.conf -D - -clean: - cabal clean - -rm -f pgf.fcgi \ No newline at end of file diff --git a/src/server/README b/src/server/README deleted file mode 100644 index a22c596f4..000000000 --- a/src/server/README +++ /dev/null @@ -1,132 +0,0 @@ -== Requirements == - -- cabal-install - * See quick installation instructions at the bottom of - http://hackage.haskell.org/trac/hackage/wiki/CabalInstall - -- GF installed as a Cabal package - $ (cd ../.. && cabal install) - -- FastCGI development kit - (MacPorts) $ sudo port install fcgi - (Ubuntu) $ sudo apt-get install libfcgi-dev - -- Google Web Toolkit - - Download from http://code.google.com/webtoolkit/ - - Unpack somewhere. - - Set $GWT_CLASSPATH to point to the GWT JAR files. For example: - $ export GWT_DIR="/Users/bringert/src/gwt-mac-1.5.3" - $ export GWT_CLASSPATH="$GWT_DIR/gwt-user.jar:$GWT_DIR/gwt-dev-mac.jar" - - -== Building == - -- Build pgf.fcgi. This will use cabal to install the dependencies (cgi, fastcgi, json, utf8-string). - $ make - -- Build small example grammar: - $ make food.pgf - $ cp food.pgf grammar.pgf - - -== Running (lighttpd) == - -- Install lighttpd - (MacPorts) $ sudo port install lighttpd - (Ubuntu) $ sudo apt-get install lighttpd - -- Run pgf.fcgi with lighttpd: - $ make run - - -== Testing == - -- First test from the command-line, since debugging is harder from the AJAX UI: - $ curl 'http://localhost:41296/pgf/grammar.pgf/translate?input=this+fish&cat=Item&from=FoodEng' - -- Non-GWT AJAX UI: - See http://localhost:41296/simple-client.html - -- GWT translator: - $ make gwt-translate - Then see http://localhost:41296/translate/ - -- GWT fridge poetry: - $ make gwt-fridge - Then see http://localhost:41296/fridge/ - -- GWT morphology: - $ make gwt-morpho - Then see http://localhost:41296/morpho/ - - The MorphoService.hs module has build-in paths to the grammar that will be loaded. - This have to be fixed by hand - -== Running (Apache) == - -Note: This is more complicated, and the instructions may not be up to date. - -- Make sure that your web server supports FastCGI. For Apache on OS X, - do this: - -$ curl -O http://www.fastcgi.com/dist/mod_fastcgi-2.4.6.tar.gz -$ tar -zxf mod_fastcgi-2.4.6.tar.gz -$ cd mod_fastcgi-2.4.6/ -$ apxs -o mod_fastcgi.so -c *.c -$ sudo apxs -i -a -n fastcgi mod_fastcgi.so - -- Make sure that your web server knows that gf.fcgi is a FastCGI -program. - -- Make sure that you are allowed to run FastCGI programs in the -directory that you use. - -- With large grammars, gf.fcgi may take long enough to start that the web server -thinks that the program has died. With Apache, you can fix this by adding -"FastCgiConfig -startDelay 30" to your httpd.conf. - -These sections from my Apache config fixes the above two -(some of this may be fixed by the second apxs command above): - -(On OS X, this is in /etc/httpd/httpd.conf) - -LoadModule fastcgi_module libexec/httpd/mod_fastcgi.so -AddModule mod_fastcgi.c - - - FastCgiIpcDir /tmp/fcgi_ipc/ - AddHandler fastcgi-script .fcgi - FastCgiConfig -startDelay 30 - - - -(On OS X, this is in /etc/httpd/users/bringert.conf) - - - Options Indexes MultiViews FollowSymlinks ExecCGI - AddHandler cgi-script .cgi - AllowOverride None - Order allow,deny - Allow from all - - -- If you have changed the web server config, you need to restart the web server - (this is also useful to get a clean slate if you end up with dead or resource-hogging - FastCGI processes): - -$ sudo apachectl restart - -- If Apache complains about a syntax error on the FastCgiIpcDir line, try deleting - any existing /tmp/fcgi_ipc/ directory: - -$ sudo rm -rf /tmp/fcgi_ipc/ - -- Copy or symlink this directory to your web directory. - -- First test from the command-line, since debugging is harder from the AJAX UI: - -$ curl 'http://localhost/~bringert/gf-server/gf.fcgi/translate?input=this+fish&cat=Item&from=FoodEng' - -- Check server logs (e.g. /var/log/httpd/error_log) if it doesn't work. - -- Go to SERVER_URL/simple-client.html in your web browser. -- cgit v1.2.3