From b1402e8bd6a68a891b00a214d6cf184d66defe19 Mon Sep 17 00:00:00 2001 From: aarne Date: Mon, 22 Sep 2003 13:16:55 +0000 Subject: [PATCH] Founding the newly structured GF2.0 cvs archive. --- bin/jgf2 | 12 + grammars/logic/Arithm.gf | 63 + grammars/logic/ArithmEng.gf | 40 + grammars/logic/Logic.gf | 82 ++ grammars/logic/LogicEng.gf | 59 + grammars/logic/LogicResEng.gf | 27 + grammars/prelude/Coordination.gf | 105 ++ grammars/prelude/Predef.gf | 25 + grammars/prelude/Prelude.gf | 83 ++ grammars/resource/abstract/Database.gf | 36 + grammars/resource/abstract/PredefAbs.gf | 4 + grammars/resource/abstract/ResAbs.gf | 266 ++++ grammars/resource/abstract/Restaurant.gf | 15 + grammars/resource/abstract/TestAbs.gf | 15 + grammars/resource/english/DatabaseEng.gf | 51 + grammars/resource/english/DatabaseEngRes.gf | 11 + grammars/resource/english/English.gf | 1 + grammars/resource/english/Morpho.gf | 150 ++ grammars/resource/english/Paradigms.gf | 229 +++ grammars/resource/english/Predication.gf | 83 ++ grammars/resource/english/ResEng.gf | 195 +++ grammars/resource/english/RestaurantEng.gf | 25 + grammars/resource/english/Syntax.gf | 848 +++++++++++ grammars/resource/english/TestEng.gf | 36 + grammars/resource/english/Types.gf | 101 ++ grammars/resource/german/DatabaseDeu.gf | 52 + grammars/resource/german/DatabaseRes.gf | 11 + grammars/resource/german/Deutsch.gf | 1 + grammars/resource/german/Logical.gf | 23 + grammars/resource/german/Morpho.gf | 399 ++++++ grammars/resource/german/Paradigms.gf | 300 ++++ grammars/resource/german/Predication.gf | 87 ++ grammars/resource/german/ResDeu.gf | 217 +++ grammars/resource/german/RestaurantDeu.gf | 24 + grammars/resource/german/Syntax.gf | 891 ++++++++++++ grammars/resource/german/TestDeu.gf | 39 + grammars/resource/german/Types.gf | 98 ++ grammars/resource/swedish/Morpho.gf | 1039 ++++++++++++++ grammars/resource/swedish/ResSwe.gf | 196 +++ grammars/resource/swedish/Svenska.gf | 1 + grammars/resource/swedish/Syntax.gf | 1000 +++++++++++++ grammars/resource/swedish/TestSwe.gf | 35 + grammars/resource/swedish/Types.gf | 150 ++ src/GF.hs | 78 + src/GF/API.hs | 267 ++++ src/GF/API/IOGrammar.hs | 42 + src/GF/CF/CF.hs | 180 +++ src/GF/CF/CFIdent.hs | 151 ++ src/GF/CF/CanonToCF.hs | 157 ++ src/GF/CF/ChartParser.hs | 166 +++ src/GF/CF/PPrCF.hs | 59 + src/GF/CF/Profile.hs | 95 ++ src/GF/Canon/AbsGFC.hs | 160 +++ src/GF/Canon/CMacros.hs | 234 +++ src/GF/Canon/CanonToGrammar.hs | 167 +++ src/GF/Canon/GFC.hs | 48 + src/GF/Canon/GetGFC.hs | 22 + src/GF/Canon/LexGFC.hs | 105 ++ src/GF/Canon/Look.hs | 141 ++ src/GF/Canon/MkGFC.hs | 121 ++ src/GF/Canon/PrExp.hs | 36 + src/GF/Canon/PrintGFC.hs | 319 +++++ src/GF/Canon/Share.hs | 116 ++ src/GF/Canon/SkelGFC.hs | 199 +++ src/GF/Canon/TestGFC.hs | 25 + src/GF/Canon/Unlex.hs | 37 + src/GF/Compile/CheckGrammar.hs | 665 +++++++++ src/GF/Compile/Compile.hs | 207 +++ src/GF/Compile/Extend.hs | 77 + src/GF/Compile/GetGrammar.hs | 71 + src/GF/Compile/GrammarToCanon.hs | 224 +++ src/GF/Compile/MkResource.hs | 75 + src/GF/Compile/ModDeps.hs | 88 ++ src/GF/Compile/Optimize.hs | 171 +++ src/GF/Compile/PGrammar.hs | 58 + src/GF/Compile/PrOld.hs | 69 + src/GF/Compile/RemoveLiT.hs | 51 + src/GF/Compile/Rename.hs | 263 ++++ src/GF/Compile/ShellState.hs | 338 +++++ src/GF/Compile/Update.hs | 98 ++ src/GF/Data/ErrM.hs | 7 + src/GF/Data/Operations.hs | 559 ++++++++ src/GF/Data/OrdMap2.hs | 118 ++ src/GF/Data/OrdSet.hs | 111 ++ src/GF/Data/Parsers.hs | 143 ++ src/GF/Data/Str.hs | 106 ++ src/GF/Data/Zipper.hs | 172 +++ src/GF/Fudgets/ArchEdit.hs | 16 + src/GF/Fudgets/CommandF.hs | 120 ++ src/GF/Fudgets/EventF.hs | 36 + src/GF/Fudgets/FudgetOps.hs | 47 + src/GF/Fudgets/UnicodeF.hs | 23 + src/GF/Grammar/AbsCompute.hs | 64 + src/GF/Grammar/Abstract.hs | 24 + src/GF/Grammar/AppPredefined.hs | 51 + src/GF/Grammar/Compute.hs | 238 ++++ src/GF/Grammar/Grammar.hs | 154 ++ src/GF/Grammar/LookAbs.hs | 125 ++ src/GF/Grammar/Lookup.hs | 393 +++++ src/GF/Grammar/MMacros.hs | 261 ++++ src/GF/Grammar/Macros.hs | 634 +++++++++ src/GF/Grammar/PatternMatch.hs | 98 ++ src/GF/Grammar/PrGrammar.hs | 189 +++ src/GF/Grammar/Refresh.hs | 105 ++ src/GF/Grammar/ReservedWords.hs | 32 + src/GF/Grammar/TC.hs | 210 +++ src/GF/Grammar/TypeCheck.hs | 231 +++ src/GF/Grammar/Unify.hs | 84 ++ src/GF/Grammar/Values.hs | 52 + src/GF/Infra/CheckM.hs | 70 + src/GF/Infra/Ident.hs | 117 ++ src/GF/Infra/Modules.hs | 181 +++ src/GF/Infra/Option.hs | 204 +++ src/GF/Infra/ReadFiles.hs | 135 ++ src/GF/Infra/UseIO.hs | 245 ++++ src/GF/Shell.hs | 292 ++++ src/GF/Shell/CommandL.hs | 135 ++ src/GF/Shell/Commands.hs | 443 ++++++ src/GF/Shell/JGF.hs | 59 + src/GF/Shell/PShell.hs | 115 ++ src/GF/Shell/SubShell.hs | 43 + src/GF/Source/AbsGF.hs | 242 ++++ src/GF/Source/CompileM.hs | 141 ++ src/GF/Source/GrammarToSource.hs | 181 +++ src/GF/Source/LexGF.hs | 127 ++ src/GF/Source/PrintGF.hs | 435 ++++++ src/GF/Source/SkelGF.hs | 289 ++++ src/GF/Source/SourceToGrammar.hs | 505 +++++++ src/GF/Source/TestGF.hs | 22 + src/GF/System/Arch.hs | 71 + src/GF/Text/Arabic.hs | 48 + src/GF/Text/Greek.hs | 158 +++ src/GF/Text/Hebrew.hs | 21 + src/GF/Text/Russian.hs | 31 + src/GF/Text/Text.hs | 56 + src/GF/Text/UTF8.hs | 35 + src/GF/Text/Unicode.hs | 24 + src/GF/UseGrammar/Custom.hs | 256 ++++ src/GF/UseGrammar/Editing.hs | 358 +++++ src/GF/UseGrammar/GetTree.hs | 46 + src/GF/UseGrammar/Information.hs | 130 ++ src/GF/UseGrammar/Linear.hs | 195 +++ src/GF/UseGrammar/MoreCustom.hs | 15 + src/GF/UseGrammar/Morphology.hs | 116 ++ src/GF/UseGrammar/Paraphrases.hs | 53 + src/GF/UseGrammar/Parsing.hs | 98 ++ src/GF/UseGrammar/Randomized.hs | 47 + src/GF/UseGrammar/RealMoreCustom.hs | 122 ++ src/GF/UseGrammar/Session.hs | 110 ++ src/GF/UseGrammar/TeachYourself.hs | 69 + src/GF/UseGrammar/Tokenize.hs | 130 ++ src/HelpFile.hs | 376 +++++ src/JavaGUI/DynamicTree.java | 272 ++++ src/JavaGUI/GFEditor.java | 1420 +++++++++++++++++++ src/JavaGUI/GrammarFilter.java | 30 + src/JavaGUI/Utils.java | 22 + src/Makefile | 23 + src/Today.hs | 1 + src/tools/GFDoc.hs | 255 ++++ src/tools/MkHelpFile.hs | 20 + src/tools/MkToday.hs | 15 + src/tools/WriteF.hs | 57 + 162 files changed, 25569 insertions(+) create mode 100644 bin/jgf2 create mode 100644 grammars/logic/Arithm.gf create mode 100644 grammars/logic/ArithmEng.gf create mode 100644 grammars/logic/Logic.gf create mode 100644 grammars/logic/LogicEng.gf create mode 100644 grammars/logic/LogicResEng.gf create mode 100644 grammars/prelude/Coordination.gf create mode 100644 grammars/prelude/Predef.gf create mode 100644 grammars/prelude/Prelude.gf create mode 100644 grammars/resource/abstract/Database.gf create mode 100644 grammars/resource/abstract/PredefAbs.gf create mode 100644 grammars/resource/abstract/ResAbs.gf create mode 100644 grammars/resource/abstract/Restaurant.gf create mode 100644 grammars/resource/abstract/TestAbs.gf create mode 100644 grammars/resource/english/DatabaseEng.gf create mode 100644 grammars/resource/english/DatabaseEngRes.gf create mode 100644 grammars/resource/english/English.gf create mode 100644 grammars/resource/english/Morpho.gf create mode 100644 grammars/resource/english/Paradigms.gf create mode 100644 grammars/resource/english/Predication.gf create mode 100644 grammars/resource/english/ResEng.gf create mode 100644 grammars/resource/english/RestaurantEng.gf create mode 100644 grammars/resource/english/Syntax.gf create mode 100644 grammars/resource/english/TestEng.gf create mode 100644 grammars/resource/english/Types.gf create mode 100644 grammars/resource/german/DatabaseDeu.gf create mode 100644 grammars/resource/german/DatabaseRes.gf create mode 100644 grammars/resource/german/Deutsch.gf create mode 100644 grammars/resource/german/Logical.gf create mode 100644 grammars/resource/german/Morpho.gf create mode 100644 grammars/resource/german/Paradigms.gf create mode 100644 grammars/resource/german/Predication.gf create mode 100644 grammars/resource/german/ResDeu.gf create mode 100644 grammars/resource/german/RestaurantDeu.gf create mode 100644 grammars/resource/german/Syntax.gf create mode 100644 grammars/resource/german/TestDeu.gf create mode 100644 grammars/resource/german/Types.gf create mode 100644 grammars/resource/swedish/Morpho.gf create mode 100644 grammars/resource/swedish/ResSwe.gf create mode 100644 grammars/resource/swedish/Svenska.gf create mode 100644 grammars/resource/swedish/Syntax.gf create mode 100644 grammars/resource/swedish/TestSwe.gf create mode 100644 grammars/resource/swedish/Types.gf create mode 100644 src/GF.hs create mode 100644 src/GF/API.hs create mode 100644 src/GF/API/IOGrammar.hs create mode 100644 src/GF/CF/CF.hs create mode 100644 src/GF/CF/CFIdent.hs create mode 100644 src/GF/CF/CanonToCF.hs create mode 100644 src/GF/CF/ChartParser.hs create mode 100644 src/GF/CF/PPrCF.hs create mode 100644 src/GF/CF/Profile.hs create mode 100644 src/GF/Canon/AbsGFC.hs create mode 100644 src/GF/Canon/CMacros.hs create mode 100644 src/GF/Canon/CanonToGrammar.hs create mode 100644 src/GF/Canon/GFC.hs create mode 100644 src/GF/Canon/GetGFC.hs create mode 100644 src/GF/Canon/LexGFC.hs create mode 100644 src/GF/Canon/Look.hs create mode 100644 src/GF/Canon/MkGFC.hs create mode 100644 src/GF/Canon/PrExp.hs create mode 100644 src/GF/Canon/PrintGFC.hs create mode 100644 src/GF/Canon/Share.hs create mode 100644 src/GF/Canon/SkelGFC.hs create mode 100644 src/GF/Canon/TestGFC.hs create mode 100644 src/GF/Canon/Unlex.hs create mode 100644 src/GF/Compile/CheckGrammar.hs create mode 100644 src/GF/Compile/Compile.hs create mode 100644 src/GF/Compile/Extend.hs create mode 100644 src/GF/Compile/GetGrammar.hs create mode 100644 src/GF/Compile/GrammarToCanon.hs create mode 100644 src/GF/Compile/MkResource.hs create mode 100644 src/GF/Compile/ModDeps.hs create mode 100644 src/GF/Compile/Optimize.hs create mode 100644 src/GF/Compile/PGrammar.hs create mode 100644 src/GF/Compile/PrOld.hs create mode 100644 src/GF/Compile/RemoveLiT.hs create mode 100644 src/GF/Compile/Rename.hs create mode 100644 src/GF/Compile/ShellState.hs create mode 100644 src/GF/Compile/Update.hs create mode 100644 src/GF/Data/ErrM.hs create mode 100644 src/GF/Data/Operations.hs create mode 100644 src/GF/Data/OrdMap2.hs create mode 100644 src/GF/Data/OrdSet.hs create mode 100644 src/GF/Data/Parsers.hs create mode 100644 src/GF/Data/Str.hs create mode 100644 src/GF/Data/Zipper.hs create mode 100644 src/GF/Fudgets/ArchEdit.hs create mode 100644 src/GF/Fudgets/CommandF.hs create mode 100644 src/GF/Fudgets/EventF.hs create mode 100644 src/GF/Fudgets/FudgetOps.hs create mode 100644 src/GF/Fudgets/UnicodeF.hs create mode 100644 src/GF/Grammar/AbsCompute.hs create mode 100644 src/GF/Grammar/Abstract.hs create mode 100644 src/GF/Grammar/AppPredefined.hs create mode 100644 src/GF/Grammar/Compute.hs create mode 100644 src/GF/Grammar/Grammar.hs create mode 100644 src/GF/Grammar/LookAbs.hs create mode 100644 src/GF/Grammar/Lookup.hs create mode 100644 src/GF/Grammar/MMacros.hs create mode 100644 src/GF/Grammar/Macros.hs create mode 100644 src/GF/Grammar/PatternMatch.hs create mode 100644 src/GF/Grammar/PrGrammar.hs create mode 100644 src/GF/Grammar/Refresh.hs create mode 100644 src/GF/Grammar/ReservedWords.hs create mode 100644 src/GF/Grammar/TC.hs create mode 100644 src/GF/Grammar/TypeCheck.hs create mode 100644 src/GF/Grammar/Unify.hs create mode 100644 src/GF/Grammar/Values.hs create mode 100644 src/GF/Infra/CheckM.hs create mode 100644 src/GF/Infra/Ident.hs create mode 100644 src/GF/Infra/Modules.hs create mode 100644 src/GF/Infra/Option.hs create mode 100644 src/GF/Infra/ReadFiles.hs create mode 100644 src/GF/Infra/UseIO.hs create mode 100644 src/GF/Shell.hs create mode 100644 src/GF/Shell/CommandL.hs create mode 100644 src/GF/Shell/Commands.hs create mode 100644 src/GF/Shell/JGF.hs create mode 100644 src/GF/Shell/PShell.hs create mode 100644 src/GF/Shell/SubShell.hs create mode 100644 src/GF/Source/AbsGF.hs create mode 100644 src/GF/Source/CompileM.hs create mode 100644 src/GF/Source/GrammarToSource.hs create mode 100644 src/GF/Source/LexGF.hs create mode 100644 src/GF/Source/PrintGF.hs create mode 100644 src/GF/Source/SkelGF.hs create mode 100644 src/GF/Source/SourceToGrammar.hs create mode 100644 src/GF/Source/TestGF.hs create mode 100644 src/GF/System/Arch.hs create mode 100644 src/GF/Text/Arabic.hs create mode 100644 src/GF/Text/Greek.hs create mode 100644 src/GF/Text/Hebrew.hs create mode 100644 src/GF/Text/Russian.hs create mode 100644 src/GF/Text/Text.hs create mode 100644 src/GF/Text/UTF8.hs create mode 100644 src/GF/Text/Unicode.hs create mode 100644 src/GF/UseGrammar/Custom.hs create mode 100644 src/GF/UseGrammar/Editing.hs create mode 100644 src/GF/UseGrammar/GetTree.hs create mode 100644 src/GF/UseGrammar/Information.hs create mode 100644 src/GF/UseGrammar/Linear.hs create mode 100644 src/GF/UseGrammar/MoreCustom.hs create mode 100644 src/GF/UseGrammar/Morphology.hs create mode 100644 src/GF/UseGrammar/Paraphrases.hs create mode 100644 src/GF/UseGrammar/Parsing.hs create mode 100644 src/GF/UseGrammar/Randomized.hs create mode 100644 src/GF/UseGrammar/RealMoreCustom.hs create mode 100644 src/GF/UseGrammar/Session.hs create mode 100644 src/GF/UseGrammar/TeachYourself.hs create mode 100644 src/GF/UseGrammar/Tokenize.hs create mode 100644 src/HelpFile.hs create mode 100644 src/JavaGUI/DynamicTree.java create mode 100644 src/JavaGUI/GFEditor.java create mode 100644 src/JavaGUI/GrammarFilter.java create mode 100644 src/JavaGUI/Utils.java create mode 100644 src/Makefile create mode 100644 src/Today.hs create mode 100644 src/tools/GFDoc.hs create mode 100644 src/tools/MkHelpFile.hs create mode 100644 src/tools/MkToday.hs create mode 100644 src/tools/WriteF.hs diff --git a/bin/jgf2 b/bin/jgf2 new file mode 100644 index 000000000..ca83e4edc --- /dev/null +++ b/bin/jgf2 @@ -0,0 +1,12 @@ +#! /bin/sh + +# change the value of GFHOME to the directory where you have the gf binary +GFHOME=/home/aarne/GF2/bin + # /.../chalmers.se/fs/cab/cs/.users/markus/home/GF1 + +JGUILIB=$GFHOME/java/ +GF=$GFHOME/gf2+ +JGUI=GFEditor + +java -cp $JGUILIB $JGUI "$GF -java $*" + diff --git a/grammars/logic/Arithm.gf b/grammars/logic/Arithm.gf new file mode 100644 index 000000000..e3ae706a4 --- /dev/null +++ b/grammars/logic/Arithm.gf @@ -0,0 +1,63 @@ +abstract Arithm = Logic ** { + +-- arithmetic +fun + Nat, Real : Dom ; + zero : Elem Nat ; + succ : Elem Nat -> Elem Nat ; + + trunc : Elem Real -> Elem Nat ; + + EqNat : (m,n : Elem Nat) -> Prop ; + LtNat : (m,n : Elem Nat) -> Prop ; + Div : (m,n : Elem Nat) -> Prop ; + Even : Elem Nat -> Prop ; + Odd : Elem Nat -> Prop ; + Prime : Elem Nat -> Prop ; + + one : Elem Nat ; + two : Elem Nat ; + sum : (m,n : Elem Nat) -> Elem Nat ; + prod : (m,n : Elem Nat) -> Elem Nat ; + + evax1 : Proof (Even zero) ; + evax2 : (n : Elem Nat) -> Proof (Even n) -> Proof (Odd (succ n)) ; + evax3 : (n : Elem Nat) -> Proof (Odd n) -> Proof (Even (succ n)) ; + eqax1 : Proof (EqNat zero zero) ; + eqax2 : (m,n : Elem Nat) -> Proof (EqNat m n) -> Proof (EqNat (succ m) (succ n)) ; + + IndNat : (C : Elem Nat -> Prop) -> + Proof (C zero) -> + ((x : Elem Nat) -> Proof (C x) -> Proof (C (succ x))) -> + Proof (Univ Nat C) ; + +def + one = succ zero ; + two = succ one ; + sum m zero = m ; + sum m (succ n) = succ (sum m n) ; + prod m zero = zero ; + prod m (succ n) = sum (prod m n) m ; + LtNat m n = Exist Nat (\x -> EqNat n (sum m (succ x))) ; + Div m n = Exist Nat (\x -> EqNat m (prod x n)) ; + Prime n = Conj + (LtNat one n) + (Univ Nat (\x -> Impl (Conj (LtNat one x) (Div n x)) (EqNat x n))) ; + +fun ex1 : Text ; +def ex1 = + ThmWithProof + (Univ Nat (\x -> Disj (Even x) (Odd x))) + (IndNat + (\x -> Disj (Even x) (Odd x)) + (DisjIl (Even zero) (Odd zero) evax1) + (\x -> \h -> DisjE (Even x) (Odd x) (Disj (Even (succ x)) (Odd (succ x))) + (Hypo (Disj (Even x) (Odd x)) h) + (\a -> DisjIr (Even (succ x)) (Odd (succ x)) + (evax2 x (Hypo (Even x) a))) + (\b -> DisjIl (Even (succ x)) (Odd (succ x)) + (evax3 x (Hypo (Odd x) b)) + ) + ) + ) ; +} ; diff --git a/grammars/logic/ArithmEng.gf b/grammars/logic/ArithmEng.gf new file mode 100644 index 000000000..8c78132ea --- /dev/null +++ b/grammars/logic/ArithmEng.gf @@ -0,0 +1,40 @@ +concrete ArithmEng of Arithm = LogicEng ** open LogicResEng in { + +lin + Nat = {s = nomReg "number"} ; + zero = ss "zero" ; + succ = fun1 "successor" ; + + EqNat = adj2 ["equal to"] ; + LtNat = adj2 ["smaller than"] ; + Div = adj2 ["divisible by"] ; + Even = adj1 "even" ; + Odd = adj1 "odd" ; + Prime = adj1 "prime" ; + + one = ss "one" ; + two = ss "two" ; + sum = fun2 "sum" ; + prod = fun2 "product" ; + + evax1 = ss ["by the first axiom of evenness , zero is even"] ; + evax2 n c = {s = + c.s ++ [". By the second axiom of evenness , the successor of"] ++ + n.s ++ ["is odd"]} ; + evax3 n c = {s = + c.s ++ [". By the third axiom of evenness , the successor of"] ++ + n.s ++ ["is even"]} ; + eqax1 = ss ["by the first axiom of equality , zero is equal to zero"] ; + eqax2 m n c = {s = + c.s ++ [". By the second axiom of equality , the successor of"] ++ m.s ++ + ["is equal to the successor of"] ++ n.s} ; + IndNat C d e = {s = + ["we proceed by induction . For the basis ,"] ++ d.s ++ + [". For the induction step, consider a number"] ++ C.$0 ++ + ["and assume"] ++ C.s ++ "(" ++ e.$1 ++ ")" ++ "." ++ e.s ++ + ["Hence, for all numbers"] ++ C.$0 ++ "," ++ C.s} ; + + ex1 = ss ["The first theorem and its proof ."] ; + +} ; + diff --git a/grammars/logic/Logic.gf b/grammars/logic/Logic.gf new file mode 100644 index 000000000..334592946 --- /dev/null +++ b/grammars/logic/Logic.gf @@ -0,0 +1,82 @@ +-- many-sorted predicate calculus +-- AR 1999, revised 2001 + +abstract Logic = { + +flags startcat=Prop ; -- this is what you want to parse + +cat + Prop ; -- proposition + Dom ; -- domain of quantification + Elem Dom ; -- individual element of a domain + Proof Prop ; -- proof of a proposition + Text ; -- theorem with proof etc. + +fun + -- texts + Statement : Prop -> Text ; + ThmWithProof : (A : Prop) -> Proof A -> Text ; + ThmWithTrivialProof : (A : Prop) -> Proof A -> Text ; + + -- logically complex propositions + Disj : (A,B : Prop) -> Prop ; + Conj : (A,B : Prop) -> Prop ; + Impl : (A,B : Prop) -> Prop ; + Abs : Prop ; + Neg : Prop -> Prop ; + + Univ : (A : Dom) -> (Elem A -> Prop) -> Prop ; + Exist : (A : Dom) -> (Elem A -> Prop) -> Prop ; + + -- progressive implication à la type theory + ImplP : (A : Prop) -> (Proof A -> Prop) -> Prop ; + + -- inference rules + ConjI : (A,B : Prop) -> Proof A -> Proof B -> Proof (Conj A B) ; + ConjEl : (A,B : Prop) -> Proof (Conj A B) -> Proof A ; + ConjEr : (A,B : Prop) -> Proof (Conj A B) -> Proof B ; + DisjIl : (A,B : Prop) -> Proof A -> Proof (Disj A B) ; + DisjIr : (A,B : Prop) -> Proof B -> Proof (Disj A B) ; + DisjE : (A,B,C : Prop) -> Proof (Disj A B) -> + (Proof A -> Proof C) -> (Proof B -> Proof C) -> Proof C ; + ImplI : (A,B : Prop) -> (Proof A -> Proof B) -> Proof (Impl A B) ; + ImplE : (A,B : Prop) -> Proof (Impl A B) -> Proof A -> Proof B ; + NegI : (A : Prop) -> (Proof A -> Proof Abs) -> Proof (Neg A) ; + NegE : (A : Prop) -> Proof (Neg A) -> Proof A -> Proof Abs ; + AbsE : (C : Prop) -> Proof Abs -> Proof C ; + + UnivI : (A : Dom) -> (B : Elem A -> Prop) -> + ((x : Elem A) -> Proof (B x)) -> Proof (Univ A B) ; + UnivE : (A : Dom) -> (B : Elem A -> Prop) -> + Proof (Univ A B) -> (a : Elem A) -> Proof (B a) ; + ExistI : (A : Dom) -> (B : Elem A -> Prop) -> + (a : Elem A) -> Proof (B a) -> Proof (Exist A B) ; + ExistE : (A : Dom) -> (B : Elem A -> Prop) -> (C : Prop) -> + Proof (Exist A B) -> ((x : Elem A) -> Proof (B x) -> Proof C) -> + Proof C ; + + -- use a hypothesis + Hypo : (A : Prop) -> Proof A -> Proof A ; + + -- pronoun + Pron : (A : Dom) -> Elem A -> Elem A ; + +data + Proof = ConjI | DisjIl | DisjIr ; + +def + -- proof normalization + ConjEl _ _ (ConjI _ _ a _) = a ; + ConjEr _ _ (ConjI _ _ _ b) = b ; + DisjE _ _ _ (DisjIl _ _ a) d _ = d a ; + DisjE _ _ _ (DisjIr _ _ b) _ e = e b ; + ImplE _ _ (ImplI _ _ b) a = b a ; + NegE _ (NegI _ b) a = b a ; + UnivE _ _ (UnivI _ _ b) a = b a ; + ExistE _ _ _ (ExistI _ _ a b) d = d a b ; + + -- Hypo and Pron are identities + Hypo _ a = a ; + Pron _ a = a ; + +} ; diff --git a/grammars/logic/LogicEng.gf b/grammars/logic/LogicEng.gf new file mode 100644 index 000000000..3b823fcb0 --- /dev/null +++ b/grammars/logic/LogicEng.gf @@ -0,0 +1,59 @@ +concrete LogicEng of Logic = open LogicResEng in { + +flags lexer=vars ; unlexer=text ; + +lincat + Dom = {s : Num => Str} ; + Prop, Elem = {s : Str} ; + +lin +Statement A = {s = A.s ++ "."} ; +ThmWithProof A a = {s = ["Theorem ."] ++ A.s ++ [".

Proof ."] ++ a.s ++ "."} ; +ThmWithTrivialProof A a = + {s = "Theorem" ++ "." ++ A.s ++ [".

Proof . Trivial ."]} ; +Disj A B = {s = A.s ++ "or" ++ B.s} ; +Conj A B = {s = A.s ++ "and" ++ B.s} ; +Impl A B = {s = "if" ++ A.s ++ "then" ++ B.s} ; +Univ A B = {s = ["for all"] ++ A.s ! pl ++ B.$0 ++ "," ++ B.s} ; +Exist A B = + {s = ["there exists"] ++ indef ++ A.s ! sg ++ B.$0 ++ ["such that"] ++ B.s} ; +Abs = {s = ["we have a contradiction"]} ; +Neg A = {s = ["it is not the case that"] ++ A.s} ; +ImplP A B = {s = "if" ++ A.s ++ "then" ++ B.s} ; +ConjI A B a b = {s = a.s ++ "." ++ b.s ++ [". Hence"] ++ A.s ++ "and" ++ B.s} ; +ConjEl A B c = {s = c.s ++ [". A fortiori ,"] ++ A.s} ; +ConjEr A B c = {s = c.s ++ [". A fortiori ,"] ++ B.s} ; +DisjIl A B a = {s = a.s ++ [". A fortiori ,"] ++ A.s ++ "or" ++ B.s} ; +DisjIr A B b = {s = b.s ++ [". A fortiori ,"] ++ A.s ++ "or" ++ B.s} ; +DisjE A B C c d e = {s = + c.s ++ + [". There are two possibilities . First , assume"] ++ + A.s ++ "(" ++ d.$0 ++ ")" ++ "." ++ d.s ++ + [". Second , assume"] ++ B.s ++ "(" ++ e.$0 ++ ")" ++ "." ++ e.s ++ + [". Thus"] ++ C.s ++ ["in both cases"]} ; +ImplI A B b = {s = + "assume" ++ A.s ++ "(" ++ b.$0 ++ ")" ++ "." ++ + b.s ++ [". Hence , if"] ++ A.s ++ "then" ++ B.s} ; +ImplE A B c a = {s = a.s ++ [". But"] ++ c.s ++ [". Hence"] ++ B.s} ; +NegI A b = {s = + "assume" ++ A.s ++ "(" ++ b.$0 ++ ")" ++ "." ++ b.s ++ + [". Hence, it is not the case that"] ++ A.s} ; +NegE A c a = + {s = a.s ++ [". But"] ++ c.s ++ [". We have a contradiction"]} ; +UnivI A B b = {s = + ["consider an arbitrary"] ++ A.s ! sg ++ b.$0 ++ "." ++ b.s ++ + [". Hence, for all"] ++ A.s ! pl ++ B.$0 ++ "," ++ B.s} ; +UnivE A B c a = + {s = c.s ++ [". Hence"] ++ B.s ++ "for" ++ B.$0 ++ ["set to"] ++ a.s} ; +ExistI A B a b = {s = + b.s ++ [". Hence, there exists"] ++ indef ++ + A.s ! sg ++ B.$0 ++ ["such that"] ++ B.s} ; +ExistE A B C c d = {s = + c.s ++ [". Consider an arbitrary"] ++ d.$0 ++ + ["and assume that"] ++ B.s ++ "(" ++ d.$1 ++ ")" ++ "." ++ d.s ++ + [". Hence"] ++ C.s ++ ["independently of"] ++ d.$0} ; +AbsE C c = {s = c.s ++ [". We may conclude"] ++ C.s} ; +Hypo A a = {s = ["by the hypothesis"] ++ a.s ++ "," ++ A.s} ; +Pron _ _ = {s = "it"} ; + +} ; diff --git a/grammars/logic/LogicResEng.gf b/grammars/logic/LogicResEng.gf new file mode 100644 index 000000000..94866bf05 --- /dev/null +++ b/grammars/logic/LogicResEng.gf @@ -0,0 +1,27 @@ +resource LogicResEng = { + +param Num = sg | pl ; + +oper + + ss : Str -> {s : Str} = \s -> {s = s} ; + + nomReg : Str -> Num => Str = \s -> table {sg => s ; pl => s + "s"} ; + + indef : Str = pre {"a" ; "an" / strs {"a" ; "e" ; "i" ; "o"}} ; + + LinElem : Type = {s : Str} ; + LinProp : Type = {s : Str} ; + + adj1 : Str -> LinElem -> LinProp = + \adj,x -> ss (x.s ++ "is" ++ adj) ; + adj2 : Str -> LinElem -> LinElem -> LinProp = + \adj,x,y -> ss (x.s ++ "is" ++ adj ++ y.s) ; + + fun1 : Str -> LinElem -> LinElem = + \f,x -> ss ("the" ++ f ++ "of" ++ x.s) ; + fun2 : Str -> LinElem -> LinElem -> LinElem = + \f,x,y -> ss ("the" ++ f ++ "of" ++ x.s ++ "and" ++ y.s) ; + + +} ; diff --git a/grammars/prelude/Coordination.gf b/grammars/prelude/Coordination.gf new file mode 100644 index 000000000..d8265e3c2 --- /dev/null +++ b/grammars/prelude/Coordination.gf @@ -0,0 +1,105 @@ +resource Coordination = { + +param + ListSize = TwoElem | ManyElem ; + +oper + SS = {s : Str} ; ---- + + ListX = {s1,s2 : Str} ; + + twoStr : (x,y : Str) -> ListX = \x,y -> + {s1 = x ; s2 = y} ; + consStr : Str -> ListX -> Str -> ListX = \comma,xs,x -> + {s1 = xs.s1 ++ comma ++ xs.s2 ; s2 = x } ; + + twoSS : (_,_ : SS) -> ListX = \x,y -> + twoStr x.s y.s ; + consSS : Str -> ListX -> SS -> ListX = \comma,xs,x -> + consStr comma xs x.s ; + + Conjunction : Type = SS ; + ConjunctionDistr : Type = {s1 : Str ; s2 : Str} ; + + conjunctX : Conjunction -> ListX -> Str = \or,xs -> + xs.s1 ++ or.s ++ xs.s2 ; + + conjunctDistrX : ConjunctionDistr -> ListX -> Str = \or,xs -> + or.s1 ++ xs.s1 ++ or.s2 ++ xs.s2 ; + + -- all this lifted to tables + + ListTable : Type -> Type = \P -> {s1,s2 : P => Str} ; + + twoTable : (P : Type) -> (_,_ : {s : P => Str}) -> ListTable P = \_,x,y -> + {s1 = x.s ; s2 = y.s} ; + + consTable : (P : Type) -> Str -> ListTable P -> {s : P => Str} -> ListTable P = + \P,c,xs,x -> + {s1 = table P {o => xs.s1 ! o ++ c ++ xs.s2 ! o} ; s2 = x.s} ; + + conjunctTable : (P : Type) -> Conjunction -> ListTable P -> {s : P => Str} = + \P,or,xs -> + {s = table P {p => xs.s1 ! p ++ or.s ++ xs.s2 ! p}} ; + + conjunctDistrTable : + (P : Type) -> ConjunctionDistr -> ListTable P -> {s : P => Str} = \P,or,xs -> + {s = table P {p => or.s1++ xs.s1 ! p ++ or.s2 ++ xs.s2 ! p}} ; + + -- ... and to two- and three-argument tables: how clumsy! --- + + ListTable2 : Type -> Type -> Type = \P,Q -> + {s1,s2 : P => Q => Str} ; + + twoTable2 : (P,Q : Type) -> (_,_ : {s : P => Q => Str}) -> ListTable2 P Q = + \_,_,x,y -> + {s1 = x.s ; s2 = y.s} ; + + consTable2 : + (P,Q : Type) -> Str -> ListTable2 P Q -> {s : P => Q => Str} -> ListTable2 P Q = + \P,Q,c,xs,x -> + {s1 = table P {p => table Q {q => xs.s1 ! p ! q ++ c ++ xs.s2 ! p! q}} ; + s2 = x.s + } ; + + conjunctTable2 : + (P,Q : Type) -> Conjunction -> ListTable2 P Q -> {s : P => Q => Str} = + \P,Q,or,xs -> + {s = table P {p => table Q {q => xs.s1 ! p ! q ++ or.s ++ xs.s2 ! p ! q}}} ; + + conjunctDistrTable2 : + (P,Q : Type) -> ConjunctionDistr -> ListTable2 P Q -> {s : P => Q => Str} = + \_,_,or,xs -> + {s = + table {p => table {q => or.s1++ xs.s1 ! p ! q ++ or.s2 ++ xs.s2 ! p ! q}}} ; + + ListTable3 : Type -> Type -> Type -> Type = \P,Q,R -> + {s1,s2 : P => Q => R => Str} ; + + twoTable3 : (P,Q,R : Type) -> (_,_ : {s : P => Q => R => Str}) -> + ListTable3 P Q R = + \_,_,_,x,y -> + {s1 = x.s ; s2 = y.s} ; + + consTable3 : + (P,Q,R : Type) -> Str -> ListTable3 P Q R -> {s : P => Q => R => Str} -> + ListTable3 P Q R = + \P,Q,R,c,xs,x -> + {s1 = \\p,q,r => xs.s1 ! p ! q ! r ++ c ++ xs.s2 ! p ! q ! r ; + s2 = x.s + } ; + + conjunctTable3 : + (P,Q,R : Type) -> Conjunction -> ListTable3 P Q R -> {s : P => Q => R => Str} = + \P,Q,R,or,xs -> + {s = \\p,q,r => xs.s1 ! p ! q ! r ++ or.s ++ xs.s2 ! p ! q ! r} ; + + conjunctDistrTable3 : + (P,Q,R : Type) -> ConjunctionDistr -> ListTable3 P Q R -> + {s : P => Q => R => Str} = + \P,Q,R,or,xs -> + {s = \\p,q,r => or.s1++ xs.s1 ! p ! q ! r ++ or.s2 ++ xs.s2 ! p ! q ! r} ; + + comma = "," ; + +} ; diff --git a/grammars/prelude/Predef.gf b/grammars/prelude/Predef.gf new file mode 100644 index 000000000..a91681af6 --- /dev/null +++ b/grammars/prelude/Predef.gf @@ -0,0 +1,25 @@ +-- predefined functions for concrete syntax, defined in AppPredefined.hs + +resource Predef = { + + -- this type is for internal use only + param PBool = PTrue | PFalse ; + + -- these operations have their definitions in AppPredefined.hs + oper Int : Type = variants {} ; ---- + + oper length : Tok -> Int = variants {} ; + oper drop : Int -> Tok -> Tok = variants {} ; + oper take : Int -> Tok -> Tok = variants {} ; + oper tk : Int -> Tok -> Tok = variants {} ; + oper dp : Int -> Tok -> Tok = variants {} ; + oper eqInt : Int -> Int -> PBool = variants {} ; + oper plus : Int -> Int -> Int = variants {} ; + + oper eqStr : Tok -> Tok -> PBool = variants {} ; + oper eqTok : (P : Type) -> P -> P -> PBool = variants {} ; + oper show : (P : Type) -> P -> Tok = variants {} ; + oper read : (P : Type) -> Tok -> P = variants {} ; + + } ; + diff --git a/grammars/prelude/Prelude.gf b/grammars/prelude/Prelude.gf new file mode 100644 index 000000000..f5903d7ec --- /dev/null +++ b/grammars/prelude/Prelude.gf @@ -0,0 +1,83 @@ +-- language-independent prelude facilities + +resource Prelude = open (Predef = Predef) in { + +oper +-- to construct records and tables + SS : Type = {s : Str} ; + ss : Str -> SS = \s -> {s = s} ; + ss2 : (_,_ : Str) -> SS = \x,y -> ss (x ++ y) ; + ss3 : (_,_ ,_: Str) -> SS = \x,y,z -> ss (x ++ y ++ z) ; + + cc2 : (_,_ : SS) -> SS = \x,y -> ss (x.s ++ y.s) ; + + SS1 : Type -> Type = \P -> {s : P => Str} ; + ss1 : (A : Type) -> Str -> SS1 A = \A,s -> {s = table {_ => s}} ; + + SP1 : Type -> Type = \P -> {s : Str ; p : P} ; + sp1 : (A : Type) -> Str -> A -> SP1 A = \_,s,a -> {s = s ; p = a} ; + + nonExist : Str = variants {} ; + + optStr : Str -> Str = \s -> variants {s ; []} ; + + constTable : (A,B : Type) -> B -> A => B = \_,_,b -> \\_ => b ; + constStr : (A : Type) -> Str -> A => Str = \A -> constTable A Str ; + + infixSS : Str -> SS -> SS -> SS = \f,x,y -> ss (x.s ++ f ++ y.s) ; + prefixSS : Str -> SS -> SS = \f,x -> ss (f ++ x.s) ; + postfixSS : Str -> SS -> SS = \f,x -> ss (x.s ++ f) ; + embedSS : Str -> Str -> SS -> SS = \f,g,x -> ss (f ++ x.s ++ g) ; + +-- discontinuous + SD2 = {s1,s2 : Str} ; + sd2 : (_,_ : Str) -> SD2 = \x,y -> {s1 = x ; s2 = y} ; + +-- parentheses + paren : Str -> Str = \s -> "(" ++ s ++ ")" ; + parenss : SS -> SS = \s -> ss (paren s.s) ; + +-- free order between two strings + bothWays : Str -> Str -> Str = \x,y -> variants {x ++ y ; y ++ x} ; + +-- parametric order between two strings + preOrPost : Bool -> Str -> Str -> Str = \pr,x,y -> + if_then_else Str pr (x ++ y) (y ++ x) ; + +-- Booleans + + param Bool = True | False ; + +oper + if_then_else : (A : Type) -> Bool -> A -> A -> A = \_,c,d,e -> + case c of { + True => d ; ---- should not need to qualify + False => e + } ; + + andB : (_,_ : Bool) -> Bool = \a,b -> if_then_else Bool a b False ; + orB : (_,_ : Bool) -> Bool = \a,b -> if_then_else Bool a True b ; + notB : Bool -> Bool = \a -> if_then_else Bool a False True ; + + +-- zero, one, two, or more (elements in a list etc) + +param + ENumber = E0 | E1 | E2 | Emore ; + +oper + eNext : ENumber -> ENumber = \e -> case e of { + E0 => E1 ; E1 => E2 ; _ => Emore} ; + + -- these were defined in Predef before + oper isNil : Tok -> Bool = \b -> pbool2bool (Predef.eqStr [] b) ; + + oper ifTok : (A : Type) -> Tok -> Tok -> A -> A -> A = \A,t,u,a,b -> + case Predef.eqStr t u of {Predef.PTrue => a ; Predef.PFalse => b} ; + + -- so we need an interface + oper pbool2bool : Predef.PBool -> Bool = \b -> case b of { + Predef.PFalse => False ; Predef.PTrue => True + } ; + +} ; diff --git a/grammars/resource/abstract/Database.gf b/grammars/resource/abstract/Database.gf new file mode 100644 index 000000000..d261e3e11 --- /dev/null +++ b/grammars/resource/abstract/Database.gf @@ -0,0 +1,36 @@ +abstract Database = { + +flags startcat=Query ; + +cat + Query ; Phras ; Statement ; Question ; + Noun ; Subject ; Value ; Property ; Relation ; Comparison ; Name ; + Feature ; + +fun + LongForm : Phras -> Query ; + ShortForm : Phras -> Query ; + + WhichAre : Noun -> Property -> Phras ; + IsThere : Noun -> Phras ; + AreThere : Noun -> Phras ; + IsIt : Subject -> Property -> Phras ; + WhatIs : Value -> Phras ; + + MoreThan : Comparison -> Subject -> Property ; + TheMost : Comparison -> Noun -> Value ; + Relatively : Comparison -> Noun -> Property ; + + RelatedTo : Relation -> Subject -> Property ; + + Individual : Name -> Subject ; + AllN : Noun -> Subject ; + Any : Noun -> Subject ; + MostN : Noun -> Subject ; + EveryN : Noun -> Subject ; + + FeatureOf : Feature -> Subject -> Subject ; + ValueOf : Feature -> Name -> Value ; + + WithProperty : Noun -> Property -> Noun ; +} ; diff --git a/grammars/resource/abstract/PredefAbs.gf b/grammars/resource/abstract/PredefAbs.gf new file mode 100644 index 000000000..ccd214fd4 --- /dev/null +++ b/grammars/resource/abstract/PredefAbs.gf @@ -0,0 +1,4 @@ +abstract PredefAbs = { + cat String ; Int ; +} ; + diff --git a/grammars/resource/abstract/ResAbs.gf b/grammars/resource/abstract/ResAbs.gf new file mode 100644 index 000000000..aba5ca216 --- /dev/null +++ b/grammars/resource/abstract/ResAbs.gf @@ -0,0 +1,266 @@ +--1 Abstract Syntax for Multilingual Resource Grammar +-- +-- Aarne Ranta 2002 -- 2003 +-- +-- Although concrete syntax differs a lot between different languages, +-- many structures can be found that are common, on a certain level +-- of abstraction. What we will present in the following is an abstract +-- syntax that has been successfully defined for English, French, German, +-- Italian, Russian, and Swedish. It has been applied to define language +-- fragments on technical or near-to-technical domains: database queries, +-- video recorder dialogue systems, software specifications, and a +-- health-related phrase book. +-- +-- To use the resource in applications, you need the following +-- $cat$ and $fun$ rules in $oper$ form, completed by taking the +-- $lincat$ and $lin$ judgements of a particular language. There is +-- a GF command for making this translation automatically. + +--2 Categories +-- +-- The categories of this resource grammar are mostly 'standard' categories +-- of linguistics. Their is no claim that they correspond to semantic categories +-- definable in type theory: to define such correspondences it the business +-- of applications grammars. +-- +-- Categories that may look special are $Adj2$, $Fun$, and $TV$. They are all +-- instances of endowing another category with a complement, which can be either +-- a direct object (whose case may vary) or a prepositional phrase. This, together +-- with the category $Adv$, removes the need of a category of +-- 'prepositional phrases', which is too language-dependent to make sense +-- on this level of abstraction. +-- + +abstract ResAbs = { + +--3 Nouns and noun phrases +-- + +cat + N ; -- simple common noun, e.g. "car" + CN ; -- common noun phrase, e.g. "red car", "car that John owns" + NP ; -- noun phrase, e.g. "John", "all cars", "you" + PN ; -- proper name, e.g. "John", "New York" + Det ; -- determiner, e.g. "every", "all" + Fun ; -- function word, e.g. "mother (of)" + Fun2 ; -- two-place function, e.g. "flight (from) (to)" + +--3 Adjectives and adjectival phrases +-- + + Adj1 ; -- one-place adjective, e.g. "even" + Adj2 ; -- two-place adjective, e.g. "divisible (by)" + AdjDeg ; -- degree adjective, e.g. "big/bigger/biggest" + AP ; -- adjective phrase, e.g. "divisible by two", "bigger than John" + +--3 Verbs and verb phrases +-- + + V ; -- one-place verb, e.g. "walk" + TV ; -- two-place verb, e.g. "love", "wait (for)", "switch on" + VS ; -- sentence-compl. verb e.g. "say", "prove" + VP ; -- verb phrase, e.g. "switch the light on" + +--3 Adverbials +-- + + AdV ; -- adverbial e.g. "now", "in the house" + AdA ; -- ad-adjective e.g. "very" + AdS ; -- sentence adverbial e.g. "therefore", "otherwise" + +--3 Sentences and relative clauses +-- + + S ; -- sentence, e.g. "John walks" + Slash ; -- sentence without NP, e.g. "John waits for (...)" + RP ; -- relative pronoun, e.g. "which", "the mother of whom" + RC ; -- relative clause, e.g. "who walks", "that I wait for" + +--3 Questions and imperatives +-- + + IP ; -- interrogative pronoun, e.g. "who", "whose mother", "which yellow car" + IAdv ; -- interrogative adverb., e.g. "when", "why" + Qu ; -- question, e.g. "who walks" + Imp ; -- imperative, e.g. "walk!" + +--3 Coordination and subordination +-- + + Conj ; -- conjunction, e.g. "and" + ConjD ; -- distributed conj. e.g. "both - and" + Subj ; -- subjunction, e.g. "if", "when" + + ListS ; -- list of sentences + ListAP ; -- list of adjectival phrases + ListNP ; -- list of noun phrases + +--3 Complete utterances +-- + + Phr ; -- full phrase, e.g. "John walks.","Who walks?", "Wait for me!" + Text ; -- sequence of phrases e.g. "One is odd. Therefore, two is even." + +--2 Rules +-- +-- This set of rules is minimal, in the sense defining the simplest combinations +-- of categories and of not having redundant rules. +-- When the resource grammar is used as a library, it will often be useful to +-- access it through an intermediate library that defines more rules as +-- combinations of the ones below. + +--3 Nouns and noun phrases +-- + +fun + UseN : N -> CN ; -- "car" + ModAdj : AP -> CN -> CN ; -- "red car" + DetNP : Det -> CN -> NP ; -- "every car" + IndefOneNP, IndefManyNP : CN -> NP ; -- "a car", "cars" + DefOneNP, DefManyNP : CN -> NP ; -- "the car", "the cars" + ModGenOne, ModGenMany : NP -> CN -> NP ; -- "John's car", "John's cars" + UsePN : PN -> NP ; -- "John" + UseFun : Fun -> CN ; -- "successor" + AppFun : Fun -> NP -> CN ; -- "successor of zero" + AppFun2 : Fun2 -> NP -> Fun ; -- "flight from Paris" + CNthatS : CN -> S -> CN ; -- "idea that the Earth is flat" + +--3 Adjectives and adjectival phrases +-- + + AdjP1 : Adj1 -> AP ; -- "red" + ComplAdj : Adj2 -> NP -> AP ; -- "divisible by two" + PositAdjP : AdjDeg -> AP ; -- "old" + ComparAdjP : AdjDeg -> NP -> AP ; -- "older than John" + SuperlNP : AdjDeg -> CN -> NP ; -- "the oldest man" + +--3 Verbs and verb phrases +-- + + PosV, NegV : V -> VP ; -- "walk", "doesn't walk" + PosA, NegA : AP -> VP ; -- "is old", "isn't old" + PosCN, NegCN : CN -> VP ; -- "is a man", "isn't a man" + PosTV, NegTV : TV -> NP -> VP ; -- "sees John", "doesn't see John" + PosPassV, NegPassV : V -> VP ; -- "is seen", "is not seen" + PosNP, NegNP : NP -> VP ; -- "is John", "is not John" + PosVS, NegVS : VS -> S -> VP ; -- "says that I run", "doesn't say..." + +--3 Adverbials +-- + + AdvVP : VP -> AdV -> VP ; -- "always walks", "walks in the park" + LocNP : NP -> AdV ; -- "in London" + AdvCN : CN -> AdV -> CN ; -- "house in London", "house today" + + AdvAP : AdA -> AP -> AP ; -- "very good" + + +--3 Sentences and relative clauses +-- + + PredVP : NP -> VP -> S ; -- "John walks" + PosSlashTV, NegSlashTV : NP -> TV -> Slash ; -- "John sees", "John doesn's see" + OneVP : VP -> S ; -- "one walks" + + IdRP : RP ; -- "which" + FunRP : Fun -> RP -> RP ; -- "the successor of which" + RelVP : RP -> VP -> RC ; -- "who walks" + RelSlash : RP -> Slash -> RC ; -- "that I wait for"/"for which I wait" + ModRC : CN -> RC -> CN ; -- "man who walks" + RelSuch : S -> RC ; -- "such that it is even" + +--3 Questions and imperatives +-- + + WhoOne, WhoMany : IP ; -- "who (is)", "who (are)" + WhatOne, WhatMany : IP ; -- "what (is)", "what (are)" + FunIP : Fun -> IP -> IP ; -- "the mother of whom" + NounIPOne, NounIPMany : CN -> IP ; -- "which car", "which cars" + + QuestVP : NP -> VP -> Qu ; -- "does John walk" + IntVP : IP -> VP -> Qu ; -- "who walks" + IntSlash : IP -> Slash -> Qu ; -- "whom does John see" + QuestAdv : IAdv -> NP -> VP -> Qu ; -- "why do you walk" + + ImperVP : VP -> Imp ; -- "be a man" + + IndicPhrase : S -> Phr ; -- "I walk." + QuestPhrase : Qu -> Phr ; -- "Do I walk?" + ImperOne, ImperMany : Imp -> Phr ; -- "Be a man!", "Be men!" + + AdvS : AdS -> S -> Phr ; -- "Therefore, 2 is prime." + +--3 Coordination +-- +-- We consider "n"-ary coordination, with "n" > 1. To this end, we have introduced +-- a *list category* $ListX$ for each category $X$ whose expressions we want to +-- conjoin. Each list category has two constructors, the base case being $TwoX$. + +-- We have not defined coordination of all possible categories here, +-- since it can be tricky in many languages. For instance, $VP$ coordination +-- is linguistically problematic in German because $VP$ is a discontinuous +-- category. + + ConjS : Conj -> ListS -> S ; -- "John walks and Mary runs" + ConjAP : Conj -> ListAP -> AP ; -- "even and prime" + ConjNP : Conj -> ListNP -> NP ; -- "John or Mary" + + ConjDS : ConjD -> ListS -> S ; -- "either John walks or Mary runs" + ConjDAP : ConjD -> ListAP -> AP ; -- "both even and prime" + ConjDNP : ConjD -> ListNP -> NP ; -- "either John or Mary" + + TwoS : S -> S -> ListS ; + ConsS : ListS -> S -> ListS ; + + TwoAP : AP -> AP -> ListAP ; + ConsAP : ListAP -> AP -> ListAP ; + + TwoNP : NP -> NP -> ListNP ; + ConsNP : ListNP -> NP -> ListNP ; + +--3 Subordination +-- +-- Subjunctions are different from conjunctions, but form +-- a uniform category among themselves. + + SubjS : Subj -> S -> S -> S ; -- "if 2 is odd, 3 is even" + SubjImper : Subj -> S -> Imp -> Imp ; -- "if it is hot, use a glove!" + SubjQu : Subj -> S -> Qu -> Qu ; -- "if you are new, who are you?" + +--2 One-word utterances +-- +-- These are, more generally, *one-phrase utterances*. The list below +-- is very incomplete. + + PhrNP : NP -> Phr ; -- "Some man.", "John." + PhrOneCN, PhrManyCN : CN -> Phr ; -- "A car.", "Cars." + PhrIP : IAdv -> Phr ; -- "Who?" + PhrIAdv : IAdv -> Phr ; -- "Why?" + +--2 Text formation +-- +-- A text is a sequence of phrases. It is defined like a non-empty list. + + OnePhr : Phr -> Text ; + ConsPhr : Phr -> Text -> Text ; + +--2 Examples of structural words +-- +-- Here we have some words belonging to closed classes and appearing +-- in all languages we have considered. +-- Sometimes they are not really meaningful, e.g. $TheyNP$ in French +-- should really be replaced by masculine and feminine variants. + + EveryDet, AllDet, WhichDet, MostDet : Det ; -- every, all, which, most + INP, ThouNP, HeNP, SheNP, ItNP : NP ; -- personal pronouns in singular + WeNP, YeNP, TheyNP : NP ; -- personal pronouns in plural + YouNP : NP ; -- the polite you + WhenIAdv,WhereIAdv,WhyIAdv,HowIAdv : IAdv ; -- when, where, why, how + AndConj, OrConj : Conj ; -- and, or + BothAnd, EitherOr, NeitherNor : ConjD ; -- both-and, either-or, neither-nor + IfSubj, WhenSubj : Subj ; -- if, when + PhrYes, PhrNo : Phr ; -- yes, no + VeryAdv, TooAdv : AdA ; -- very, too + OtherwiseAdv, ThereforeAdv : AdS ; -- therefore, otherwise +} ; + diff --git a/grammars/resource/abstract/Restaurant.gf b/grammars/resource/abstract/Restaurant.gf new file mode 100644 index 000000000..5c4ae4681 --- /dev/null +++ b/grammars/resource/abstract/Restaurant.gf @@ -0,0 +1,15 @@ +abstract Restaurant = Database ** { + +fun + Restaurant, Bar : Noun ; + French, Italian, Indian, Japanese : Property ; + address, phone, priceLevel : Feature ; + Cheap, Expensive : Comparison ; + + WhoRecommend : Name -> Phras ; + WhoHellRecommend : Name -> Phras ; + + +-- examples of restaurant names + LucasCarton : Name ; +} ; diff --git a/grammars/resource/abstract/TestAbs.gf b/grammars/resource/abstract/TestAbs.gf new file mode 100644 index 000000000..c07ac4968 --- /dev/null +++ b/grammars/resource/abstract/TestAbs.gf @@ -0,0 +1,15 @@ +abstract TestAbs = ResAbs ** { + +-- a random sample of lexicon to test resource grammar with + +fun + Big, Small, Old, Young : AdjDeg ; + Man, Woman, Car, House, Light : N ; + Walk, Run : V ; + Send, Wait, Love, SwitchOn, SwitchOff : TV ; + Say, Prove : VS ; + Mother, Uncle : Fun ; + Connection : Fun2 ; + Well, Always : AdV ; + John, Mary : PN ; +} ; diff --git a/grammars/resource/english/DatabaseEng.gf b/grammars/resource/english/DatabaseEng.gf new file mode 100644 index 000000000..9d94e69ed --- /dev/null +++ b/grammars/resource/english/DatabaseEng.gf @@ -0,0 +1,51 @@ +concrete DatabaseEng of Database = open Prelude,Syntax,English,Predication,Paradigms,DatabaseRes in { + +flags lexer=text ; unlexer=text ; + +lincat + Phras = SS1 Bool ; -- long or short form + Subject = NP ; + Noun = CN ; + Property = AP ; + Comparison = AdjDeg ; + Relation = Adj2 ; + Feature = Fun ; + Value = NP ; + Name = ProperName ; + +lin + LongForm sent = ss (sent.s ! True ++ "?") ; + ShortForm sent = ss (sent.s ! False ++ "?") ; + + WhichAre A B = mkSent (defaultQuestion (IntVP (NounIPMany A) (PosA B))) + (defaultNounPhrase (IndefManyNP (ModAdj B A))) ; + + IsIt Q A = mkSentSame (defaultQuestion (QuestVP Q (PosA A))) ; + + MoreThan = ComparAdjP ; + TheMost = SuperlNP ; + Relatively C _ = PositAdjP C ; + + RelatedTo = ComplAdj ; + + FeatureOf = appFun1 ; + ValueOf F V = appFun1 F (UsePN V) ; + + WithProperty A B = ModAdj B A ; + + Individual = UsePN ; + + AllN = DetNP AllDet ; + MostN = DetNP MostDet ; + EveryN = DetNP EveryDet ; + +-- only these are language-dependent + + Any = detNounPhrase anyPlDet ; --- + + IsThere A = mkSentPrel ["is there"] (defaultNounPhrase (IndefOneNP A)) ; + AreThere A = mkSentPrel ["are there"] (defaultNounPhrase (IndefManyNP A)) ; + + WhatIs V = mkSentPrel ["what is"] (defaultNounPhrase V) ; + +} ; diff --git a/grammars/resource/english/DatabaseEngRes.gf b/grammars/resource/english/DatabaseEngRes.gf new file mode 100644 index 000000000..e00501a47 --- /dev/null +++ b/grammars/resource/english/DatabaseEngRes.gf @@ -0,0 +1,11 @@ +resource DatabaseEngRes = open Prelude in { +oper + mkSent : SS -> SS -> SS1 Bool = \long, short -> + {s = table {b => if_then_else Str b long.s short.s}} ; + + mkSentPrel : Str -> SS -> SS1 Bool = \prel, matter -> + mkSent (ss (prel ++ matter.s)) matter ; + + mkSentSame : SS -> SS1 Bool = \s -> + mkSent s s ; +} ; diff --git a/grammars/resource/english/English.gf b/grammars/resource/english/English.gf new file mode 100644 index 000000000..45b64d72f --- /dev/null +++ b/grammars/resource/english/English.gf @@ -0,0 +1 @@ +resource English = reuse ResEng ; diff --git a/grammars/resource/english/Morpho.gf b/grammars/resource/english/Morpho.gf new file mode 100644 index 000000000..52779cd11 --- /dev/null +++ b/grammars/resource/english/Morpho.gf @@ -0,0 +1,150 @@ +--1 A Simple English Resource Morphology +-- +-- Aarne Ranta 2002 +-- +-- This resource morphology contains definitions needed in the resource +-- syntax. It moreover contains the most usual inflectional patterns. +-- +-- We use the parameter types and word classes defined in $types.Eng.gf$. + +resource Morpho = Types ** open Prelude in { + +--2 Nouns +-- +-- For conciseness and abstraction, we define a worst-case macro for +-- noun inflection. It is used for defining special case that +-- only need one string as argument. + +oper + mkNoun : (_,_,_,_ : Str) -> CommonNoun = + \man,men, mans, mens -> {s = table { + Sg => table {Nom => man ; Gen => mans} ; + Pl => table {Nom => men ; Gen => mens} + }} ; + + nounReg : Str -> CommonNoun = \dog -> + mkNoun dog (dog + "s") (dog + "'s") (dog + "s'"); + + nounS : Str -> CommonNoun = \kiss -> + mkNoun kiss (kiss + "es") (kiss + "'s") (kiss + "es'") ; + + nounY : Str -> CommonNoun = \fl -> + mkNoun (fl + "y") (fl + "ies") (fl + "y's") (fl + "ies'") ; + +--3 Proper names +-- +-- Regular proper names are inflected with "'s" in the genitive. + + nameReg : Str -> ProperName = \john -> + {s = table {Nom => john ; Gen => john + "'s"}} ; + + +--2 Pronouns +-- +-- Here we define personal and relative pronouns. + + mkPronoun : (_,_,_,_ : Str) -> Number -> Person -> Pronoun = \I,me,my,mine,n,p -> + {s = table {NomP => I ; AccP => me ; GenP => my ; GenSP => mine} ; + n = n ; p = p} ; + + pronI = mkPronoun "I" "me" "my" "mine" Sg P1 ; + pronYouSg = mkPronoun "you" "you" "your" "yours" Sg P2 ; -- verb form still OK + pronHe = mkPronoun "he" "him" "his" "his" Sg P3 ; + pronShe = mkPronoun "she" "her" "her" "hers" Sg P3 ; + + pronWe = mkPronoun "we" "us" "our" "ours" Pl P1 ; + pronYouPl = mkPronoun "you" "you" "your" "yours" Pl P2 ; + pronThey = mkPronoun "they" "them" "their" "theirs" Pl P3 ; + +-- Relative pronouns in the accusative have the 'no pronoun' variant. +-- The simple pronouns do not really depend on number. + + relPron : RelPron = {s = table { + NoHum => \\_ => table { + NomP => variants {"that" ; "which"} ; + AccP => variants {"that" ; "which" ; []} ; + GenP => variants {"whose"} ; + GenSP => variants {"which"} + } ; + Hum => \\_ => table { + NomP => variants {"that" ; "who"} ; + AccP => variants {"that" ; "who" ; "whom" ; []} ; + GenP => variants {"whose"} ; + GenSP => variants {"whom"} + } + } + } ; + + +--3 Determiners +-- +-- We have just a heuristic definition of the indefinite article. +-- There are lots of exceptions: consonantic "e" ("euphemism"), consonantic +-- "o" ("one-sided"), vocalic "u" ("umbrella"). + + artIndef = pre {"a" ; + "an" / strs {"a" ; "e" ; "i" ; "o" ; "A" ; "E" ; "I" ; "O" }} ; + + artDef = "the" ; + +--2 Adjectives +-- +-- For the comparison of adjectives, three forms are needed in the worst case. + + mkAdjDegr : (_,_,_ : Str) -> AdjDegr = \good,better,best -> + {s = table {Pos => good ; Comp => better ; Sup => best}} ; + + adjDegrReg : Str -> AdjDegr = \long -> + mkAdjDegr long (long + "er") (long + "est") ; + + adjDegrY : Str -> AdjDegr = \lovel -> + mkAdjDegr (lovel + "y") (lovel + "ier") (lovel + "iest") ; + +-- Many adjectives are 'inflected' by adding a comparison word. + + adjDegrLong : Str -> AdjDegr = \ridiculous -> + mkAdjDegr ridiculous ("more" ++ ridiculous) ("most" ++ ridiculous) ; + +-- simple adjectives are just strings + + simpleAdj : Str -> Adjective = ss ; + +--3 Verbs +-- +-- Except for "be", the worst case needs two forms. + + mkVerbP3 : (_,_: Str) -> VerbP3 = \goes,go -> + {s = table {InfImp => go ; Indic P3 => goes ; Indic _ => go}} ; + + regVerbP3 : Str -> VerbP3 = \walk -> + mkVerbP3 (walk + "s") walk ; + + verbP3s : Str -> VerbP3 = \kiss -> + mkVerbP3 (kiss + "es") kiss ; + + verbP3y : Str -> VerbP3 = \fl -> + mkVerbP3 (fl + "ies") (fl + "y") ; + + verbP3Have = mkVerbP3 "has" "have" ; + + verbP3Do = verbP3s "do" ; + + verbBe : VerbP3 = {s = table { + InfImp => "be" ; + Indic P1 => "am" ; + Indic P2 => "are" ; + Indic P3 => "is" + }} ; + + verbPart : VerbP3 -> Particle -> Verb = \v,p -> + v ** {s1 = p} ; + + verbNoPart : VerbP3 -> Verb = \v -> verbPart v [] ; + +-- The optional negation contraction is a useful macro e.g. for "do". + + contractNot : Str -> Str = \is -> variants {is ++ "not" ; is + "n't"} ; + + dont = contractNot (verbP3Do.s ! InfImp) ; +} ; + diff --git a/grammars/resource/english/Paradigms.gf b/grammars/resource/english/Paradigms.gf new file mode 100644 index 000000000..65e5c1297 --- /dev/null +++ b/grammars/resource/english/Paradigms.gf @@ -0,0 +1,229 @@ +--1 English Lexical Paradigms +-- +-- Aarne Ranta 2003 +-- +-- This is an API to the user of the resource grammar +-- for adding lexical items. It give shortcuts for forming +-- expressions of basic categories: nouns, adjectives, verbs. +-- +-- Closed categories (determiners, pronouns, conjunctions) are +-- accessed through the resource syntax API, $resource.Abs.gf$. +-- +-- The main difference with $morpho.Eng.gf$ is that the types +-- referred to are compiled resource grammar types. We have moreover +-- had the design principle of always having existing forms as string +-- arguments of the paradigms, not stems. +-- +-- The following modules are presupposed: + +resource Paradigms = open (Predef=Predef), Prelude, Syntax, English in { + +--2 Parameters +-- +-- To abstract over gender names, we define the following identifiers. + +oper + human : Gender ; + nonhuman : Gender ; + +-- To abstract over number names, we define the following. + + singular : Number ; + plural : Number ; + + +--2 Nouns + +-- Worst case: give all four forms and the semantic gender. +-- In practice the worst case is just: give singular and plural nominative. + +oper + mkN : (man,men,man's,men's : Str) -> Gender -> N ; + nMan : (man,men : Str) -> Gender -> N ; + +-- Regular nouns, nouns ending with "s", "y", or "o", and nouns with the same +-- plural form as the singular. + + nReg : Str -> Gender -> N ; -- dog, dogs + nKiss : Str -> Gender -> N ; -- kiss, kisses + nFly : Str -> Gender -> N ; -- fly, flies + nHero : Str -> Gender -> N ; -- hero, heroes (= nKiss !) + nSheep : Str -> Gender -> N ; -- sheep, sheep + +-- These use general heuristics, that recognizes the last letter. *N.B* it +-- does not get right with "boy", "rush", since it only looks at one letter. + + nHuman : Str -> N ; -- gambler/actress/nanny + nNonhuman : Str -> N ; -- dog/kiss/fly + +-- Nouns used as functions need a preposition. The most common is "of". + + mkFun : N -> Preposition -> Fun ; + + funHuman : Str -> Fun ; -- the father/mistress/daddy of + funNonhuman : Str -> Fun ; -- the successor/address/copy of + +-- Proper names, with their regular genitive. + + pnReg : (John : Str) -> PN ; -- John, John's + +-- The most common cases on the top level havee shortcuts. +-- The regular "y"/"s" variation is taken into account in $CN$. + + cnNonhuman : Str -> CN ; + cnHuman : Str -> CN ; + npReg : Str -> NP ; + + +--2 Adjectives + +-- Non-comparison one-place adjectives just have one form. + + mkAdj1 : (even : Str) -> Adj1 ; + +-- Two-place adjectives need a preposition as second argument. + + mkAdj2 : (divisible, by : Str) -> Adj2 ; + +-- Comparison adjectives have three forms. The common irregular +-- cases are ones ending with "y" and a consonant that is duplicated. + + mkAdjDeg : (good,better,best : Str) -> AdjDeg ; + + aReg : (long : Str) -> AdjDeg ; -- long, longer, longest + aHappy : (happy : Str) -> AdjDeg ; -- happy, happier, happiest + aFat : (fat : Str) -> AdjDeg ; -- fat, fatter, fattest + aRidiculous : (ridiculous : Str) -> AdjDeg ; -- -/more/most ridiculous + +-- On top level, there are adjectival phrases. The most common case is +-- just to use a one-place adjective. + + apReg : Str -> AP ; + + +--2 Verbs +-- +-- The fragment only has present tense so far, but in all persons. +-- Except for "be", the worst case needs two forms: the infinitive and +-- the third person singular. + + mkV : (go, goes : Str) -> V ; + + vReg : (walk : Str) -> V ; -- walk, walks + vKiss : (kiss : Str) -> V ; -- kiss, kisses + vFly : (fly : Str) -> V ; -- fly, flies + vGo : (go : Str) -> V ; -- go, goes (= vKiss !) + +-- This generic function recognizes the special cases where the last +-- character is "y", "s", or "z". It is not right for "finish" and "convey". + + vGen : Str -> V ; -- walk/kiss/fly + +-- The verbs "be" and "have" are special. + + vBe : V ; + vHave : V ; + +-- Verbs with a particle. + + vPart : (go, goes, up : Str) -> V ; + vPartReg : (get, up : Str) -> V ; + +-- Two-place verbs, and the special case with direct object. +-- Notice that a particle can already be included in $V$. + + mkTV : V -> Str -> TV ; -- look for, kill + + tvGen : (look, for : Str) -> TV ; -- look for, talk about + tvDir : V -> TV ; -- switch off + tvGenDir : (kill : Str) -> TV ; -- kill + +-- Regular two-place verbs with a particle. + + tvPartReg : Str -> Str -> Str -> TV ; -- get, along, with + +-- The definitions should not bother the user of the API. So they are +-- hidden from the document. +--. + + human = Hum ; + nonhuman = NoHum ; + -- singular defined in types.Eng + -- plural defined in types.Eng + + nominative = Nom ; + + mkN = \man,men,man's,men's,g -> mkNoun man men man's men's ** {g = g} ; + nReg = addGenN nounReg ; + nKiss = addGenN nounS ; + nFly = \fly -> addGenN nounY (Predef.tk 1 fly) ; + nMan = \man,men -> mkN man men (man + "'s") (men + "'s") ; + nHero = nKiss ; + nSheep = \sheep -> nMan sheep sheep ; + + nHuman = \s -> nGen s Hum ; + nNonhuman = \s -> nGen s NoHum ; + + nGen : Str -> Gender -> N = \fly,g -> let { + fl = Predef.tk 1 fly ; + y = Predef.dp 1 fly ; + eqy = ifTok (Str -> Gender -> N) y + } in + eqy "y" nFly ( + eqy "s" nKiss ( + eqy "z" nKiss ( + nReg))) fly g ; + + mkFun = \n,p -> n ** {s2 = p} ; + funNonhuman = \s -> mkFun (nNonhuman s) "of" ; + funHuman = \s -> mkFun (nHuman s) "of" ; + + pnReg = nameReg ; + + cnNonhuman = \s -> UseN (nGen s nonhuman) ; + cnHuman = \s -> UseN (nGen s human) ; + npReg = \s -> UsePN (pnReg s) ; + + addGenN : (Str -> CommonNoun) -> Str -> Gender -> N = \f -> + \s,g -> f s ** {g = g} ; + + mkAdj1 = simpleAdj ; + mkAdj2 = \s,p -> simpleAdj s ** {s2 = p} ; + mkAdjDeg = mkAdjDegr ; + aReg = adjDegrReg ; + aHappy = \happy -> adjDegrY (Predef.tk 1 happy) ; + aFat = \fat -> let {fatt = fat + Predef.dp 1 fat} in + mkAdjDeg fat (fatt + "er") (fatt + "est") ; + aRidiculous = adjDegrLong ; + apReg = \s -> AdjP1 (mkAdj1 s) ; + + mkV = \go,goes -> verbNoPart (mkVerbP3 goes go) ; + vReg = \run -> mkV run (run + "s") ; + vKiss = \kiss -> mkV kiss (kiss + "es") ; + vFly = \fly -> mkV fly (Predef.tk 1 fly + "ies") ; + vGo = vKiss ; + + vGen = \fly -> let { + fl = Predef.tk 1 fly ; + y = Predef.dp 1 fly ; + eqy = ifTok (Str -> V) y + } in + eqy "y" vFly ( + eqy "s" vKiss ( + eqy "z" vKiss ( + vReg))) fly ; + + vPart = \go, goes, up -> verbPart (mkVerbP3 goes go) up ; + vPartReg = \get, up -> verbPart (regVerbP3 get) up ; + + mkTV = \v,p -> v ** {s3 = p} ; + tvPartReg = \get, along, with -> mkTV (vPartReg get along) with ; + + vBe = verbBe ; + vHave = mkV "have" "has" ; + + tvGen = \s,p -> mkTV (vGen s) p ; + tvDir = \v -> mkTV v [] ; + tvGenDir = \s -> tvDir (vGen s) ; + +} ; diff --git a/grammars/resource/english/Predication.gf b/grammars/resource/english/Predication.gf new file mode 100644 index 000000000..cc92c465f --- /dev/null +++ b/grammars/resource/english/Predication.gf @@ -0,0 +1,83 @@ + +--1 A Small Predication Library +-- +-- (c) Aarne Ranta 2003 under Gnu GPL. +-- +-- This library is built on a language-independent API of +-- resource grammars. It has a common part, the type signatures +-- (defined here), and language-dependent parts. The user of +-- the library should only have to look at the type signatures. + +resource Predication = open English in { + +-- We first define a set of predication patterns. + +oper + predV1 : V -> NP -> S ; -- one-place verb: "John walks" + predV2 : TV -> NP -> NP -> S ; -- two-place verb: "John loves Mary" + predVColl : V -> NP -> NP -> S ; -- collective verb: "John and Mary fight" + predA1 : Adj1 -> NP -> S ; -- one-place adjective: "John is old" + predA2 : Adj2 -> NP -> NP -> S ; -- two-place adj: "John is married to Mary" + predAComp : AdjDeg -> NP -> NP -> S ; -- compar adj: "John is older than Mary" + predAColl : Adj1 -> NP -> NP -> S ; -- collective adj: "John and Mary are married" + predN1 : N -> NP -> S ; -- one-place noun: "John is a man" + predN2 : Fun -> NP -> NP -> S ; -- two-place noun: "John is a lover of Mary" + predNColl : N -> NP -> NP -> S ; -- collective noun: "John and Mary are lovers" + +-- Individual-valued function applications. + + appFun1 : Fun -> NP -> NP ; -- one-place function: "the successor of x" + appFunColl : Fun -> NP -> NP -> NP ; -- collective function: "the sum of x and y" + +-- Families of types, expressed by common nouns depending on arguments. + + appFam1 : Fun -> NP -> CN ; -- one-place family: "divisor of x" + appFamColl : Fun -> NP -> NP -> CN ; -- collective family: "path between x and y" + +-- Type constructor, similar to a family except that the argument is a type. + + constrTyp1 : Fun -> CN -> CN ; + +-- Logical connectives on two sentences. + + conjS : S -> S -> S ; + disjS : S -> S -> S ; + implS : S -> S -> S ; + +-- As an auxiliary, we need two-place conjunction of names ("John and Mary"), +-- used in collective predication. + + conjNP : NP -> NP -> NP ; + + +----------------------------- + +---- what follows should be an implementation of the preceding + +oper + predV1 = \F, x -> PredVP x (PosV F) ; + predV2 = \F, x, y -> PredVP x (PosTV F y) ; + predVColl = \F, x, y -> PredVP (conjNP x y) (PosV F) ; + predA1 = \F, x -> PredVP x (PosA F) ; + predA2 = \F, x, y -> PredVP x (PosA (ComplAdj F y)) ; + predAComp = \F, x, y -> PredVP x (PosA (ComparAdjP F y)) ; + predAColl = \F, x, y -> PredVP (conjNP x y) (PosA F) ; + predN1 = \F, x -> PredVP x (PosCN (UseN F)) ; + predN2 = \F, x, y -> PredVP x (PosCN (AppFun F y)) ; + predNColl = \F, x, y -> PredVP (conjNP x y) (PosCN (UseN F)) ; + + appFun1 = \f, x -> DefOneNP (AppFun f x) ; + appFunColl = \f, x, y -> DefOneNP (AppFun f (conjNP x y)) ; + + appFam1 = \F, x -> AppFun F x ; + appFamColl = \F, x, y -> AppFun F (conjNP x y) ; + + conjS = \A, B -> ConjS AndConj (TwoS A B) ; + disjS = \A, B -> ConjS OrConj (TwoS A B) ; + implS = \A, B -> SubjS IfSubj A B ; + + constrTyp1 = \F, A -> AppFun F (IndefManyNP A) ; + + conjNP = \x, y -> ConjNP AndConj (TwoNP x y) ; + +} ; diff --git a/grammars/resource/english/ResEng.gf b/grammars/resource/english/ResEng.gf new file mode 100644 index 000000000..412bcfae7 --- /dev/null +++ b/grammars/resource/english/ResEng.gf @@ -0,0 +1,195 @@ +--1 The Top-Level English Resource Grammar +-- +-- Aarne Ranta 2002 -- 2003 +-- +-- This is the English concrete syntax of the multilingual resource +-- grammar. Most of the work is done in the file $syntax.Eng.gf$. +-- However, for the purpose of documentation, we make here explicit the +-- linearization types of each category, so that their structures and +-- dependencies can be seen. +-- Another substantial part are the linearization rules of some +-- structural words. +-- +-- The users of the resource grammar should not look at this file for the +-- linearization rules, which are in fact hidden in the document version. +-- They should use $resource.Abs.gf$ to access the syntactic rules. +-- This file can be consulted in those, hopefully rare, occasions in which +-- one has to know how the syntactic categories are +-- implemented. The parameter types are defined in $types.Eng.gf$. + +concrete ResEng of ResAbs = open Prelude, Syntax in { + +flags + startcat=Phr ; + parser=chart ; + +lincat + N = CommNoun ; + -- = {s : Number => Case => Str} + CN = CommNounPhrase ; + -- = CommNoun ** {g : Gender} + NP = {s : NPForm => Str ; n : Number ; p : Person} ; + PN = {s : Case => Str} ; + Det = {s : Str ; n : Number} ; + Fun = CommNounPhrase ** {s2 : Preposition} ; + + Adj1 = Adjective ; + -- = {s : Str} + Adj2 = Adjective ** {s2 : Preposition} ; + AdjDeg = {s : Degree => Str} ; + AP = Adjective ** {p : Bool} ; + + V = Verb ; + -- = {s : VForm => Str ; s1 : Particle} + VP = {s : VForm => Str ; s2 : Number => Str ; isAux : Bool} ; + TV = Verb ** {s3 : Preposition} ; + VS = Verb ; + + AdV = {s : Str ; isPost : Bool} ; + + S = {s : Str} ; + Slash = {s : Bool => Str ; s2 : Preposition} ; + RP = {s : Gender => Number => NPForm => Str} ; + RC = {s : Gender => Number => Str} ; + + IP = {s : NPForm => Str ; n : Number} ; + Qu = {s : QuestForm => Str} ; + Imp = {s : Number => Str} ; + Phr = {s : Str} ; + + Conj = {s : Str ; n : Number} ; + ConjD = {s1 : Str ; s2 : Str ; n : Number} ; + + ListS = {s1 : Str ; s2 : Str} ; + ListAP = {s1 : Str ; s2 : Str ; p : Bool} ; + ListNP = {s1,s2 : NPForm => Str ; n : Number ; p : Person} ; + +--. + +lin + UseN = noun2CommNounPhrase ; + ModAdj = modCommNounPhrase ; + ModGenOne = npGenDet singular ; + ModGenMany = npGenDet plural ; + UsePN = nameNounPhrase ; + UseFun = funAsCommNounPhrase ; + AppFun = appFunComm ; + AdjP1 = adj2adjPhrase ; + ComplAdj = complAdj ; + PositAdjP = positAdjPhrase ; + ComparAdjP = comparAdjPhrase ; + SuperlNP = superlNounPhrase ; + + DetNP = detNounPhrase ; + IndefOneNP = indefNounPhrase singular ; + IndefManyNP = indefNounPhrase plural ; + DefOneNP = defNounPhrase singular ; + DefManyNP = defNounPhrase plural ; + + PredVP = predVerbPhrase ; + PosV = predVerb True ; + NegV = predVerb False ; + PosA = predAdjective True ; + NegA = predAdjective False ; + PosCN = predCommNoun True ; + NegCN = predCommNoun False ; + PosTV = complTransVerb True ; + NegTV = complTransVerb False ; + PosNP = predNounPhrase True ; + NegNP = predNounPhrase False ; + PosVS = complSentVerb True ; + NegVS = complSentVerb False ; + + + AdvVP = adVerbPhrase ; + LocNP = locativeNounPhrase ; + AdvCN = advCommNounPhrase ; + + PosSlashTV = slashTransVerb True ; + NegSlashTV = slashTransVerb False ; + + IdRP = identRelPron ; + FunRP = funRelPron ; + RelVP = relVerbPhrase ; + RelSlash = relSlash ; + ModRC = modRelClause ; + RelSuch = relSuch ; + + WhoOne = intPronWho singular ; + WhoMany = intPronWho plural ; + WhatOne = intPronWhat singular ; + WhatMany = intPronWhat plural ; + FunIP = funIntPron ; + NounIPOne = nounIntPron singular ; + NounIPMany = nounIntPron plural ; + + QuestVP = questVerbPhrase ; + IntVP = intVerbPhrase ; + IntSlash = intSlash ; + QuestAdv = questAdverbial ; + + ImperVP = imperVerbPhrase ; + + IndicPhrase = indicUtt ; + QuestPhrase = interrogUtt ; + ImperOne = imperUtterance singular ; + ImperMany = imperUtterance plural ; + +lin + TwoS = twoSentence ; + ConsS = consSentence ; + ConjS = conjunctSentence ; + ConjDS = conjunctDistrSentence ; + + TwoAP = twoAdjPhrase ; + ConsAP = consAdjPhrase ; + ConjAP = conjunctAdjPhrase ; + ConjDAP = conjunctDistrAdjPhrase ; + + TwoNP = twoNounPhrase ; + ConsNP = consNounPhrase ; + ConjNP = conjunctNounPhrase ; + ConjDNP = conjunctDistrNounPhrase ; + + SubjS = subjunctSentence ; + SubjImper = subjunctImperative ; + SubjQu = subjunctQuestion ; + + PhrNP = useNounPhrase ; + PhrOneCN = useCommonNounPhrase singular ; + PhrManyCN = useCommonNounPhrase plural ; + PhrIP ip = ip ; + PhrIAdv ia = ia ; + + +lin + INP = pronI ; + ThouNP = pronYouSg ; + HeNP = pronHe ; + SheNP = pronShe ; + WeNP = pronWe ; + YeNP = pronYouPl ; + YouNP = pronYouSg ; + TheyNP = pronThey ; + + EveryDet = everyDet ; + AllDet = allDet ; + WhichDet = whichDet ; + MostDet = mostDet ; + + HowIAdv = ss "how" ; + WhenIAdv = ss "when" ; + WhereIAdv = ss "where" ; + WhyIAdv = ss "why" ; + + AndConj = ss "and" ** {n = Pl} ; + OrConj = ss "or" ** {n = Sg} ; + BothAnd = sd2 "both" "and" ** {n = Pl} ; + EitherOr = sd2 "either" "or" ** {n = Sg} ; + NeitherNor = sd2 "neither" "nor" ** {n = Sg} ; + IfSubj = ss "if" ; + WhenSubj = ss "when" ; + + PhrYes = ss "Yes." ; + PhrNo = ss "No." ; +} ; diff --git a/grammars/resource/english/RestaurantEng.gf b/grammars/resource/english/RestaurantEng.gf new file mode 100644 index 000000000..00a9392f0 --- /dev/null +++ b/grammars/resource/english/RestaurantEng.gf @@ -0,0 +1,25 @@ +concrete RestaurantEng of Restaurant = + DatabaseEng ** open Prelude,Paradigms,DatabaseRes in { + +lin + Restaurant = cnNonhuman "restaurant" ; + Bar = cnNonhuman "bar" ; + French = apReg "French" ; + Italian = apReg "Italian" ; + Indian = apReg "Indian" ; + Japanese = apReg "Japanese" ; + + address = funNonhuman "address" ; + phone = funNonhuman ["number"] ; --- phone + priceLevel = funNonhuman ["level"] ; --- price + + Cheap = aReg "cheap" ; + Expensive = aRidiculous "expensive" ; + + WhoRecommend rest = mkSentSame (ss (["who recommended"] ++ rest.s ! nominative)) ; + WhoHellRecommend rest = + mkSentSame (ss (["who the hell recommended"] ++ rest.s ! nominative)) ; + + LucasCarton = pnReg ["Lucas Carton"] ; + +} ; diff --git a/grammars/resource/english/Syntax.gf b/grammars/resource/english/Syntax.gf new file mode 100644 index 000000000..994b8722b --- /dev/null +++ b/grammars/resource/english/Syntax.gf @@ -0,0 +1,848 @@ +--1 A Small English Resource Syntax +-- +-- Aarne Ranta 2002 +-- +-- This resource grammar contains definitions needed to construct +-- indicative, interrogative, and imperative sentences in English. +-- +-- The following files are presupposed: + +resource Syntax = Morpho ** open Prelude, (CO = Coordination) in { + +--2 Common Nouns +-- +-- Simple common nouns are defined as the type $CommNoun$ in $morpho.Deu.gf$. + +--3 Common noun phrases + +-- To the common nouns of morphology, +-- we add natural gender (human/nonhuman) which is needed in syntactic +-- combinations (e.g. "man who runs" - "program which runs"). + +oper + CommNoun = CommonNoun ** {g : Gender} ; + + CommNounPhrase = CommNoun ; + + noun2CommNounPhrase : CommNoun -> CommNounPhrase = \man -> + man ; + + cnGen : CommonNoun -> Gender -> CommNoun = \cn,g -> + cn ** {g = g} ; + + cnHum : CommonNoun -> CommNoun = \cn -> + cnGen cn Hum ; + cnNoHum : CommonNoun -> CommNoun = \cn -> + cnGen cn NoHum ; + +--2 Noun phrases +-- +-- The worst case is pronouns, which have inflection in the possessive forms. +-- Proper names are a special case. + + NounPhrase : Type = Pronoun ; + + nameNounPhrase : ProperName -> NounPhrase = \john -> + {s = \\c => john.s ! toCase c ; n = Sg ; p = P3} ; + +--2 Determiners +-- +-- Determiners are inflected according to the nouns they determine. +-- The determiner is not inflected. + Determiner : Type = {s : Str ; n : Number} ; + + detNounPhrase : Determiner -> CommNounPhrase -> NounPhrase = \every, man -> + {s = \\c => every.s ++ man.s ! every.n ! toCase c ; + n = every.n ; + p = P3 + } ; + + mkDeterminer : Number -> Str -> Determiner = \n,det -> + {s = det ; + n = n + } ; + + everyDet = mkDeterminer Sg "every" ; + allDet = mkDeterminer Pl "all" ; + mostDet = mkDeterminer Pl "most" ; + aDet = mkDeterminer Sg artIndef ; + plDet = mkDeterminer Pl [] ; + theSgDet = mkDeterminer Sg "the" ; + thePlDet = mkDeterminer Pl "the" ; + anySgDet = mkDeterminer Sg "any" ; + anyPlDet = mkDeterminer Pl "any" ; + + whichSgDet = mkDeterminer Sg "which" ; + whichPlDet = mkDeterminer Pl "which" ; + + whichDet = whichSgDet ; --- API + + indefNoun : Number -> CommNoun -> Str = \n,man -> + (indefNounPhrase n man).s ! NomP ; + + indefNounPhrase : Number -> CommNounPhrase -> NounPhrase = \n,man -> + {s = \\c => case n of { + Sg => artIndef ++ man.s ! n ! toCase c ; + Pl => man.s ! n ! toCase c + } ; + n = n ; p = P3 + } ; + + defNounPhrase : Number -> CommNounPhrase -> NounPhrase = \n,car -> + {s = \\c => artDef ++ car.s ! n ! toCase c ; n = n ; p = P3} ; + +-- Genitives of noun phrases can be used like determiners, to build noun phrases. +-- The number argument makes the difference between "my house" - "my houses". +-- +-- We have the variation "the car of John / the car of John's / John's car" + + npGenDet : Number -> NounPhrase -> CommNounPhrase -> NounPhrase = + \n,john,car -> + {s = \\c => variants { + artDef ++ car.s ! n ! Nom ++ "of" ++ john.s ! GenSP ; + john.s ! GenP ++ car.s ! n ! toCase c + } ; + n = n ; + p = P3 + } ; + +-- *Bare plural noun phrases* like "men", "good cars", are built without a +-- determiner word. + + plurDet : CommNounPhrase -> NounPhrase = \cn -> + {s = \\c => cn.s ! plural ! toCase c ; + p = P3 ; + n = Pl + } ; + + +--2 Adjectives +-- +-- Adjectival phrases have a parameter $p$ telling if they are prefixed ($True$) or +-- postfixed (complex APs). + + AdjPhrase : Type = Adjective ** {p : Bool} ; + + adj2adjPhrase : Adjective -> AdjPhrase = \new -> new ** {p = True} ; + + simpleAdjPhrase : Str -> AdjPhrase = \French -> + adj2adjPhrase (simpleAdj French) ; + +--3 Comparison adjectives +-- +-- Each of the comparison forms has a characteristic use: +-- +-- Positive forms are used alone, as adjectival phrases ("big"). + + positAdjPhrase : AdjDegr -> AdjPhrase = \big -> + adj2adjPhrase (ss (big.s ! Pos)) ; + +-- Comparative forms are used with an object of comparison, as +-- adjectival phrases ("bigger then you"). + + comparAdjPhrase : AdjDegr -> NounPhrase -> AdjPhrase = \big, you -> + {s = big.s ! Comp ++ "than" ++ you.s ! NomP ; + p = False + } ; + +-- Superlative forms are used with a modified noun, picking out the +-- maximal representative of a domain ("the biggest house"). + + superlNounPhrase : AdjDegr -> CommNoun -> NounPhrase = \big, house -> + {s = \\c => "the" ++ big.s ! Sup ++ house.s ! Sg ! toCase c ; + n = Sg ; + p = P3 + } ; + + +--3 Two-place adjectives +-- +-- A two-place adjective is an adjective with a preposition used before +-- the complement. + + Preposition = Str ; + + AdjCompl = Adjective ** {s2 : Preposition} ; + + complAdj : AdjCompl -> NounPhrase -> AdjPhrase = \related,john -> + {s = related.s ++ related.s2 ++ john.s ! AccP ; + p = False + } ; + + +--3 Modification of common nouns +-- +-- The two main functions of adjective are in predication ("John is old") +-- and in modification ("an old man"). Predication will be defined +-- later, in the chapter on verbs. +-- +-- Modification must pay attention to pre- and post-noun +-- adjectives: "big car"/"car bigger than X" + + modCommNounPhrase : AdjPhrase -> CommNounPhrase -> CommNounPhrase = \big, car -> + {s = \\n => if_then_else (Case => Str) big.p + (\\c => big.s ++ car.s ! n ! c) + (table {Nom => car.s ! n ! Nom ++ big.s ; Gen => variants {}}) ; + g = car.g + } ; + + +--2 Function expressions + +-- A function expression is a common noun together with the +-- preposition prefixed to its argument ("mother of x"). +-- The type is analogous to two-place adjectives and transitive verbs. + + Function = CommNounPhrase ** {s2 : Preposition} ; + +-- The application of a function gives, in the first place, a common noun: +-- "mother/mothers of John". From this, other rules of the resource grammar +-- give noun phrases, such as "the mother of John", "the mothers of John", +-- "the mothers of John and Mary", and "the mother of John and Mary" (the +-- latter two corresponding to distributive and collective functions, +-- respectively). Semantics will eventually tell when each +-- of the readings is meaningful. + + appFunComm : Function -> NounPhrase -> CommNounPhrase = \mother,john -> + {s = \\n => table { + Gen => nonExist ; + _ => mother.s ! n ! Nom ++ mother.s2 ++ john.s ! GenSP + } ; + g = mother.g + } ; + +-- It is possible to use a function word as a common noun; the semantics is +-- often existential or indexical. + + funAsCommNounPhrase : Function -> CommNounPhrase = + noun2CommNounPhrase ; + +-- The following is an aggregate corresponding to the original function application +-- producing "John's mother" and "the mother of John". It does not appear in the +-- resource grammar API any longer. + + appFun : Bool -> Function -> NounPhrase -> NounPhrase = \coll, mother,john -> + let {n = john.n ; nf = if_then_else Number coll Sg n} in + variants { + defNounPhrase nf (appFunComm mother john) ; + npGenDet nf john mother + } ; + +-- The commonest case is functions with the preposition "of". + + funOf : CommNoun -> Function = \mother -> + mother ** {s2 = "of"} ; + + funOfReg : Str -> Gender -> Function = \mother,g -> + funOf (nounReg mother ** {g = g}) ; + + + +--2 Verbs +-- +--3 Verb phrases +-- +-- Verb phrases are discontinuous: the two parts of a verb phrase are +-- (s) an inflected verb, (s2) infinitive and complement. +-- For instance: "doesn't" - "walk" ; "isn't" - "old" ; "is" - "a man" +-- There's also a parameter telling if the verb is an auxiliary: +-- this is needed in question. + + VerbPhrase = VerbP3 ** {s2 : Number => Str ; isAux : Bool} ; + +-- From the inflection table, we selecting the finite form as function +-- of person and number: + + indicVerb : VerbP3 -> Person -> Number -> Str = \v,p,n -> case n of { + Sg => v.s ! Indic p ; + Pl => v.s ! Indic P2 + } ; + +-- A simple verb can be made into a verb phrase with an empty complement. +-- There are two versions, depending on if we want to negate the verb. +-- N.B. negation is *not* a function applicable to a verb phrase, since +-- double negations with "don't" are not grammatical. + + predVerb : Bool -> Verb -> VerbPhrase = \b,walk -> + if_then_else VerbPhrase b + {s = \\v => walk.s ! v ++ walk.s1 ; + s2 = \\_ => [] ; + isAux = False + } + {s = \\v => contractNot (verbP3Do.s ! v) ; + s2 = \\_ => walk.s ! InfImp ++ walk.s1 ; + isAux = True + } ; + +-- Sometimes we want to extract the verb part of a verb phrase. + + verbOfPhrase : VerbPhrase -> VerbP3 = \v -> {s = v.s} ; + +-- Verb phrases can also be formed from adjectives ("is old"), +-- common nouns ("is a man"), and noun phrases ("ist John"). +-- The third rule is overgenerating: "is every man" has to be ruled out +-- on semantic grounds. + + predAdjective : Bool -> Adjective -> VerbPhrase = \b,old -> + {s = beOrNotBe b ; + s2 = \\_ => old.s ; + isAux = True + } ; + + predCommNoun : Bool -> CommNoun -> VerbPhrase = \b,man -> + {s = beOrNotBe b ; + s2 = \\n => indefNoun n man ; + isAux = True + } ; + + predNounPhrase : Bool -> NounPhrase -> VerbPhrase = \b,john -> + {s = beOrNotBe b ; + s2 = \\_ => john.s ! NomP ; + isAux = True + } ; + +-- We use an auxiliary giving all forms of "be". + + beOrNotBe : Bool -> (VForm => Str) = \b -> + if_then_else (VForm => Str) b + verbBe.s + (table { + InfImp => contractNot "do" ++ "be" ; + Indic P1 => "am" ++ "not" ; + v => contractNot (verbBe.s ! v) + }) ; + +--3 Transitive verbs +-- +-- Transitive verbs are verbs with a preposition for the complement, +-- in analogy with two-place adjectives and functions. +-- One might prefer to use the term "2-place verb", since +-- "transitive" traditionally means that the inherent preposition is empty. +-- Such a verb is one with a *direct object*. + + TransVerb : Type = Verb ** {s3 : Preposition} ; + +-- The rule for using transitive verbs is the complementization rule. +-- Particles produce free variation: before or after the complement +-- ("I switch on the TV" / "I switch the TV on"). + + complTransVerb : Bool -> TransVerb -> NounPhrase -> VerbPhrase = + \b,lookat,john -> + let {lookatjohn = bothWays lookat.s1 (lookat.s3 ++ john.s ! AccP)} in + if_then_else VerbPhrase b + {s = lookat.s ; + s2 = \\_ => lookatjohn ; + isAux = False} + {s = \\v => contractNot (verbP3Do.s ! v) ; + s2 = \\_ => lookat.s ! InfImp ++ lookatjohn ; + isAux = True} ; + + +-- Verbs that take direct object and a particle: + mkTransVerbPart : VerbP3 -> Str -> TransVerb = \turn,off -> + {s = turn.s ; s1 = off ; s3 = []} ; + +-- Verbs that take prepositional object, no particle: + mkTransVerb : VerbP3 -> Str -> TransVerb = \wait,for -> + {s = wait.s ; s1 = [] ; s3 = for} ; + +-- Verbs that take direct object, no particle: + mkTransVerbDir : VerbP3 -> TransVerb = \love -> + mkTransVerbPart love [] ; + + +--2 Adverbials +-- +-- Adverbials are not inflected (we ignore comparison, and treat +-- compared adverbials as separate expressions; this could be done another way). +-- We distinguish between post- and pre-verbal adverbs. + + Adverb : Type = SS ** {isPost : Bool} ; + + advPre : Str -> Adverb = \seldom -> ss seldom ** {isPost = False} ; + advPost : Str -> Adverb = \well -> ss well ** {isPost = True} ; + +-- N.B. this rule generates the cyclic parsing rule $VP#2 ::= VP#2$ +-- and cannot thus be parsed. + + adVerbPhrase : VerbPhrase -> Adverb -> VerbPhrase = \sings, well -> + let {postp = orB well.isPost sings.isAux} in + { + s = \\v => (if_then_else Str postp [] well.s) ++ sings.s ! v ; + s2 = \\n => sings.s2 ! n ++ (if_then_else Str postp well.s []) ; + isAux = sings.isAux + } ; + +-- Adverbials are typically generated by prefixing prepositions. +-- The rule for creating locative noun phrases by the preposition "in" +-- is a little shaky, since other prepositions may be preferred ("on", "at"). + + prepPhrase : Preposition -> NounPhrase -> Adverb = \on, it -> + advPost (on ++ it.s ! AccP) ; + + locativeNounPhrase : NounPhrase -> Adverb = + prepPhrase "in" ; + +-- This is a source of the "mann with a telescope" ambiguity, and may produce +-- strange things, like "cars always" (while "cars today" is OK). +-- Semantics will have to make finer distinctions among adverbials. +-- +-- N.B. the genitive case created in this way would not make sense. + + advCommNounPhrase : CommNounPhrase -> Adverb -> CommNounPhrase = \car,today -> + {s = \\n => table { + Nom => car.s ! n ! Nom ++ today.s ; + Gen => nonExist + } ; + g = car.g + } ; + + +--2 Sentences +-- +-- Sentences are not inflected in this fragment of English without tense. + + Sentence : Type = SS ; + +-- This is the traditional $S -> NP VP$ rule. It takes care of +-- agreement between subject and verb. Recall that the VP may already +-- contain negation. + + predVerbPhrase : NounPhrase -> VerbPhrase -> Sentence = \john,walks -> + ss (john.s ! NomP ++ indicVerb (verbOfPhrase walks) john.p john.n ++ + walks.s2 ! john.n) ; + + +-- This is a macro for simultaneous predication and complementization. + + predTransVerb : Bool -> NounPhrase -> TransVerb -> NounPhrase -> Sentence = + \b,you,see,john -> + predVerbPhrase you (complTransVerb b see john) ; + + +--3 Sentence-complement verbs +-- +-- Sentence-complement verbs take sentences as complements. + + SentenceVerb : Type = Verb ; + +-- To generate "says that John walks" / "doesn't say that John walks": + + complSentVerb : Bool -> SentenceVerb -> Sentence -> VerbPhrase = + \b,say,johnruns -> + let {thatjohnruns = optStr "that" ++ johnruns.s} in + if_then_else VerbPhrase b + {s = say.s ; + s2 = \\_ => thatjohnruns ; + isAux = False} + {s = \\v => contractNot (verbP3Do.s ! v) ; + s2 = \\_ => say.s ! InfImp ++ thatjohnruns ; + isAux = True} ; + + +--2 Sentences missing noun phrases +-- +-- This is one instance of Gazdar's *slash categories*, corresponding to his +-- $S/NP$. +-- We cannot have - nor would we want to have - a productive slash-category former. +-- Perhaps a handful more will be needed. +-- +-- Notice that the slash category has a similar relation to sentences as +-- transitive verbs have to verbs: it's like a *sentence taking a complement*. +-- However, we need something more to distinguish its use in direct questions: +-- not just "you see" but ("whom") "do you see". +-- +-- The particle always follows the verb, but the preposition can fly: +-- "whom you make it up with" / "with whom you make it up". + + SentenceSlashNounPhrase = {s : Bool => Str ; s2 : Preposition} ; + + slashTransVerb : Bool -> NounPhrase -> TransVerb -> SentenceSlashNounPhrase = + \b,You,lookat -> + let {you = You.s ! NomP ; + looks = indicVerb {s = lookat.s} You.p You.n ; + look = lookat.s ! InfImp ; + do = indicVerb verbP3Do You.p You.n ; + dont = contractNot do ; + up = lookat.s1 + } in + {s = table { + True => if_then_else Str b do dont ++ you ++ look ++ up ; + False => you ++ if_then_else Str b looks (dont ++ look) ++ up + } ; + s2 = lookat.s3 + } ; + + +--2 Relative pronouns and relative clauses +-- +-- As described in $types.Eng.gf$, relative pronouns are inflected in +-- gender (human/nonhuman), number, and case. +-- +-- We get the simple relative pronoun ("who"/"which"/"whom"/"whose"/"that"/$""$) +-- from $morpho.Eng.gf$. + + identRelPron : RelPron = relPron ; + + funRelPron : Function -> RelPron -> RelPron = \mother,which -> + {s = \\g,n,c => "the" ++ mother.s ! n ! Nom ++ + mother.s2 ++ which.s ! g ! n ! GenSP + } ; + +-- Relative clauses can be formed from both verb phrases ("who walks") and +-- slash expressions ("whom you see", "on which you sit" / "that you sit on"). + + RelClause : Type = {s : Gender => Number => Str} ; + + relVerbPhrase : RelPron -> VerbPhrase -> RelClause = \who,walks -> + {s = \\g, n => who.s ! g ! n ! NomP ++ + indicVerb (verbOfPhrase walks) P3 n ++ walks.s2 ! n + } ; + + relSlash : RelPron -> SentenceSlashNounPhrase -> RelClause = \who,yousee -> + {s = \\g,n => + let {youSee = yousee.s ! False} in + variants { + who.s ! g ! n ! AccP ++ youSee ++ yousee.s2 ; + yousee.s2 ++ who.s ! g ! n ! GenSP ++ youSee + } + } ; + +-- A 'degenerate' relative clause is the one often used in mathematics, e.g. +-- "number x such that x is even". + + relSuch : Sentence -> RelClause = \A -> + {s = \\_,_ => "such" ++ "that" ++ A.s} ; + +-- The main use of relative clauses is to modify common nouns. +-- The result is a common noun, out of which noun phrases can be formed +-- by determiners. No comma is used before these relative clause. + + modRelClause : CommNounPhrase -> RelClause -> CommNounPhrase = \man,whoruns -> + {s = \\n,c => man.s ! n ! c ++ whoruns.s ! man.g ! n ; + g = man.g + } ; + + +--2 Interrogative pronouns +-- +-- If relative pronouns are adjective-like, interrogative pronouns are +-- noun-phrase-like. + + IntPron : Type = {s : NPForm => Str ; n : Number} ; + +-- In analogy with relative pronouns, we have a rule for applying a function +-- to a relative pronoun to create a new one. + + funIntPron : Function -> IntPron -> IntPron = \mother,which -> + {s = \\c => "the" ++ mother.s ! which.n ! Nom ++ mother.s2 ++ which.s ! GenSP ; + n = which.n + } ; + +-- There is a variety of simple interrogative pronouns: +-- "which house", "who", "what". + + nounIntPron : Number -> CommNounPhrase -> IntPron = \n, car -> + {s = \\c => "which" ++ car.s ! n ! toCase c ; + n = n + } ; + + intPronWho : Number -> IntPron = \num -> { + s = table { + NomP => "who" ; + AccP => variants {"who" ; "whom"} ; + GenP => "whose" ; + GenSP => "whom" + } ; + n = num + } ; + + intPronWhat : Number -> IntPron = \num -> { + s = table { + GenP => "what's" ; + _ => "what" + } ; + n = num + } ; + + +--2 Utterances + +-- By utterances we mean whole phrases, such as +-- 'can be used as moves in a language game': indicatives, questions, imperative, +-- and one-word utterances. The rules are far from complete. +-- +-- N.B. we have not included rules for texts, which we find we cannot say much +-- about on this level. In semantically rich GF grammars, texts, dialogues, etc, +-- will of course play an important role as categories not reducible to utterances. +-- An example is proof texts, whose semantics show a dependence between premises +-- and conclusions. Another example is intersentential anaphora. + + Utterance = SS ; + + indicUtt : Sentence -> Utterance = \x -> ss (x.s ++ ".") ; + interrogUtt : Question -> Utterance = \x -> ss (x.s ! DirQ ++ "?") ; + + +--2 Questions +-- +-- Questions are either direct ("are you happy") or indirect +-- ("if/whether you are happy"). + +param + QuestForm = DirQ | IndirQ ; + +oper + Question = SS1 QuestForm ; + +--3 Yes-no questions +-- +-- Yes-no questions are used both independently +-- ("does John walk" / "if John walks") +-- and after interrogative adverbials +-- ("why does John walk" / "why John walks"). +-- +-- It is economical to handle with all these cases by the one +-- rule, $questVerbPhrase'$. The word ("ob" / "whether") never appears +-- if there is an adverbial. + + questVerbPhrase : NounPhrase -> VerbPhrase -> Question = + questVerbPhrase' False ; + + questVerbPhrase' : Bool -> NounPhrase -> VerbPhrase -> Question = + \adv,john,walk -> + {s = table { + DirQ => if_then_else Str walk.isAux + (indicVerb (verbOfPhrase walk) john.p john.n ++ + john.s ! NomP ++ walk.s2 ! john.n) + (indicVerb verbP3Do john.p john.n ++ + john.s ! NomP ++ walk.s ! InfImp ++ walk.s2 ! john.n) ; + IndirQ => if_then_else Str adv [] (variants {"if" ; "whether"}) ++ + (predVerbPhrase john walk).s + } + } ; + + + +--3 Wh-questions +-- +-- Wh-questions are of two kinds: ones that are like $NP - VP$ sentences, +-- others that are line $S/NP - NP$ sentences. + + intVerbPhrase : IntPron -> VerbPhrase -> Question = \who,walk -> + {s = \\_ => who.s ! NomP ++ indicVerb (verbOfPhrase walk) P3 who.n ++ + walk.s2 ! who.n + } ; + + intSlash : IntPron -> SentenceSlashNounPhrase -> Question = \who,yousee -> + {s = \\q => + let {youSee = case q of { + DirQ => yousee.s ! True ; + IndirQ => yousee.s ! False + } + } in + variants { + who.s ! AccP ++ youSee ++ yousee.s2 ; + yousee.s2 ++ who.s ! GenSP ++ youSee + } + } ; + +--3 Interrogative adverbials +-- +-- These adverbials will be defined in the lexicon: they include +-- "when", "where", "how", "why", etc, which are all invariant one-word +-- expressions. In addition, they can be formed by adding prepositions +-- to interrogative pronouns, in the same way as adverbials are formed +-- from noun phrases. + + IntAdverb = SS ; + + prepIntAdverb : Preposition -> IntPron -> IntAdverb = \at, whom -> + ss (at ++ whom.s ! AccP) ; + +-- A question adverbial can be applied to anything, and whether this makes +-- sense is a semantic question. + + questAdverbial : IntAdverb -> NounPhrase -> VerbPhrase -> Question = + \why, you, walk -> + {s = \\q => why.s ++ (questVerbPhrase' True you walk).s ! q} ; + + +--2 Imperatives +-- +-- We only consider second-person imperatives. + + Imperative = SS1 Number ; + + imperVerbPhrase : VerbPhrase -> Imperative = \walk -> + {s = \\n => walk.s ! InfImp ++ walk.s2 ! n} ; + + imperUtterance : Number -> Imperative -> Utterance = \n,I -> + ss (I.s ! n ++ "!") ; + + +--2 Coordination +-- +-- Coordination is to some extent orthogonal to the rest of syntax, and +-- has been treated in a generic way in the module $CO$ in the file +-- $coordination.gf$. The overall structure is independent of category, +-- but there can be differences in parameter dependencies. +-- +--3 Conjunctions +-- +-- Coordinated phrases are built by using conjunctions, which are either +-- simple ("and", "or") or distributed ("both - and", "either - or"). +-- +-- The conjunction has an inherent number, which is used when conjoining +-- noun phrases: "John and Mary are..." vs. "John or Mary is..."; in the +-- case of "or", the result is however plural if any of the disjuncts is. + + Conjunction = CO.Conjunction ** {n : Number} ; + ConjunctionDistr = CO.ConjunctionDistr ** {n : Number} ; + +--3 Coordinating sentences +-- +-- We need a category of lists of sentences. It is a discontinuous +-- category, the parts corresponding to 'init' and 'last' segments +-- (rather than 'head' and 'tail', because we have to keep track of the slot between +-- the last two elements of the list). A list has at least two elements. + + ListSentence : Type = SD2 ; + + twoSentence : (_,_ : Sentence) -> ListSentence = CO.twoSS ; + + consSentence : ListSentence -> Sentence -> ListSentence = + CO.consSS CO.comma ; + +-- To coordinate a list of sentences by a simple conjunction, we place +-- it between the last two elements; commas are put in the other slots, +-- e.g. "du rauchst, er trinkt und ich esse". + + conjunctSentence : Conjunction -> ListSentence -> Sentence = \c,xs -> + ss (CO.conjunctX c xs) ; + +-- To coordinate a list of sentences by a distributed conjunction, we place +-- the first part (e.g. "either") in front of the first element, the second +-- part ("or") between the last two elements, and commas in the other slots. +-- For sentences this is really not used. + + conjunctDistrSentence : ConjunctionDistr -> ListSentence -> Sentence = + \c,xs -> + ss (CO.conjunctDistrX c xs) ; + +--3 Coordinating adjective phrases +-- +-- The structure is the same as for sentences. The result is a prefix adjective +-- if and only if all elements are prefix. + + ListAdjPhrase : Type = SD2 ** {p : Bool} ; + + twoAdjPhrase : (_,_ : AdjPhrase) -> ListAdjPhrase = \x,y -> + CO.twoStr x.s y.s ** {p = andB x.p y.p} ; + + consAdjPhrase : ListAdjPhrase -> AdjPhrase -> ListAdjPhrase = \xs,x -> + CO.consStr CO.comma xs x.s ** {p = andB xs.p x.p} ; + + conjunctAdjPhrase : Conjunction -> ListAdjPhrase -> AdjPhrase = \c,xs -> + ss (CO.conjunctX c xs) ** {p = xs.p} ; + + conjunctDistrAdjPhrase : ConjunctionDistr -> ListAdjPhrase -> AdjPhrase = + \c,xs -> + ss (CO.conjunctDistrX c xs) ** {p = xs.p} ; + + +--3 Coordinating noun phrases +-- +-- The structure is the same as for sentences. The result is either always plural +-- or plural if any of the components is, depending on the conjunction. + + ListNounPhrase : Type = {s1,s2 : NPForm => Str ; n : Number ; p : Person} ; + + twoNounPhrase : (_,_ : NounPhrase) -> ListNounPhrase = \x,y -> + CO.twoTable NPForm x y ** {n = conjNumber x.n y.n ; p = conjPerson x.p y.p} ; + + consNounPhrase : ListNounPhrase -> NounPhrase -> ListNounPhrase = \xs,x -> + CO.consTable NPForm CO.comma xs x ** + {n = conjNumber xs.n x.n ; p = conjPerson xs.p x.p} ; + + conjunctNounPhrase : Conjunction -> ListNounPhrase -> NounPhrase = \c,xs -> + CO.conjunctTable NPForm c xs ** {n = conjNumber c.n xs.n ; p = xs.p} ; + + conjunctDistrNounPhrase : ConjunctionDistr -> ListNounPhrase -> NounPhrase = + \c,xs -> + CO.conjunctDistrTable NPForm c xs ** {n = conjNumber c.n xs.n ; p = xs.p} ; + +-- We have to define a calculus of numbers of persons. For numbers, +-- it is like the conjunction with $Pl$ corresponding to $False$. + + conjNumber : Number -> Number -> Number = \m,n -> case of { + => Sg ; + _ => Pl + } ; + +-- For persons, we let the latter argument win ("either you or I am absent" +-- but "either I or you are absent"). This is not quite clear. + + conjPerson : Person -> Person -> Person = \_,p -> + p ; + + + +--2 Subjunction +-- +-- Subjunctions ("when", "if", etc) +-- are a different way to combine sentences than conjunctions. +-- The main clause can be a sentences, an imperatives, or a question, +-- but the subjoined clause must be a sentence. +-- +-- There are uniformly two variant word orders, e.g. +-- "if you smoke I get angry" +-- and "I get angry if you smoke". + + Subjunction = SS ; + + subjunctSentence : Subjunction -> Sentence -> Sentence -> Sentence = + \if, A, B -> + ss (subjunctVariants if A.s B.s) ; + + subjunctImperative : Subjunction -> Sentence -> Imperative -> Imperative = + \if, A, B -> + {s = \\n => subjunctVariants if A.s (B.s ! n)} ; + + subjunctQuestion : Subjunction -> Sentence -> Question -> Question = + \if, A, B -> + {s = \\q => subjunctVariants if A.s (B.s ! q)} ; + + subjunctVariants : Subjunction -> Str -> Str -> Str = \if,A,B -> + variants {if.s ++ A ++ "," ++ B ; B ++ "," ++ if.s ++ A} ; + + +--2 One-word utterances +-- +-- An utterance can consist of one phrase of almost any category, +-- the limiting case being one-word utterances. These +-- utterances are often (but not always) in what can be called the +-- default form of a category, e.g. the nominative. +-- This list is far from exhaustive. + + useNounPhrase : NounPhrase -> Utterance = \john -> + postfixSS "." (defaultNounPhrase john) ; + + useCommonNounPhrase : Number -> CommNounPhrase -> Utterance = \n,car -> + useNounPhrase (indefNounPhrase n car) ; + + useRegularName : SS -> NounPhrase = \john -> + nameNounPhrase (nameReg john.s) ; + +-- Here are some default forms. + + defaultNounPhrase : NounPhrase -> SS = \john -> + ss (john.s ! NomP) ; + + defaultQuestion : Question -> SS = \whoareyou -> + ss (whoareyou.s ! DirQ) ; + + defaultSentence : Sentence -> Utterance = \x -> + x ; + +} ; diff --git a/grammars/resource/english/TestEng.gf b/grammars/resource/english/TestEng.gf new file mode 100644 index 000000000..57d81d173 --- /dev/null +++ b/grammars/resource/english/TestEng.gf @@ -0,0 +1,36 @@ +concrete TestEng of TestAbs = ResEng ** open Syntax in { + +flags startcat=Phr ; lexer=text ; parser=chart ; unlexer=text ; + +-- a random sample from the lexicon + +lin + Big = mkAdjDegr "big" "bigger" "biggest"; + Small = adjDegrReg "small" ; + Old = adjDegrReg "old" ; + Young = adjDegrReg "young" ; + Man = cnHum (mkNoun "man" "men" "man's" "men's") ; + Woman = cnHum (mkNoun "woman" "women" "woman's" "women's") ; + Car = cnNoHum (nounReg "car") ; + House = cnNoHum (nounReg "house") ; + Light = cnNoHum (nounReg "light") ; + Walk = verbNoPart (regVerbP3 "walk") ; + Run = verbNoPart (regVerbP3 "run") ; + Say = verbNoPart (regVerbP3 "say") ; + Prove = verbNoPart (regVerbP3 "prove") ; + Send = mkTransVerbDir (regVerbP3 "send") ; + Love = mkTransVerbDir (regVerbP3 "love") ; + Wait = mkTransVerb (regVerbP3 "wait") "for" ; + Mother = funOfReg "mother" Hum ; + Uncle = funOfReg "uncle" Hum ; + + Always = advPre "always" ; + Well = advPost "well" ; + + SwitchOn = mkTransVerbPart (verbP3s "switch") "on" ; + SwitchOff = mkTransVerbPart (verbP3s "switch") "off" ; + + John = nameReg "John" ; + Mary = nameReg "Mary" ; + +} ; diff --git a/grammars/resource/english/Types.gf b/grammars/resource/english/Types.gf new file mode 100644 index 000000000..a43ffd81b --- /dev/null +++ b/grammars/resource/english/Types.gf @@ -0,0 +1,101 @@ +--1 English Word Classes and Morphological Parameters +-- +-- This is a resource module for English morphology, defining the +-- morphological parameters and word classes of English. It is aimed +-- to be complete w.r.t. the description of word forms. +-- However, it only includes those parameters that are needed for +-- analysing individual words: such parameters are defined in syntax modules. +-- +-- we use the language-independent prelude. + +resource Types = open Prelude in { + +-- +--2 Enumerated parameter types +-- +-- These types are the ones found in school grammars. +-- Their parameter values are atomic. + +param + Number = Sg | Pl ; + Gender = NoHum | Hum ; + Case = Nom | Gen ; + Person = P1 | P2 | P3 ; + Degree = Pos | Comp | Sup ; + +-- For data abstraction, we define + +oper + singular = Sg ; + plural = Pl ; + +--2 Word classes and hierarchical parameter types +-- +-- Real parameter types (i.e. ones on which words and phrases depend) +-- are often hierarchical. The alternative would be cross-products of +-- simple parameters, but this would usually overgenerate. +-- + +--3 Common nouns +-- +-- Common nouns are inflected in number and case. + + CommonNoun : Type = {s : Number => Case => Str} ; + + +-- +--3 Adjectives +-- +-- The major division is between the comparison degrees, but it +-- is also good to leave room for adjectives that cannon be compared. +-- Such adjectives are simply strings. + + Adjective : Type = SS ; + AdjDegr = SS1 Degree ; + +--3 Verbs +-- +-- We limit the grammar so far to verbs in infinitive-imperative or present tense. +-- The present tense is made to depend on person, which correspond to forms +-- in the singular; plural forms are uniformly equal to the 2nd person singular. + +param + VForm = InfImp | Indic Person ; + +oper + VerbP3 : Type = SS1 VForm ; + +-- A full verb can moreover have a particle. + + Particle : Type = Str ; + Verb = VerbP3 ** {s1 : Particle} ; + +-- +--3 Pronouns +-- +-- For pronouns, we need four case forms: "I" - "me" - "my" - "mine". + +param + NPForm = NomP | AccP | GenP | GenSP ; + +oper + Pronoun : Type = {s : NPForm => Str ; n : Number ; p : Person} ; + +-- Coercions between pronoun cases and ordinaty cases. + + toCase : NPForm -> Case = \c -> case c of {GenP => Gen ; _ => Nom} ; + toNPForm : Case -> NPForm = \c -> case c of {Gen => GenP ; _ => NomP} ; --- + +--3 Proper names +-- +-- Proper names only need two cases. + + ProperName : Type = SS1 Case ; + +--3 Relative pronouns +-- +-- Relative pronouns are inflected in gender (human/nonhuman), number, and case. + + RelPron : Type = {s : Gender => Number => NPForm => Str} ; +} ; + diff --git a/grammars/resource/german/DatabaseDeu.gf b/grammars/resource/german/DatabaseDeu.gf new file mode 100644 index 000000000..a7a8f278e --- /dev/null +++ b/grammars/resource/german/DatabaseDeu.gf @@ -0,0 +1,52 @@ +concrete DatabaseDeu of Database = + open Prelude,Syntax,Deutsch,Predication,Paradigms,DatabaseRes in { + +flags lexer=text ; unlexer=text ; + +lincat + Phras = SS1 Bool ; -- long or short form + Subject = NP ; + Noun = CN ; + Property = AP ; + Comparison = AdjDeg ; + Relation = Adj2 ; + Feature = Fun ; + Value = NP ; + Name = ProperName ; + +lin + LongForm sent = ss (sent.s ! True ++ "?") ; + ShortForm sent = ss (sent.s ! False ++ "?") ; + + WhichAre A B = mkSent (defaultQuestion (IntVP (NounIPMany A) (PosA B))) + (defaultNounPhrase (IndefManyNP (ModAdj B A))) ; + + IsIt Q A = mkSentSame (defaultQuestion (QuestVP Q (PosA A))) ; + + MoreThan = ComparAdjP ; + TheMost = SuperlNP ; + Relatively C _ = PositAdjP C ; + + RelatedTo = ComplAdj ; + + FeatureOf = appFun1 ; + ValueOf F V = appFun1 F (UsePN V) ; + + WithProperty A B = ModAdj B A ; + + Individual = nameNounPhrase ; + + AllN = DetNP AllDet ; + MostN = DetNP MostDet ; + EveryN = DetNP EveryDet ; + +-- only these are language-dependent + + Any = detNounPhrase einDet ; + + IsThere A = mkSentPrel ["gibt es"] (defaultNounPhrase (IndefOneNP A)) ; + AreThere A = mkSentPrel ["gibt es"] (defaultNounPhrase (IndefManyNP A)) ; + + WhatIs V = mkSentPrel ["was ist"] (defaultNounPhrase V) ; + +} ; diff --git a/grammars/resource/german/DatabaseRes.gf b/grammars/resource/german/DatabaseRes.gf new file mode 100644 index 000000000..57bac16ac --- /dev/null +++ b/grammars/resource/german/DatabaseRes.gf @@ -0,0 +1,11 @@ +resource DatabaseRes = open Prelude in { +oper + mkSent : SS -> SS -> SS1 Bool = \long, short -> + {s = table {b => if_then_else Str b long.s short.s}} ; + + mkSentPrel : Str -> SS -> SS1 Bool = \prel, matter -> + mkSent (ss (prel ++ matter.s)) matter ; + + mkSentSame : SS -> SS1 Bool = \s -> + mkSent s s ; +} ; diff --git a/grammars/resource/german/Deutsch.gf b/grammars/resource/german/Deutsch.gf new file mode 100644 index 000000000..4a91ad219 --- /dev/null +++ b/grammars/resource/german/Deutsch.gf @@ -0,0 +1 @@ +resource Deutsch = reuse ResDeu ; diff --git a/grammars/resource/german/Logical.gf b/grammars/resource/german/Logical.gf new file mode 100644 index 000000000..3347ae129 --- /dev/null +++ b/grammars/resource/german/Logical.gf @@ -0,0 +1,23 @@ +-- Slightly ad hoc and formal negation and connectives. + +resource Logical = Predication ** open Deutsch, Paradigms in { + + oper + negS : S -> S ; -- es ist nicht der Fall, dass S + univS : CN -> S -> S ; -- für alle CNs gilt es, dass S + existS : CN -> S -> S ; -- es gibt ein CN derart, dass S + existManyS : CN -> S -> S ; -- es gibt CNs derart, dass S +--. + + negS = \A -> + PredVP ItNP (NegNP (DefOneNP (CNthatS (UseN (nRaum "Fall" "Fälle")) A))) ; + univS = \A,B -> + PredVP ItNP (AdvVP (PosVS (mkV "gelten" "gilt" "gelte" "gegolten") B) + (mkPP accusative "für" (DetNP AllDet A))) ; + existS = \A,B -> + PredVP ItNP (PosTV (tvDir (mkV "geben" "gibt" "gib" "gegeben")) + (IndefOneNP (ModRC A (RelSuch B)))) ; + existManyS = \A,B -> + PredVP ItNP (PosTV (tvDir (mkV "geben" "gibt" "gib" "gegeben")) + (IndefManyNP (ModRC A (RelSuch B)))) ; +} ; diff --git a/grammars/resource/german/Morpho.gf b/grammars/resource/german/Morpho.gf new file mode 100644 index 000000000..f286bc3b7 --- /dev/null +++ b/grammars/resource/german/Morpho.gf @@ -0,0 +1,399 @@ +--1 A Simple German Resource Morphology +-- +-- Aarne Ranta 2002 +-- +-- This resource morphology contains definitions needed in the resource +-- syntax. It moreover contains the most usual inflectional patterns. +-- +-- We use the parameter types and word classes defined in $types.Deu.gf$. + +resource Morpho = Types ** open (Predef=Predef), Prelude in { + +--2 Nouns +-- +-- For conciseness and abstraction, we define a method for +-- generating a case-dependent table from a list of four forms. + +oper + caselist : (_,_,_,_ : Str) -> Case => Str = \n,a,d,g -> table { + Nom => n ; Acc => a ; Dat => d ; Gen => g} ; + +-- The *worst-case macro* for common nouns needs six forms: all plural forms +-- are always the same except for the dative. + + mkNoun : (_,_,_,_,_,_ : Str) -> Gender -> CommNoun = + \mann, mannen, manne, mannes, männer, männern, g -> {s = table { + Sg => caselist mann mannen manne mannes ; + Pl => caselist männer männer männern männer + } ; g = g} ; + +-- But we never need all the six forms at the same time. Often +-- we need just two, three, or four forms. + + mkNoun4 : (_,_,_,_ : Str) -> Gender -> CommNoun = \kuh,kuhes,kühe,kühen -> + mkNoun kuh kuh kuh kuhes kühe kühen ; + + mkNoun3 : (_,_,_ : Str) -> Gender -> CommNoun = \kuh,kühe,kühen -> + mkNoun kuh kuh kuh kuh kühe kühen ; + + mkNoun2n : (_,_ : Str) -> Gender -> CommNoun = \zahl, zahlen -> + mkNoun3 zahl zahlen zahlen ; + + mkNoun2es : (_,_ : Str) -> Gender -> CommNoun = \wort, wörter -> + mkNoun wort wort wort (wort + "es") wörter (wörter + "n") ; + + mkNoun2s : (_,_ : Str) -> Gender -> CommNoun = \vater, väter -> + mkNoun vater vater vater (vater + "s") väter (väter + "n") ; + + mkNoun2ses : (_,_ : Str) -> Gender -> CommNoun = \wort,wörter -> + mkNoun wort wort wort (wort + variants {"es" ; "s"}) wörter (wörter + "n") ; + +-- Here are the school grammar declensions with their commonest variations. +-- Unfortunately we cannot define *Umlaut* in GF, but have to give two forms. +-- +-- First declension, with plural "en"/"n", including weak masculins: + + declN1 : Str -> CommNoun = \zahl -> + mkNoun2n zahl (zahl + "en") Fem ; + + declN1e : Str -> CommNoun = \stufe -> + mkNoun2n stufe (stufe + "n") Fem ; + + declN1M : Str -> CommNoun = \junge -> let {jungen = junge + "n"} in + mkNoun junge jungen jungen jungen jungen jungen Masc ; + + declN1eM : Str -> CommNoun = \soldat -> let {soldaten = soldat + "en"} in + mkNoun soldat soldaten soldaten soldaten soldaten soldaten Masc ; + +-- Second declension, with plural "e": + + declN2 : Str -> CommNoun = \punkt -> + mkNoun2es punkt (punkt+"e") Masc ; + + declN2i : Str -> CommNoun = \onkel -> + mkNoun2s onkel onkel Masc ; + + declN2u : (_,_ : Str) -> CommNoun = \raum,räume -> + mkNoun2es raum räume Masc ; + + declN2uF : (_,_ : Str) -> CommNoun = \kuh,kühe -> + mkNoun3 kuh kühe (kühe + "n") Fem ; + +-- Third declension, with plural "er": + + declN3 : Str -> CommNoun = \punkt -> + mkNoun2es punkt (punkt+"er") Neut ; + + declN3u : (_,_ : Str) -> CommNoun = \buch,bücher -> + mkNoun2ses buch bücher Neut ; + + declN3uS : (_,_ : Str) -> CommNoun = \haus,häuser -> + mkNoun2es haus häuser Neut ; + +-- Plural with "s": + + declNs : Str -> CommNoun = \restaurant -> + mkNoun3 restaurant (restaurant+"s") (restaurant+"s") Neut ; + + +--2 Pronouns +-- +-- Here we define personal and relative pronouns. +-- All personal pronouns, except "ihr", conform to the simple +-- pattern $mkPronPers$. + + ProPN = {s : NPForm => Str ; n : Number ; p : Person} ; + + mkPronPers : (_,_,_,_,_ : Str) -> Number -> Person -> ProPN = + \ich,mich,mir,meines,mein,n,p -> { + s = table { + NPCase c => caselist ich mich mir meines ! c ; + NPPoss gn c => mein + pronEnding ! gn ! c + } ; + n = n ; + p = p + } ; + + pronEnding : GenNum => Case => Str = table { + GSg Masc => caselist "" "en" "em" "es" ; + GSg Fem => caselist "e" "e" "er" "er" ; + GSg Neut => caselist "" "" "em" "es" ; + GPl => caselist "e" "e" "en" "er" + } ; + + pronIch = mkPronPers "ich" "mich" "mir" "meines" "mein" Sg P1 ; + pronDu = mkPronPers "du" "dich" "dir" "deines" "dein" Sg P2 ; + pronEr = mkPronPers "er" "ihn" "ihm" "seines" "sein" Sg P3 ; + pronSie = mkPronPers "sie" "sie" "ihr" "ihres" "ihr" Sg P3 ; + pronEs = mkPronPers "es" "es" "ihm" "seines" "sein" Sg P3 ; + pronWir = mkPronPers "wir" "uns" "uns" "unser" "unser" Pl P1 ; + + pronSiePl = mkPronPers "sie" "sie" "ihnen" "ihrer" "ihr" Pl P3 ; + pronSSie = mkPronPers "Sie" "Sie" "Ihnen" "Ihrer" "Ihr" Pl P3 ; --- + +-- We still have wrong agreement with the complement of the polite "Sie": +-- it is in plural, like the verb, although it should be in singular. + +-- The peculiarity with "ihr" is the presence of "e" in forms without an ending. + + pronIhr = + {s = table { + NPPoss (GSg Masc) Nom => "euer" ; + NPPoss (GSg Neut) Nom => "euer" ; + NPPoss (GSg Neut) Acc => "euer" ; + pf => (mkPronPers "ihr" "euch" "euch" "euer" "eur" Pl P2).s ! pf + } ; + n = Pl ; + p = P2 + } ; + +-- Relative pronouns are like the definite article, except in the genitive and +-- the plural dative. The function $artDef$ will be defined right below. + + RelPron : Type = {s : GenNum => Case => Str} ; + + relPron : RelPron = {s = \\gn,c => + case of { + => "deren" ; + => "dessen" ; + => "denen" ; + => "deren" ; + _ => artDef ! gn ! c + } + } ; + + +--2 Articles +-- +-- Here are all forms the indefinite and definite article. +-- The indefinite article is like a large class of pronouns. +-- The definite article is more peculiar; we don't try to +-- subsume it to any general rule. + + artIndef : Gender => Case => Str = \\g,c => "ein" + pronEnding ! GSg g ! c ; + + artDef : GenNum => Case => Str = table { + GSg Masc => caselist "der" "den" "dem" "des" ; + GSg Fem => caselist "die" "die" "der" "der" ; + GSg Neut => caselist "das" "das" "dem" "des" ; + GPl => caselist "die" "die" "den" "der" + } ; + + +--2 Adjectives +-- +-- As explained in $types.Deu.gf$, it +-- would be superfluous to use the cross product of gender and number, +-- since there is no gender distinction in the plural. But it is handy to have +-- a function that constructs gender-number complexes. + + gNumber : Gender -> Number -> GenNum = \g,n -> + case n of { + Sg => GSg g ; + Pl => GPl + } ; + +-- It's also handy to have a function that finds out the number from such a complex. + + numGenNum : GenNum -> Number = \gn -> + case gn of { + GSg _ => Sg ; + GPl => Pl + } ; + +-- This function costructs parameters in the complex type of adjective forms. + + aMod : Adjf -> Gender -> Number -> Case -> AForm = \a,g,n,c -> + AMod a (gNumber g n) c ; + +-- The worst-case macro for adjectives (positive degree) only needs +-- two forms. + + mkAdjective : (_,_ : Str) -> Adjective = \böse,bös -> {s = table { + APred => böse ; + AMod Strong (GSg Masc) c => + caselist (bös+"er") (bös+"en") (bös+"em") (bös+"es") ! c ; + AMod Strong (GSg Fem) c => + caselist (bös+"e") (bös+"e") (bös+"er") (bös+"er") ! c ; + AMod Strong (GSg Neut) c => + caselist (bös+"es") (bös+"es") (bös+"em") (bös+"es") ! c ; + AMod Strong GPl c => + caselist (bös+"e") (bös+"e") (bös+"en") (bös+"er") ! c ; + AMod Weak (GSg g) c => case of { + <_,Nom> => bös+"e" ; + => bös+"en" ; + <_,Acc> => bös+"e" ; + _ => bös+"en" } ; + AMod Weak GPl c => bös+"en" + }} ; + +-- Here are some classes of adjectives: + + adjReg : Str -> Adjective = \gut -> mkAdjective gut gut ; + adjE : Str -> Adjective = \bös -> mkAdjective (bös+"e") bös ; + adjEr : Str -> Adjective = \teu -> mkAdjective (teu+"er") (teu+"r") ; + adjInvar : Str -> Adjective = \prima -> {s = table {_ => prima}} ; + +-- The first three classes can be recognized from the end of the word, depending +-- on if it is "e", "er", or something else. + + adjGen : Str -> Adjective = \gut -> let { + er = Predef.dp 2 gut ; + teu = Predef.tk 2 gut ; + e = Predef.dp 1 gut ; + bös = Predef.tk 1 gut + } in + ifTok Adjective er "er" (adjEr teu) ( + ifTok Adjective e "e" (adjE bös) ( + (adjReg gut))) ; + + +-- The comparison of adjectives needs three adjectives in the worst case. + + mkAdjComp : (_,_,_ : Adjective) -> AdjComp = \gut,besser,best -> + {s = table {Pos => gut.s ; Comp => besser.s ; Sup => best.s}} ; + +-- It can be done by just three strings, if each of the comparison +-- forms taken separately is a regular adjective. + + adjCompReg3 : (_,_,_ : Str) -> AdjComp = \gut,besser,best -> + mkAdjComp (adjReg gut) (adjReg besser) (adjReg best) ; + +-- If also the comparison forms are regular, one string is enough. + + adjCompReg : Str -> AdjComp = \billig -> + adjCompReg3 billig (billig+"er") (billig+"st") ; + + +--2 Verbs +-- +-- We limit ourselves to verbs in present tense infinitive, indicative, +-- and imperative, and past participle. Other forms will be introduced later. +-- +-- The worst-case macro needs three forms: the infinitive, the third person +-- singular indicative, and the second person singular imperative. +-- We take care of the special cases "ten", "sen", "ln", "rn". +-- +-- A famous law about Germanic languages says that plural first and third person +-- are similar. + + mkVerbum : (_,_,_,_ : Str) -> Verbum = \geben, gib, gb, gegeben -> + let { + en = Predef.dp 2 geben ; + geb = ifTok Tok (Predef.tk 1 en) "e" (Predef.tk 2 geben)(Predef.tk 1 geben) ; + gebt = ifTok Tok (Predef.dp 1 geb) "t" (geb + "et") (geb + "t") ; + gibst = ifTok Tok (Predef.dp 1 gib) "s" (gib + "t") (gib + "st") ; + gegebener = (adjReg gegeben).s + } in table { + VInf => geben ; + VInd Sg P1 => geb + "e" ; + VInd Sg P2 => gibst ; + VInd Sg P3 => gib + "t" ; + VInd Pl P2 => gebt ; + VInd Pl _ => geben ; -- the famous law + VImp Sg => gb ; + VImp Pl => gebt ; + VPart a => gegebener ! a + } ; + +-- Regular verbs: + + regVerb : Str -> Verbum = \legen -> + let {lege = ifTok Tok (Predef.dp 3 legen) "ten" (Predef.tk 1 legen) ( + ifTok Tok (Predef.dp 2 legen) "en" (Predef.tk 2 legen) ( + Predef.tk 1 legen))} in + mkVerbum legen lege lege ("ge" + (lege + "t")) ; + +-- Verbs ending with "t"; now recognized in $mkVerbum$. + + verbWarten : Str -> Verbum = regVerb ; + +-- Verbs with Umlaut in the second and third person singular and imperative: + + verbSehen : Str -> Str -> Str -> Verbum = \sehen, sieht, gesehen -> + let {sieh = Predef.tk 1 sieht} in mkVerbum sehen sieh sieh gesehen ; + +-- Verbs with Umlaut in the second and third person singular but not imperative: + + verbLaufen : Str -> Str -> Str -> Verbum = \laufen, läuft, gelaufen -> + let {läuf = Predef.tk 1 läuft ; laufe = Predef.tk 1 laufen} + in mkVerbum laufen läuf laufe gelaufen ; + +-- The verb "be": + + verbumSein : Verbum = let { + gewesen = (adjReg "gewesen").s + } in + table { + VInf => "sein" ; + VInd Sg P1 => "bin" ; + VInd Sg P2 => "bist" ; + VInd Sg P3 => "ist" ; + VInd Pl P2 => "seid" ; + VInd Pl _ => "sind" ; + VImp Sg => "sei" ; + VImp Pl => "seiet" ; + VPart a => gewesen ! a + } ; + +-- The verb "have": + + verbumHaben : Verbum = let { + haben = (regVerb "haben") + } in + table { + VInd Sg P2 => "hast" ; + VInd Sg P3 => "hat" ; + v => haben ! v + } ; + +-- The verb "become", used as the passive auxiliary: + + verbumWerden : Verbum = let { + werden = regVerb "werden" ; + geworden = (adjReg "geworden").s + } in + table { + VInd Sg P2 => "wirst" ; + VInd Sg P3 => "wird" ; + VPart a => geworden ! a ; + v => werden ! v + } ; + +-- A *full verb* ($Verb$) consists of the inflection forms ($Verbum$) and +-- a *particle* (e.g. "aus-sehen"). Simple verbs are the ones that have no +-- such particle. + + mkVerb : Verbum -> Particle -> Verb = \v,p -> {s = v ; s2 = p} ; + + mkVerbSimple : Verbum -> Verb = \v -> mkVerb v [] ; + + verbSein = mkVerbSimple verbumSein ; + verbHaben = mkVerbSimple verbumHaben ; + verbWerden = mkVerbSimple verbumWerden ; + +{- + -- tests for optimizer + verbumSein2 : Verbum = + table { + VInf => "sein" ; + VInd Sg P1 => "bin" ; + VInd Sg P2 => "bist" ; + VInd Sg P3 => "ist" ; + VInd Pl P2 => "seid" ; + VInd Pl _ => "sind" ; + VImp Sg => "sei" ; + VImp Pl => "seiet" ; + VPart a => (adjReg "gewesen").s ! a + } ; + + verbumHaben2 : Verbum = + table { + VInd Sg P2 => "hast" ; + VInd Sg P3 => "hat" ; + v => regVerb "haben" ! v + } ; +-} + +} ; + diff --git a/grammars/resource/german/Paradigms.gf b/grammars/resource/german/Paradigms.gf new file mode 100644 index 000000000..d31e3fecd --- /dev/null +++ b/grammars/resource/german/Paradigms.gf @@ -0,0 +1,300 @@ +--1 German Lexical Paradigms +-- +-- Aarne Ranta 2003 +-- +-- This is an API to the user of the resource grammar +-- for adding lexical items. It give shortcuts for forming +-- expressions of basic categories: nouns, adjectives, verbs. +-- +-- Closed categories (determiners, pronouns, conjunctions) are +-- accessed through the resource syntax API, $resource.Abs.gf$. +-- +-- The main difference with $morpho.Deu.gf$ is that the types +-- referred to are compiled resource grammar types. We have moreover +-- had the design principle of always having existing forms as string +-- arguments of the paradigms, not stems. +-- +-- The following modules are presupposed: + +resource Paradigms = open (Predef=Predef), Prelude, (Morpho=Morpho), Syntax, Deutsch in { + + +--2 Parameters +-- +-- To abstract over gender names, we define the following identifiers. + +oper + masculine : Gender ; + feminine : Gender ; + neuter : Gender ; + +-- To abstract over case names, we define the following. + + nominative : Case ; + accusative : Case ; + dative : Case ; + genitive : Case ; + +-- To abstract over number names, we define the following. + + singular : Number ; + plural : Number ; + + +--2 Nouns + +-- Worst case: give all four singular forms, two plural forms (others + dative), +-- and the gender. + + mkN : (_,_,_,_,_,_ : Str) -> Gender -> N ; + -- mann, mann, manne, mannes, männer, männern + +-- Often it is enough with singular and plural nominatives, and singular +-- genitive. The plural dative +-- is computed by the heuristic that it is the same as the nominative this +-- ends with "n" or "s", otherwise "n" is added. + + nGen : Str -> Str -> Str -> Gender -> N ; -- punkt,punktes,punkt + +-- Here are some common patterns. Singular nominative or two nominatives are needed. +-- Two forms are needed in case of Umlaut, which would be complicated to define. +-- For the same reason, we have separate patterns for multisyllable stems. +-- +-- The weak masculine pattern $nSoldat$ avoids duplicating the final "e". + + nRaum : (_,_ : Str) -> N ; -- Raum, (Raumes,) Räume (masc) + nTisch : Str -> N ; -- Tisch, (Tisches, Tische) (masc) + nVater : (_,_ : Str) -> N ; -- Vater, (Vaters,) Väter (masc) + nFehler : Str -> N ; -- Fehler, (fehlers, Fehler) (masc) + nSoldat : Str -> N ; -- Soldat (, Soldaten) ; Kunde (, Kunden) (masc) + +-- Neuter patterns. + + nBuch : (_,_ : Str) -> N ; -- Buch, (Buches, Bücher) (neut) + nMesser : Str -> N ; -- Messer, (Messers, Messer) (neut) + nAuto : Str -> N ; -- Auto, (Autos, Autos) (neut) + +-- Feminine patterns. Duplicated "e" is avoided in $nFrau$. + + nHand : (_,_ : Str) -> N ; -- Hand, Hände; Mutter, Mütter (fem) + nFrau : Str -> N ; -- Frau (, Frauen) ; Wiese (, Wiesen) (fem) + + +-- Nouns used as functions need a preposition. The most common is "von". + + mkFun : N -> Preposition -> Case -> Fun ; + funVon : N -> Fun ; + +-- Proper names, with their possibly +-- irregular genitive. The regular genitive is "s", omitted after "s". + + mkPN : (karolus, karoli : Str) -> PN ; -- karolus, karoli + pnReg : (Johann : Str) -> PN ; -- Johann, Johanns ; Johannes, Johannes + +-- On the top level, it is maybe $CN$ that is used rather than $N$, and +-- $NP$ rather than $PN$. + + mkCN : N -> CN ; + mkNP : (karolus,karoli : Str) -> NP ; + + npReg : Str -> NP ; -- Johann, Johanns + +-- In some cases, you may want to make a complex $CN$ into a function. + + mkFunCN : CN -> Preposition -> Case -> Fun ; + funVonCN : CN -> Fun ; + + +--2 Adjectives + +-- Non-comparison one-place adjectives need two forms in the worst case: +-- the one in predication and the one before the ending "e". + + mkAdj1 : (teuer,teur : Str) -> Adj1 ; + +-- Invariable adjective are a special case. + + adjInvar : Str -> Adj1 ; -- prima + +-- The following heuristic recognizes the the end of the word, and builds +-- the second form depending on if it is "e", "er", or something else. +-- N.B. a contraction is made with "er", which works for "teuer" but not +-- for "bitter". + + adjGen : Str -> Adj1 ; -- gut; teuer; böse + +-- Two-place adjectives need a preposition and a case as extra arguments. + + mkAdj2 : Adj1 -> Str -> Case -> Adj2 ; -- teilbar, durch, acc + +-- Comparison adjectives may need three adjective, corresponding to the +-- three comparison forms. + + mkAdjDeg : (gut,besser,best : Adj1) -> AdjDeg ; + +-- In many cases, each of these adjectives is itself regular. Then we only +-- need three strings. Notice that contraction with "er" is not performed +-- ("bessere", not "bessre"). + + aDeg3 : (gut,besser,best : Str) -> AdjDeg ; + +-- In the completely regular case, the comparison forms are constructed by +-- the endings "er" and "st". + + aReg : Str -> AdjDeg ; -- billig, billiger, billigst + +-- The past participle of a verb can be used as an adjective. + + aPastPart : V -> Adj1 ; -- gefangen + +-- On top level, there are adjectival phrases. The most common case is +-- just to use a one-place adjective. The variation in $adjGen$ is taken +-- into account. + + apReg : Str -> AP ; + + +--2 Verbs +-- +-- The fragment only has present tense so far, but in all persons. +-- It also has the infinitive and the past participles. +-- The worst case macro needs four forms: : the infinitive and +-- the third person singular (where Umlaut may occur), the singular imperative, +-- and the past participle. +-- +-- The function recognizes if the stem ends with "s" or "t" and performs the +-- appropriate contractions. + + mkV : (_,_,_,_ : Str) -> V ; -- geben, gibt, gib, gegeben + +-- Regular verbs are those where no Umlaut occurs. + + vReg : Str -> V ; -- kommen + +-- The verbs 'be' and 'have' are special. + + vSein : V ; + vHaben : V ; + +-- Verbs with a detachable particle, with regular ones as a special case. + + vPart : (_,_,_,_,_ : Str) -> V ; -- sehen, sieht, sieh, gesehen, aus + vPartReg : (_,_ : Str) -> V ; -- bringen, um + +-- Two-place verbs, and the special case with direct object. Notice that +-- a particle can be included in a $V$. + + mkTV : V -> Str -> Case -> TV ; -- hören, zu, dative + + tvReg : Str -> Str -> Case -> TV ; -- hören, zu, dative + tvDir : V -> TV ; -- umbringen + tvDirReg : Str -> TV ; -- lieben + +--2 Adverbials +-- +-- Adverbials for modifying verbs, adjectives, and sentences can be formed +-- from strings. + + mkAdV : Str -> AdV ; + mkAdA : Str -> AdA ; + mkAdS : Str -> AdS ; + +-- Prepositional phrases are another productive form of adverbials. + + mkPP : Case -> Str -> NP -> AdV ; + +-- The definitions should not bother the user of the API. So they are +-- hidden from the document. +--. + + + masculine = Masc ; + feminine = Fem ; + neuter = Neut ; + nominative = Nom ; + accusative = Acc ; + dative = Dat ; + genitive = Gen ; + -- singular defined in Types + -- plural defined in Types + + mkN = mkNoun ; + + nGen = \punkt, punktes, punkte, g -> let { + e = Predef.dp 1 punkte ; + eqy = ifTok (Gender -> N) e ; + noN = mkNoun4 punkt punktes punkte punkte + } in + eqy "n" noN ( + eqy "s" noN ( + mkNoun4 punkt punktes punkte (punkte+"n"))) g ; + + nRaum = \raum, räume -> nGen raum (raum + "es") räume masculine ; + nTisch = \tisch -> + mkNoun4 tisch (tisch + "es") (tisch + "e") (tisch +"en") masculine ; + nVater = \vater, väter -> nGen vater (vater + "s") väter masculine ; + nFehler = \fehler -> nVater fehler fehler ; + + nSoldat = \soldat -> let { + e = Predef.dp 1 soldat ; + soldaten = ifTok Tok e "e" (soldat + "n") (soldat + "en") + } in + mkN soldat soldaten soldaten soldaten soldaten soldaten masculine ; + + nBuch = \buch, bücher -> nGen buch (buch + "es") bücher neuter ; + nMesser = \messer -> nGen messer (messer + "s") messer neuter ; + nAuto = \auto -> let {autos = auto + "s"} in + mkNoun4 auto autos autos autos neuter ; + + nHand = \hand, hände -> nGen hand hand hände feminine ; + + nFrau = \frau -> let { + e = Predef.dp 1 frau ; + frauen = ifTok Tok e "e" (frau + "n") (frau + "en") + } in + mkN frau frau frau frau frauen frauen feminine ; + + mkFun = \n -> mkFunCN (n2n n) ; + funVon = \n -> funVonCN (n2n n) ; + + mkPN = \karolus, karoli -> {s = table {Gen => karoli ; _ => karolus}} ; + pnReg = \horst -> + mkPN horst (ifTok Tok (Predef.dp 1 horst) "s" horst (horst + "s")) ; + + mkCN = UseN ; + mkNP = \x,y -> UsePN (mkPN x y) ; + npReg = \s -> UsePN (pnReg s) ; + + mkFunCN = mkFunC ; + funVonCN = funVonC ; + + mkAdj1 = mkAdjective ; + adjInvar = Morpho.adjInvar ; + adjGen = Morpho.adjGen ; + mkAdj2 = \a,p,c -> a ** {s2 = p ; c = c} ; + + mkAdjDeg = mkAdjComp ; + aDeg3 = adjCompReg3 ; + aReg = adjCompReg ; + aPastPart = \v -> {s = table AForm {a => v.s ! VPart a}} ; + apReg = \s -> AdjP1 (adjGen s) ; + + mkV = \sehen, sieht, sieh, gesehen -> + mkVerbSimple (mkVerbum sehen sieht sieh gesehen) ; + vReg = \s -> mkVerbSimple (regVerb s) ; + vSein = verbSein ; + vHaben = verbHaben ; + vPart = \sehen, sieht, sieh, gesehen, aus -> + mkVerb (mkVerbum sehen sieht sieh gesehen) aus ; + vPartReg = \sehen, aus -> mkVerb (regVerb sehen) aus ; + + mkTV = mkTransVerb ; + tvReg = \hören, zu, dat -> mkTV (vReg hören) zu dat ; + tvDir = \v -> mkTV v [] accusative ; + tvDirReg = \v -> tvReg v [] accusative ; + + mkAdV = ss ; + mkPP = prepPhrase ; + mkAdA = ss ; + mkAdS = ss ; +} ; diff --git a/grammars/resource/german/Predication.gf b/grammars/resource/german/Predication.gf new file mode 100644 index 000000000..9c05cc69b --- /dev/null +++ b/grammars/resource/german/Predication.gf @@ -0,0 +1,87 @@ + +--1 A Small Predication Library +-- +-- (c) Aarne Ranta 2003 under Gnu GPL. +-- +-- This library is built on a language-independent API of +-- resource grammars. It has a common part, the type signatures +-- (defined here), and language-dependent parts. The user of +-- the library should only have to look at the type signatures. + +resource Predication = open Deutsch in { + +-- We first define a set of predication patterns. + +oper + predV1 : V -> NP -> S ; -- one-place verb: "John walks" + predV2 : TV -> NP -> NP -> S ; -- two-place verb: "John loves Mary" + predVColl : V -> NP -> NP -> S ; -- collective verb: "John and Mary fight" + predA1 : Adj1 -> NP -> S ; -- one-place adjective: "John is old" + predA2 : Adj2 -> NP -> NP -> S ; -- two-place adj: "John is married to Mary" + predAComp : AdjDeg -> NP -> NP -> S ; -- compar adj: "John is older than Mary" + predAColl : Adj1 -> NP -> NP -> S ; -- collective adj: "John and Mary are married" + predN1 : N -> NP -> S ; -- one-place noun: "John is a man" + predN2 : Fun -> NP -> NP -> S ; -- two-place noun: "John is a lover of Mary" + predNColl : N -> NP -> NP -> S ; -- collective noun: "John and Mary are lovers" + +-- Individual-valued function applications. + + appFun1 : Fun -> NP -> NP ; -- one-place function: "the successor of x" + appFun2 : Fun -> NP -> NP -> NP ; -- two-place function: "the line from x to y" + appFunColl : Fun -> NP -> NP -> NP ; -- collective function: "the sum of x and y" + +-- Families of types, expressed by common nouns depending on arguments. + + appFam1 : Fun -> NP -> CN ; -- one-place family: "divisor of x" + appFam2 : Fun -> NP -> NP -> CN ; -- two-place family: "line from x to y" + appFamColl : Fun -> NP -> NP -> CN ; -- collective family: "path between x and y" + +-- Type constructor, similar to a family except that the argument is a type. + + constrTyp1 : Fun -> CN -> CN ; + +-- Logical connectives on two sentences. + + conjS : S -> S -> S ; + disjS : S -> S -> S ; + implS : S -> S -> S ; + +-- As an auxiliary, we need two-place conjunction of names ("John and Mary"), +-- used in collective predication. + + conjNP : NP -> NP -> NP ; + + +----------------------------- + +---- what follows should be an implementation of the preceding + +oper + predV1 = \F, x -> PredVP x (PosV F) ; + predV2 = \F, x, y -> PredVP x (PosTV F y) ; + predVColl = \F, x, y -> PredVP (conjNP x y) (PosV F) ; + predA1 = \F, x -> PredVP x (PosA F) ; + predA2 = \F, x, y -> PredVP x (PosA (ComplAdj F y)) ; + predAComp = \F, x, y -> PredVP x (PosA (ComparAdjP F y)) ; + predAColl = \F, x, y -> PredVP (conjNP x y) (PosA F) ; + predN1 = \F, x -> PredVP x (PosCN (UseN F)) ; + predN2 = \F, x, y -> PredVP x (PosCN (AppFun F y)) ; + predNColl = \F, x, y -> PredVP (conjNP x y) (PosCN (UseN F)) ; + + appFun1 = \f, x -> DefOneNP (AppFun f x) ; + appFun2 = \f, x, y -> DefOneNP (AppFun (AppFun2 f x) y) ; + appFunColl = \f, x, y -> DefOneNP (AppFun f (conjNP x y)) ; + + appFam1 = \F, x -> AppFun F x ; + appFam2 = \F, x, y -> AppFun (AppFun2 F x) y ; + appFamColl = \F, x, y -> AppFun F (conjNP x y) ; + + conjS = \A, B -> ConjS AndConj (TwoS A B) ; + disjS = \A, B -> ConjS OrConj (TwoS A B) ; + implS = \A, B -> SubjS IfSubj A B ; + + constrTyp1 = \F, A -> AppFun F (IndefManyNP A) ; + + conjNP = \x, y -> ConjNP AndConj (TwoNP x y) ; + +} ; diff --git a/grammars/resource/german/ResDeu.gf b/grammars/resource/german/ResDeu.gf new file mode 100644 index 000000000..dd2b160b3 --- /dev/null +++ b/grammars/resource/german/ResDeu.gf @@ -0,0 +1,217 @@ +--1 The Top-Level German Resource Grammar +-- +-- Aarne Ranta 2002 -- 2003 +-- +-- This is the German concrete syntax of the multilingual resource +-- grammar. Most of the work is done in the file $syntax.Deu.gf$. +-- However, for the purpose of documentation, we make here explicit the +-- linearization types of each category, so that their structures and +-- dependencies can be seen. +-- Another substantial part are the linearization rules of some +-- structural words. +-- +-- The users of the resource grammar should not look at this file for the +-- linearization rules, which are in fact hidden in the document version. +-- They should use $resource.Abs.gf$ to access the syntactic rules. +-- This file can be consulted in those, hopefully rare, occasions in which +-- one has to know how the syntactic categories are +-- implemented. The parameter types are defined in $Types.gf$. + +concrete ResDeu of ResAbs = open Prelude, Syntax in { + +flags + startcat=Phr ; + parser=chart ; + +lincat + CN = CommNounPhrase ; + -- = {s : Adjf => Number => Case => Str ; g : Gender} ; + N = CommNoun ; + -- = {s : Number => Case => Str ; g : Gender} ; + NP = NounPhrase ; + -- = {s : NPForm => Str ; n : Number ; p : Person ; pro : Bool} ; + PN = ProperName ; + -- = {s : Case => Str} ; + Det = {s : Gender => Case => Str ; n : Number ; a : Adjf} ; + Fun = Function ; + -- = CommNounPhrase ** {s2 : Preposition ; c : Case} ; + Fun2 = Function ** {s3 : Preposition ; c2 : Case} ; + + Adj1 = Adjective ; + -- = {s : AForm => Str} ; + Adj2 = Adjective ** {s2 : Preposition ; c : Case} ; + AdjDeg = {s : Degree => AForm => Str} ; + AP = Adjective ** {p : Bool} ; + + V = Verb ; + -- = {s : VForm => Str ; s2 : Particle} ; + VP = Verb ** {s3 : Number => Str} ; + TV = Verb ** {s3 : Preposition ; c : Case} ; + VS = Verb ; + AdV = {s : Str} ; + + S = Sentence ; + -- = {s : Order => Str} ; + Slash = Sentence ** {s2 : Preposition ; c : Case} ; + + RP = {s : GenNum => Case => Str} ; + RC = {s : GenNum => Str} ; + + IP = ProperName ** {n : Number} ; + Qu = {s : QuestForm => Str} ; + Imp = {s : Number => Str} ; + Phr = {s : Str} ; + Text = {s : Str} ; + + Conj = {s : Str ; n : Number} ; + ConjD = {s1,s2 : Str ; n : Number} ; + + ListS = {s1,s2 : Order => Str} ; + ListAP = {s1,s2 : AForm => Str ; p : Bool} ; + ListNP = {s1,s2 : NPForm => Str ; n : Number ; p : Person ; pro : Bool} ; + +--. + +lin + UseN = noun2CommNounPhrase ; + ModAdj = modCommNounPhrase ; + ModGenOne = npGenDet singular ; + ModGenMany = npGenDet plural ; + UsePN = nameNounPhrase ; + UseFun = funAsCommNounPhrase ; + AppFun = appFunComm ; + AppFun2 = appFun2 ; + AdjP1 = adj2adjPhrase ; + ComplAdj = complAdj ; + PositAdjP = positAdjPhrase ; + ComparAdjP = comparAdjPhrase ; + SuperlNP = superlNounPhrase ; + + DetNP = detNounPhrase ; + IndefOneNP = indefNounPhrase singular ; + IndefManyNP = indefNounPhrase plural ; + DefOneNP = defNounPhrase singular ; + DefManyNP = defNounPhrase plural ; + + CNthatS = nounThatSentence ; + + PredVP = predVerbPhrase ; + PosV = predVerb True ; + NegV = predVerb False ; + PosA = predAdjective True ; + NegA = predAdjective False ; + PosCN = predCommNoun True ; + NegCN = predCommNoun False ; + PosTV = complTransVerb True ; + NegTV = complTransVerb False ; + PosPassV = passVerb True ; + NegPassV = passVerb False ; + PosNP = predNounPhrase True ; + NegNP = predNounPhrase False ; + PosVS = complSentVerb True ; + NegVS = complSentVerb False ; + + AdvVP = adVerbPhrase ; + LocNP = locativeNounPhrase ; + AdvCN = advCommNounPhrase ; + AdvAP = advAdjPhrase ; + + PosSlashTV = slashTransVerb True ; + NegSlashTV = slashTransVerb False ; + OneVP = predVerbPhrase (nameNounPhrase {s = \\_ => "man"}) ; + + IdRP = identRelPron ; + FunRP = funRelPron ; + RelVP = relVerbPhrase ; + RelSlash = relSlash ; + ModRC = modRelClause ; + RelSuch = relSuch ; + + WhoOne = intPronWho singular ; + WhoMany = intPronWho plural ; + WhatOne = intPronWhat singular ; + WhatMany = intPronWhat plural ; + FunIP = funIntPron ; + NounIPOne = nounIntPron singular ; + NounIPMany = nounIntPron plural ; + + QuestVP = questVerbPhrase ; + IntVP = intVerbPhrase ; + IntSlash = intSlash ; + QuestAdv = questAdverbial ; + + ImperVP = imperVerbPhrase ; + + IndicPhrase = indicUtt ; + QuestPhrase = interrogUtt ; + ImperOne = imperUtterance singular ; + ImperMany = imperUtterance plural ; + + AdvS = advSentence ; + +lin + TwoS = twoSentence ; + ConsS = consSentence ; + ConjS = conjunctSentence ; + ConjDS = conjunctDistrSentence ; + + TwoAP = twoAdjPhrase ; + ConsAP = consAdjPhrase ; + ConjAP = conjunctAdjPhrase ; + ConjDAP = conjunctDistrAdjPhrase ; + + TwoNP = twoNounPhrase ; + ConsNP = consNounPhrase ; + ConjNP = conjunctNounPhrase ; + ConjDNP = conjunctDistrNounPhrase ; + + SubjS = subjunctSentence ; + SubjImper = subjunctImperative ; + SubjQu = subjunctQuestion ; + + PhrNP = useNounPhrase ; + PhrOneCN = useCommonNounPhrase singular ; + PhrManyCN = useCommonNounPhrase plural ; + PhrIP ip = ip ; + PhrIAdv ia = ia ; + + OnePhr p = p ; + ConsPhr = cc2 ; + + INP = pronNounPhrase pronIch ; + ThouNP = pronNounPhrase pronDu ; + HeNP = pronNounPhrase pronEr ; + SheNP = pronNounPhrase pronSie ; + ItNP = pronNounPhrase pronEs ; + WeNP = pronNounPhrase pronWir ; + YeNP = pronNounPhrase pronIhr ; + TheyNP = pronNounPhrase pronSiePl ; + + YouNP = pronNounPhrase pronSSie ; + + EveryDet = jederDet ; + AllDet = alleDet ; + WhichDet = welcherDet ; + MostDet = meistDet ; + + HowIAdv = ss "wie" ; + WhenIAdv = ss "wann" ; + WhereIAdv = ss "war" ; + WhyIAdv = ss "warum" ; + + AndConj = ss "und" ** {n = Pl} ; + OrConj = ss "oder" ** {n = Sg} ; + BothAnd = sd2 "sowohl" ["als auch"] ** {n = Pl} ; + EitherOr = sd2 "entweder" "oder" ** {n = Sg} ; + NeitherNor = sd2 "weder" "noch" ** {n = Sg} ; + IfSubj = ss "wenn" ; + WhenSubj = ss "wenn" ; + + PhrYes = ss ["Ja ."] ; + PhrNo = ss ["Nein ."] ; + + VeryAdv = ss "sehr" ; + TooAdv = ss "zu" ; + OtherwiseAdv = ss "sonst" ; + ThereforeAdv = ss "deshalb" ; +} ; diff --git a/grammars/resource/german/RestaurantDeu.gf b/grammars/resource/german/RestaurantDeu.gf new file mode 100644 index 000000000..3a6d6f8d6 --- /dev/null +++ b/grammars/resource/german/RestaurantDeu.gf @@ -0,0 +1,24 @@ +concrete RestaurantDeu of Restaurant = + DatabaseDeu ** open Prelude,Paradigms,Deutsch,DatabaseRes in { + +lin + Restaurant = UseN (nAuto "Restaurant") ; + Bar = UseN (nAuto "Bar") ; --- ?? + French = apReg "Französisch" ; + Italian = apReg "Italienisch" ; + Indian = apReg "Indisch" ; + Japanese = apReg "Japanisch" ; + + address = funVon (nFrau "Adresse") ; + phone = funVon (nFrau "Rufnummer") ; ---- + priceLevel = funVon (nFrau "Preisstufe") ; + + Cheap = aReg "billig" ; + Expensive = aDeg3 "teuer" "teurer" "teurest" ; + + WhoRecommend rest = mkSentSame (ss2 ["wer empfiehlt"] (rest.s ! accusative)) ; + WhoHellRecommend rest = + mkSentSame (ss2 ["wer zum Teufel empfiehlt"] (rest.s ! accusative)) ; + + LucasCarton = mkPN ["Lucas Carton"] ["Lucas Cartons"] ; +} ; diff --git a/grammars/resource/german/Syntax.gf b/grammars/resource/german/Syntax.gf new file mode 100644 index 000000000..904cd1903 --- /dev/null +++ b/grammars/resource/german/Syntax.gf @@ -0,0 +1,891 @@ +--1 A Small German Resource Syntax +-- +-- Aarne Ranta 2002 +-- +-- This resource grammar contains definitions needed to construct +-- indicative, interrogative, and imperative sentences in German. +-- +-- The following modules are presupposed: + +resource Syntax = Morpho ** open Prelude, (CO = Coordination) in { + +--2 Common Nouns +-- +-- Simple common nouns are defined as the type $CommNoun$ in $morpho.Deu.gf$. + +--3 Common noun phrases + +-- The need for this more complex type comes from the variation in the way in +-- which a modifying adjective is inflected after different determiners. +-- We use the $Adjf$ parameter for this ($Strong$/$Weak$). + +oper + + CommNounPhrase : Type = {s : Adjf => Number => Case => Str ; g : Gender} ; + + noun2CommNounPhrase : CommNoun -> CommNounPhrase = \haus -> + {s = \\_ => haus.s ; g = haus.g} ; + + n2n = noun2CommNounPhrase ; + + + +--2 Noun phrases +-- +-- The worst case is pronouns, which have inflection in the possessive +-- forms. Other noun phrases express all possessive forms with the genitive case. +-- The parameter $pro$ tells if the $NP$ is a pronoun, which is needed in e.g. +-- genitive constructions. + + NounPhrase : Type = { + s : NPForm => Str ; + n : Number ; + p : Person ; + pro : Bool + } ; + + pronNounPhrase : ProPN -> NounPhrase = \ich -> + ich ** {pro = True} ; + + caseNP : NPForm -> Case = \np -> case np of { + NPCase c => c ; + NPPoss _ _ => Gen + } ; + + normalNounPhrase : (Case => Str) -> Number -> NounPhrase = \cs,n -> + {s = \\c => cs ! caseNP c ; + n = n ; + p = P3 ; -- third person + pro = False -- not a pronoun + } ; + +-- Proper names are a simple kind of noun phrases. They can usually +-- be constructed from strings in a regular way. + + ProperName : Type = {s : Case => Str} ; + + nameNounPhrase : ProperName -> NounPhrase = \john -> + {s = \\np => john.s ! caseNP np ; n = Sg ; p = P3 ; pro = False} ; + + mkProperName : Str -> ProperName = \horst -> + {s = table {Gen => horst + "s" ; _ => horst}} ; + +--2 Determiners +-- +-- Determiners are inflected according to the nouns they determine. +-- The determiner determines the number and adjectival form from the determiner. + + Determiner : Type = {s : Gender => Case => Str ; n : Number ; a : Adjf} ; + + detNounPhrase : Determiner -> CommNounPhrase -> NounPhrase = \ein, mann -> + {s = \\c => let {nc = caseNP c} in + ein.s ! mann.g ! nc ++ mann.s ! adjfCas ein.a nc ! ein.n ! nc ; + p = P3 ; + n = ein.n ; + pro = False + } ; + +-- The adjectival form after a determiner depends both on the inferent form +-- and on the case ("ein alter Mann" but "einem alten Mann"). + + adjfCas : Adjf -> Case -> Adjf = \a,c -> case of { + => Strong ; + => Strong ; + _ => Weak + } ; + +-- The following macros are sufficient to define most determiners, +-- as shown by the examples that follow. + + DetSg = Gender => Case => Str ; + DetPl = Case => Str ; + + mkDeterminerSg : DetSg -> Adjf -> Determiner = \ein, a -> + {s = ein ; n = Sg ; a = a} ; + + mkDeterminerPl : DetPl -> Adjf -> Determiner = \alle, a -> + {s = \\_ => alle ; n = Pl ; a = a} ; + + detLikeAdj : Str -> Determiner = \jed -> mkDeterminerSg + (\\g,c => (adjReg jed).s ! AMod Strong (GSg g) c) Weak ; + + jederDet = detLikeAdj "jed" ; + alleDet = mkDeterminerPl (caselist "alle" "alle" "allen" "aller") Weak ; + einDet = mkDeterminerSg artIndef Strong ; + derDet = mkDeterminerSg (table {g => artDef ! GSg g}) Weak ; + dieDet = mkDeterminerPl (artDef ! GPl) Weak ; + + meistDet = mkDeterminerPl (table {c => artDef ! GPl ! c ++ "meisten"}) Weak ; + welcherDet = detLikeAdj "welch" ; + welcheDet = mkDeterminerPl (caselist "welche" "welche" "welchen" "welcher") Weak ; + +-- Choose "welcher"/"welche" + + welchDet : Number -> Determiner = \n -> + case n of {Sg => welcherDet ; Pl => welcheDet} ; + +-- Genitives of noun phrases can be used like determiners, to build noun phrases. +-- The number argument makes the difference between "mein Haus" - "meine Häuser". +-- +-- If the 'owner' is a pronoun, only one form is available "mein Haus". +-- In other cases, two variants are available: "Johanns Haus" / "das Haus Johanns". + + npGenDet : Number -> NounPhrase -> CommNounPhrase -> NounPhrase = \n,haus,Wein -> + let { + hauses : Case => Str = \\c => haus.s ! NPPoss (gNumber Wein.g n) c ; + wein : NPForm => Str = \\c => Wein.s ! Strong ! n ! caseNP c ; + derwein : NPForm => Str = (defNounPhrase n Wein).s + } + in + {s = \\c => variants { + hauses ! caseNP c ++ wein ! c ; + if_then_else Str haus.pro + nonExist + (derwein ! c ++ hauses ! Nom) -- the case does not matter + } ; + p = P3 ; + n = n ; + pro = False + } ; + +-- *Bare plural noun phrases* like "Männer", "gute Häuser", are built without a +-- determiner word. + + plurDet : CommNounPhrase -> NounPhrase = \cn -> + normalNounPhrase (cn.s ! Strong ! Pl) Pl ; + +-- Macros for indef/def Sg/Pl noun phrases are needed in many places even +-- if they might not be constituents. + + indefNounPhrase : Number -> CommNounPhrase -> NounPhrase = \n,haus -> case n of { + Sg => detNounPhrase einDet haus ; + Pl => plurDet haus + } ; + + defNounPhrase : Number -> CommNounPhrase -> NounPhrase = \n,haus -> case n of { + Sg => detNounPhrase derDet haus ; + Pl => detNounPhrase dieDet haus + } ; + + indefNoun : Number -> CommNounPhrase -> Str = \n, mann -> case n of { + Sg => (detNounPhrase einDet mann).s ! NPCase Nom ; + Pl => (plurDet mann).s ! NPCase Nom + } ; + +-- Constructions like "die Idee, dass zwei gerade ist" are formed at the +-- first place as common nouns, so that one can also have "ein Vorschlag, dass...". + + nounThatSentence : CommNounPhrase -> Sentence -> CommNounPhrase = \idee,x -> + {s = \\a,n,c => idee.s ! a! n ! c ++ [", dass"] ++ x.s ! Sub ; + g = idee.g + } ; + +--2 Adjectives +-- +-- Adjectival phrases have a parameter $p$ telling if postposition is +-- allowed (complex APs). + + AdjPhrase : Type = Adjective ** {p : Bool} ; + + adj2adjPhrase : Adjective -> AdjPhrase = \ny -> ny ** {p = False} ; + +--3 Comparison adjectives +-- +-- The type is defined in $types.Deu.gf$. + + AdjDegr : Type = AdjComp ; + +-- Each of the comparison forms has a characteristic use: +-- +-- Positive forms are used alone, as adjectival phrases ("jung"). + + positAdjPhrase : AdjDegr -> AdjPhrase = \jung -> + {s = jung.s ! Pos ; p = False} ; + +-- Comparative forms are used with an object of comparison, as +-- adjectival phrases ("besser als Rolf"). + + comparAdjPhrase : AdjDegr -> NounPhrase -> AdjPhrase = \besser,rolf -> + {s = \\a => besser.s ! Comp ! a ++ "als" ++ rolf.s ! NPCase Nom ; + p = True + } ; + +-- Superlative forms are used with a common noun, picking out the +-- maximal representative of a domain ("der Jüngste Mann"). + + superlNounPhrase : AdjDegr -> CommNounPhrase -> NounPhrase = \best,mann -> + let {gen = mann.g} in + {s = \\c => let {nc = caseNP c} in + artDef ! gNumber gen Sg ! nc ++ + best.s ! Sup ! aMod Weak gen Sg nc ++ + mann.s ! Weak ! Sg ! nc ; + p = P3 ; + n = Sg ; + pro = False + } ; + +--3 Two-place adjectives +-- +-- A two-place adjective is an adjective with a preposition used before +-- the complement, and the complement case. + + AdjCompl = Adjective ** {s2 : Preposition ; c : Case} ; + + complAdj : AdjCompl -> NounPhrase -> AdjPhrase = \verwandt,dich -> + {s = \\a => + bothWays (verwandt.s ! a) (verwandt.s2 ++ dich.s ! NPCase verwandt.c) ; + p = True + } ; + +--3 Modification of common nouns +-- +-- The two main functions of adjective are in predication ("Johann ist jung") +-- and in modification ("ein junger Mann"). Predication will be defined +-- later, in the chapter on verbs. +-- +-- Modification must pay attention to pre- and post-noun +-- adjectives: "gutes Haus"; "besseres als X haus" / "haus besseres als X" + + modCommNounPhrase : AdjPhrase -> CommNounPhrase -> CommNounPhrase = \gut,haus -> + {s = \\a,n,c => let { + gutes = gut.s ! aMod a haus.g n c ; + Haus = haus.s ! a ! n ! c + } in + if_then_else Str gut.p (bothWays gutes Haus) (gutes ++ Haus) ; + g = haus.g} ; + +--2 Function expressions + +-- A function expression is a common noun together with the +-- preposition prefixed to its argument ("Mutter von x"). +-- The type is analogous to two-place adjectives and transitive verbs. + + Function = CommNounPhrase ** {s2 : Preposition ; c : Case} ; + +-- The application of a function gives, in the first place, a common noun: +-- "Mutter/Mütter von Johann". From this, other rules of the resource grammar +-- give noun phrases, such as "die Mutter von Johann", "die Mütter von Johann", +-- "die Mütter von Johann und Maria", and "die Mutter von Johann und Maria" (the +-- latter two corresponding to distributive and collective functions, +-- respectively). Semantics will eventually tell when each +-- of the readings is meaningful. + + appFunComm : Function -> NounPhrase -> CommNounPhrase = \mutter,uwe -> + {s = \\a,n,c => mutter.s ! a ! n ! c ++ mutter.s2 ++ uwe.s ! NPCase mutter.c ; + g = mutter.g + } ; + +-- It is possible to use a function word as a common noun; the semantics is +-- often existential or indexical. + + funAsCommNounPhrase : Function -> CommNounPhrase = \x -> x ; + +-- The following is an aggregate corresponding to the original function application +-- producing "Johanns Mutter" and "die Mutter von Johann". It does not appear in the +-- resource grammar API any longer. + + appFun : Bool -> Function -> NounPhrase -> NounPhrase = \coll, mutter, uwe -> + let {n = uwe.n ; g = mutter.g ; nf = if_then_else Number coll Sg n} in + variants { + defNounPhrase nf (appFunComm mutter uwe) ; + npGenDet nf uwe mutter + } ; + +-- The commonest cases are functions with "von" and functions with Genitive. + + mkFunC : CommNounPhrase -> Preposition -> Case -> Function = \f,p,c -> + f ** {s2 = p ; c = c} ; + + funVonC : CommNounPhrase -> Function = \wert -> + mkFunC wert "von" Dat ; + + funGenC : CommNounPhrase -> Function = \wert -> + mkFunC wert [] Gen ; + +-- Two-place functions add one argument place. + + Function2 = Function ** {s3 : Preposition ; c2 : Case} ; + +-- There application starts by filling the first place. + + appFun2 : Function2 -> NounPhrase -> Function = \flug, paris -> + {s = \\a,n,c => flug.s ! a ! n ! c ++ flug.s2 ++ paris.s ! NPCase flug.c ; + g = flug.g ; + s2 = flug.s3 ; + c = flug.c2 + } ; + + +--2 Verbs +-- +--3 Verb phrases +-- +-- Verb phrases are discontinuous: the parts of a verb phrase are +-- (s) an inflected verb, (s2) particle, and +-- (s3) negation and complement. This discontinuity is needed in sentence formation +-- to account for word order variations. + + VerbPhrase = Verb ** {s3 : Number => Str} ; + +-- A simple verb can be made into a verb phrase with an empty complement. +-- There are two versions, depending on if we want to negate the verb. +-- N.B. negation is *not* a function applicable to a verb phrase, since +-- double negations with "nicht" are not grammatical. + + predVerb : Bool -> Verb -> VerbPhrase = \b,aussehen -> + aussehen ** { + s3 = \\_ => negation b + } ; + + negation : Bool -> Str = \b -> if_then_else Str b [] "nicht" ; + +-- Sometimes we want to extract the verb part of a verb phrase. + + verbOfPhrase : VerbPhrase -> Verb = \v -> {s = v.s ; s2 = v.s2} ; + +-- Verb phrases can also be formed from adjectives ("ist gut"), +-- common nouns ("ist ein Mann"), and noun phrases ("ist der jüngste Mann"). +-- The third rule is overgenerating: "ist jeder Mann" has to be ruled out +-- on semantic grounds. + + predAdjective : Bool -> Adjective -> VerbPhrase = \b,gut -> + verbSein ** { + s3 = \\_ => negation b ++ gut.s ! APred + } ; + + predCommNoun : Bool -> CommNounPhrase -> VerbPhrase = \b,man -> + verbSein ** { + s3 = \\n => negation b ++ indefNoun n man + } ; + + predNounPhrase : Bool -> NounPhrase -> VerbPhrase = \b,dermann -> + verbSein ** { + s3 = \\n => negation b ++ dermann.s ! NPCase Nom + } ; + +--3 Transitive verbs +-- +-- Transitive verbs are verbs with a preposition for the complement, +-- in analogy with two-place adjectives and functions. +-- One might prefer to use the term "2-place verb", since +-- "transitive" traditionally means that the inherent preposition is empty. +-- Such a verb is one with a *direct object* - which may still be accusative, +-- dative, or genitive. + + TransVerb = Verb ** {s3 : Preposition ; c : Case} ; + + mkTransVerb : Verb -> Preposition -> Case -> TransVerb = + \v,p,c -> v ** {s3 = p ; c = c} ; + +-- The rule for using transitive verbs is the complementization rule: + + complTransVerb : Bool -> TransVerb -> NounPhrase -> VerbPhrase = + \b,warten,dich -> + let { + aufdich = warten.s3 ++ dich.s ! NPCase warten.c ; + nicht = negation b + } in + {s = warten.s ; + s2 = warten.s2 ; + s3 = \\_ => bothWays aufdich nicht + } ; + +-- Transitive verbs with accusative objects can be used passively. +-- The function does not check that the verb is transitive. +-- Therefore, the function can also be used for "es wird gelaufen", etc. + + passVerb : Bool -> Verb -> VerbPhrase = \b,lieben -> + {s = verbumWerden ; + s2 = [] ; + s3 = \\_ => negation b ++ lieben.s ! VPart APred + } ; + + +--2 Adverbials +-- +-- Adverbials are not inflected (we ignore comparison, and treat +-- compared adverbials as separate expressions; this could be done another way). + + Adverb : Type = SS ; + + mkAdverb : Str -> Adverb = ss ; + + adVerbPhrase : VerbPhrase -> Adverb -> VerbPhrase = \spielt, gut -> + {s = spielt.s ; + s2 = spielt.s2 ; + s3 = \\n => spielt.s3 ! n ++ gut.s + } ; + + advAdjPhrase : Adverb -> AdjPhrase -> AdjPhrase = \sehr, gut -> + {s = \\a => sehr.s ++ gut.s ! a ; + p = gut.p + } ; + +-- Adverbials are typically generated by prefixing prepositions. +-- The rule for creating locative noun phrases by the preposition "in" +-- is a little shaky, since other prepositions may be preferred ("an", "auf"). + + prepPhrase : Case -> Preposition -> NounPhrase -> Adverb = \c,auf,ihm -> + ss (auf ++ ihm.s ! NPCase c) ; + + locativeNounPhrase : NounPhrase -> Adverb = + prepPhrase Dat "in" ; + +-- This is a source of the "Mann mit einem Teleskop" ambiguity, and may produce +-- strange things, like "Autos immer" (while "Autos heute" is OK). +-- Semantics will have to make finer distinctions among adverbials. + + advCommNounPhrase : CommNounPhrase -> Adverb -> CommNounPhrase = \haus,heute -> + {s = \\a, n, c => haus.s ! a ! n ! c ++ heute.s ; + g = haus.g} ; + + + +--2 Sentences +-- +-- Sentences depend on a *word order parameter* selecting between main clause, +-- inverted, and subordinate clause. + + Sentence : Type = SS1 Order ; + +-- This is the traditional $S -> NP VP$ rule. It takes care of both +-- word order and agreement. + + predVerbPhrase : NounPhrase -> VerbPhrase -> Sentence = + \Ich,LiebeDichNichtAus -> + let { + ich = Ich.s ! NPCase Nom ; + liebe = LiebeDichNichtAus.s ! VInd Ich.n Ich.p ; + aus = LiebeDichNichtAus.s2 ; + dichnichtgut = LiebeDichNichtAus.s3 ! Ich.n + } in + {s = table { + Main => ich ++ liebe ++ dichnichtgut ++ aus ; + Inv => liebe ++ ich ++ dichnichtgut ++ aus ; + Sub => ich ++ dichnichtgut ++ aus ++ liebe + } + } ; + +--3 Sentence-complement verbs +-- +-- Sentence-complement verbs take sentences as complements. + + SentenceVerb : Type = Verb ; + + complSentVerb : Bool -> SentenceVerb -> Sentence -> VerbPhrase = \b,sage,duisst -> + sage ** + {s3 = \\_ => negation b ++ "," ++ "dass" ++ duisst.s ! Sub} ; + + +--2 Sentences missing noun phrases +-- +-- This is one instance of Gazdar's *slash categories*, corresponding to his +-- $S/NP$. +-- We cannot have - nor would we want to have - a productive slash-category former. +-- Perhaps a handful more will be needed. +-- +-- Notice that the slash category has the same relation to sentences as +-- transitive verbs have to verbs: it's like a *sentence taking a complement*. + + SentenceSlashNounPhrase : Type = Sentence ** {s2 : Preposition ; c : Case} ; + + slashTransVerb : Bool -> NounPhrase -> TransVerb -> SentenceSlashNounPhrase = + \b, Ich, sehen -> + let { + ich = Ich.s ! NPCase Nom ; + sehe = sehen.s ! VInd Ich.n P3 ; + aus = sehen.s2 ; + nicht = negation b + } in + {s = table { + Main => ich ++ sehe ++ nicht ++ aus ; + Inv => sehe ++ ich ++ nicht ++ aus ; + Sub => ich ++ nicht ++ aus ++ sehe + } ; + s2 = sehen.s3 ; + c = sehen.c + } ; + +--2 Relative pronouns and relative clauses +-- +-- Relative pronouns are inflected in +-- gender, number, and case just like adjectives. + +oper + identRelPron : RelPron = relPron ; + + funRelPron : Function -> RelPron -> RelPron = \wert, der -> + {s = \\gn,c => let {nu = numGenNum gn} in + artDef ! gNumber wert.g nu ! c ++ wert.s ! Weak ! nu ! c ++ + wert.s2 ++ der.s ! gn ! wert.c + } ; + +-- Relative clauses can be formed from both verb phrases ("der schläft") and +-- slash expressions ("den ich sehe", "auf dem ich sitze"). + + RelClause : Type = {s : GenNum => Str} ; + + relVerbPhrase : RelPron -> VerbPhrase -> RelClause = \der, geht -> + {s = \\gn => (predVerbPhrase (normalNounPhrase (der.s ! gn) (numGenNum gn)) + geht + ).s ! Sub + } ; + + relSlash : RelPron -> SentenceSlashNounPhrase -> RelClause = \den, ichSehe -> + {s = \\gn => ichSehe.s2 ++ den.s ! gn ! ichSehe.c ++ ichSehe.s ! Sub + } ; + +-- A 'degenerate' relative clause is the one often used in mathematics, e.g. +-- "Zahl x derart, dass x gerade ist". + + relSuch : Sentence -> RelClause = \A -> + {s = \\_ => "derart" ++ "dass" ++ A.s ! Sub} ; + +-- The main use of relative clauses is to modify common nouns. +-- The result is a common noun, out of which noun phrases can be formed +-- by determiners. A comma is used before the relative clause. + + modRelClause : CommNounPhrase -> RelClause -> CommNounPhrase = \mann,dergeht -> + {s = \\a,n,c => mann.s ! a ! n ! c ++ "," ++ dergeht.s ! gNumber mann.g n ; + g = mann.g + } ; + + +--2 Interrogative pronouns +-- +-- If relative pronouns are adjective-like, interrogative pronouns are +-- noun-phrase-like. We use a simplified type, since we don't need the possessive +-- forms. + + IntPron : Type = ProperName ** {n : Number} ; + +-- In analogy with relative pronouns, we have a rule for applying a function +-- to a relative pronoun to create a new one. + + funIntPron : Function -> IntPron -> IntPron = \wert, wer -> + let {n = wer.n} in + {s = \\c => + artDef ! gNumber wert.g n ! c ++ wert.s ! Weak ! n ! c ++ + wert.s2 ++ wer.s ! wert.c ; + n = n + } ; + +-- There is a variety of simple interrogative pronouns: +-- "welches Haus", "wer", "was". + + nounIntPron : Number -> CommNounPhrase -> IntPron = \n,cn -> + let {np = detNounPhrase (welchDet n) cn} in + {s = \\c => np.s ! NPCase c ; + n = np.n} ; + + intPronWho : Number -> IntPron = \num -> { + s = caselist "wer" "wen" "wem" "weren" ; + n = num + } ; + + intPronWhat : Number -> IntPron = \num -> { + s = caselist "was" "was" nonExist nonExist ; --- + n = num + } ; + + + +--2 Utterances + +-- By utterances we mean whole phrases, such as +-- 'can be used as moves in a language game': indicatives, questions, imperative, +-- and one-word utterances. The rules are far from complete. +-- +-- N.B. we have not included rules for texts, which we find we cannot say much +-- about on this level. In semantically rich GF grammars, texts, dialogues, etc, +-- will of course play an important role as categories not reducible to utterances. +-- An example is proof texts, whose semantics show a dependence between premises +-- and conclusions. Another example is intersentential anaphora. + + Utterance = SS ; + + indicUtt : Sentence -> Utterance = \x -> ss (x.s ! Main ++ ".") ; + interrogUtt : Question -> Utterance = \x -> ss (x.s ! DirQ ++ "?") ; + + +--2 Questions +-- +-- Questions are either direct ("bist du müde") or indirect +-- ("ob du müde bist"). + +param + QuestForm = DirQ | IndirQ ; + +oper + Question = SS1 QuestForm ; + +--3 Yes-no questions +-- +-- Yes-no questions are used both independently ("bist du müde") +-- and after interrogative adverbials ("warum bist du müde"). +-- It is economical to handle with these two cases by the one +-- rule, $questVerbPhrase'$. The only difference is if "ob" appears +-- in the indirect form. + + questVerbPhrase : NounPhrase -> VerbPhrase -> Question = + questVerbPhrase' False ; + + questVerbPhrase' : Bool -> NounPhrase -> VerbPhrase -> Question = + \adv, du,gehst -> + let {dugehst = (predVerbPhrase du gehst).s} in + {s = table { + DirQ => dugehst ! Inv ; + IndirQ => (if_then_else Str adv [] "ob") ++ dugehst ! Sub + } + } ; + + +--3 Wh-questions +-- +-- Wh-questions are of two kinds: ones that are like $NP - VP$ sentences, +-- others that are line $S/NP - NP$ sentences. + + intVerbPhrase : IntPron -> VerbPhrase -> Question = \Wer,geht -> + let {wer : NounPhrase = normalNounPhrase Wer.s Wer.n ; + wergeht : Sentence = predVerbPhrase wer geht + } in + {s = table { + DirQ => wergeht.s ! Main ; + IndirQ => wergeht.s ! Sub + } + } ; + + intSlash : IntPron -> SentenceSlashNounPhrase -> Question = \wer, ichSehe -> + let {zuwen = ichSehe.s2 ++ wer.s ! ichSehe.c} in + {s = table { + DirQ => zuwen ++ ichSehe.s ! Inv ; + IndirQ => zuwen ++ ichSehe.s ! Sub + } + } ; + + +--3 Interrogative adverbials +-- +-- These adverbials will be defined in the lexicon: they include +-- "wann", "war", "wie", "warum", etc, which are all invariant one-word +-- expressions. In addition, they can be formed by adding prepositions +-- to interrogative pronouns, in the same way as adverbials are formed +-- from noun phrases. + + IntAdverb = SS ; + + prepIntAdverb : Case -> Preposition -> IntPron -> IntAdverb =\ c,auf,wem -> + ss (auf ++ wem.s ! c) ; + +-- A question adverbial can be applied to anything, and whether this makes +-- sense is a semantic question. + + questAdverbial : IntAdverb -> NounPhrase -> VerbPhrase -> Question = + \wie, du, tust -> + {s = \\q => wie.s ++ (questVerbPhrase du tust).s ! q} ; + + +--2 Imperatives +-- +-- We only consider second-person imperatives. No polite "Sie" form so far. + + Imperative = SS1 Number ; + + imperVerbPhrase : VerbPhrase -> Imperative = \komm -> + {s = \\n => komm.s ! VImp n ++ komm.s3 ! n ++ komm.s2} ; + + imperUtterance : Number -> Imperative -> Utterance = \n,I -> + ss (I.s ! n ++ "!") ; + +--2 Sentence adverbials +-- +-- This class covers adverbials such as "sonst", "folgelich", which are prefixed +-- to a sentence to form a phrase; the sentence gets inverted word order. + + advSentence : Adverb -> Sentence -> Utterance = \sonst,ist1gerade -> + ss (sonst.s ++ ist1gerade.s ! Inv ++ ".") ; + +--2 Coordination +-- +-- Coordination is to some extent orthogonal to the rest of syntax, and +-- has been treated in a generic way in the module $CO$ in the file +-- $coordination.gf$. The overall structure is independent of category, +-- but there can be differences in parameter dependencies. +-- +--3 Conjunctions +-- +-- Coordinated phrases are built by using conjunctions, which are either +-- simple ("und", "oder") or distributed ("sowohl - als auch", "entweder - oder"). +-- +-- The conjunction has an inherent number, which is used when conjoining +-- noun phrases: "John und Mary sind..." vs. "John oder Mary ist..."; in the +-- case of "oder", the result is however plural if any of the disjuncts is. + + Conjunction = CO.Conjunction ** {n : Number} ; + ConjunctionDistr = CO.ConjunctionDistr ** {n : Number} ; + + +--3 Coordinating sentences +-- +-- We need a category of lists of sentences. It is a discontinuous +-- category, the parts corresponding to 'init' and 'last' segments +-- (rather than 'head' and 'tail', because we have to keep track of the slot between +-- the last two elements of the list). A list has at least two elements. + + ListSentence : Type = {s1,s2 : Order => Str} ; + + twoSentence : (_,_ : Sentence) -> ListSentence = + CO.twoTable Order ; + + consSentence : ListSentence -> Sentence -> ListSentence = + CO.consTable Order CO.comma ; + +-- To coordinate a list of sentences by a simple conjunction, we place +-- it between the last two elements; commas are put in the other slots, +-- e.g. "du rauchst, er trinkt und ich esse". + + conjunctSentence : Conjunction -> ListSentence -> Sentence = + CO.conjunctTable Order ; + +-- To coordinate a list of sentences by a distributed conjunction, we place +-- the first part (e.g. "entweder") in front of the first element, the second +-- part ("oder") between the last two elements, and commas in the other slots. +-- For sentences this is really not used. + + conjunctDistrSentence : ConjunctionDistr -> ListSentence -> Sentence = + CO.conjunctDistrTable Order ; + +--3 Coordinating adjective phrases +-- +-- The structure is the same as for sentences. The result is a prefix adjective +-- if and only if all elements are prefix. + + ListAdjPhrase : Type = + {s1,s2 : AForm => Str ; p : Bool} ; + + twoAdjPhrase : (_,_ : AdjPhrase) -> ListAdjPhrase = \x,y -> + CO.twoTable AForm x y ** {p = andB x.p y.p} ; + consAdjPhrase : ListAdjPhrase -> AdjPhrase -> ListAdjPhrase = \xs,x -> + CO.consTable AForm CO.comma xs x ** {p = andB xs.p x.p} ; + + conjunctAdjPhrase : Conjunction -> ListAdjPhrase -> AdjPhrase = \c,xs -> + CO.conjunctTable AForm c xs ** {p = xs.p} ; + + conjunctDistrAdjPhrase : ConjunctionDistr -> ListAdjPhrase -> AdjPhrase = \c,xs -> + CO.conjunctDistrTable AForm c xs ** {p = xs.p} ; + + + +--3 Coordinating noun phrases +-- +-- The structure is the same as for sentences. The result is either always plural +-- or plural if any of the components is, depending on the conjunction. +-- The result is a pronoun if all components are. + + ListNounPhrase : Type = + {s1,s2 : NPForm => Str ; n : Number ; p : Person ; pro : Bool} ; + + twoNounPhrase : (_,_ : NounPhrase) -> ListNounPhrase = \x,y -> + CO.twoTable NPForm x y ** + {n = conjNumber x.n y.n ; p = conjPerson x.p y.p ; pro = andB x.pro y.pro} ; + + consNounPhrase : ListNounPhrase -> NounPhrase -> ListNounPhrase = \xs,x -> + CO.consTable NPForm CO.comma xs x ** + {n = conjNumber xs.n x.n ; p = conjPerson xs.p x.p ; pro = andB xs.pro x.pro} ; + + conjunctNounPhrase : Conjunction -> ListNounPhrase -> NounPhrase = \c,xs -> + CO.conjunctTable NPForm c xs ** + {n = conjNumber c.n xs.n ; p = xs.p ; pro = xs.pro} ; + + conjunctDistrNounPhrase : ConjunctionDistr -> ListNounPhrase -> NounPhrase = + \c,xs -> + CO.conjunctDistrTable NPForm c xs ** + {n = conjNumber c.n xs.n ; p = xs.p ; pro = xs.pro} ; + +-- We have to define a calculus of numbers of persons. For numbers, +-- it is like the conjunction with $Pl$ corresponding to $False$. + + conjNumber : Number -> Number -> Number = \m,n -> case of { + => Sg ; + _ => Pl + } ; + +-- For persons, we go in the descending order: +-- "ich und dich sind stark", "er oder du bist stark". +-- This is not always quite clear. + + conjPerson : Person -> Person -> Person = \p,q -> case of { + => P3 ; + => P1 ; + <_,P1> => P1 ; + _ => P2 + } ; + + +--2 Subjunction +-- +-- Subjunctions ("wenn", "falls", etc) +-- are a different way to combine sentences than conjunctions. +-- The main clause can be a sentences, an imperatives, or a question, +-- but the subjoined clause must be a sentence. + + Subjunction = SS ; + + subjunctSentence : Subjunction -> Sentence -> Sentence -> Sentence = \if, A, B -> + let {As = A.s ! Sub} in + {s = table { + Main => variants {if.s ++ As ++ "," ++ B.s ! Inv ; + B.s ! Main ++ "," ++ if.s ++ As} ; + o => B.s ! o ++ "," ++ if.s ++ As + } + } ; + + subjunctImperative : Subjunction -> Sentence -> Imperative -> Imperative = + \if, A, B -> + {s = \\n => subjunctVariants if A (B.s ! n)} ; + + subjunctQuestion : Subjunction -> Sentence -> Question -> Question = \if, A, B -> + {s = \\q => subjunctVariants if A (B.s ! q)} ; + +-- There are uniformly two variant word orders, e.g. +-- "wenn du rauchst, werde ish böse" +-- and "ich werde böse, wenn du rauchst". + + subjunctVariants : Subjunction -> Sentence -> Str -> Str = \if,A,B -> + let {As = A.s ! Sub} in + variants {if.s ++ As ++ "," ++ B ; B ++ "," ++ if.s ++ As} ; + + +--2 One-word utterances +-- +-- An utterance can consist of one phrase of almost any category, +-- the limiting case being one-word utterances. These +-- utterances are often (but not always) in what can be called the +-- default form of a category, e.g. the nominative. +-- This list is far from exhaustive. + + useNounPhrase : NounPhrase -> Utterance = \john -> + postfixSS "." (defaultNounPhrase john) ; + useCommonNounPhrase : Number -> CommNounPhrase -> Utterance = \n,car -> + useNounPhrase (indefNounPhrase n car) ; + +-- Here are some default forms. + + defaultNounPhrase : NounPhrase -> SS = \john -> + ss (john.s ! NPCase Nom) ; + + defaultQuestion : Question -> SS = \whoareyou -> + ss (whoareyou.s ! DirQ) ; + + defaultSentence : Sentence -> Utterance = \x -> ss (x.s ! Main) ; + +--3 Puzzle +-- +-- Adding some lexicon, we can generate the sentence +-- +-- "der grösste alte Mann ist nicht ein Auto auf die Mutter von dem Männer warten" +-- +-- which looks completely ungrammatical! What you should do to decipher it is +-- put parentheses around "auf die Mutter von dem". + +} ; diff --git a/grammars/resource/german/TestDeu.gf b/grammars/resource/german/TestDeu.gf new file mode 100644 index 000000000..e09b60d1f --- /dev/null +++ b/grammars/resource/german/TestDeu.gf @@ -0,0 +1,39 @@ +concrete TestDeu of TestAbs = ResDeu ** open Syntax in { + +flags startcat=Phr ; lexer=text ; parser=chart ; unlexer=text ; + +-- a random sample from the lexicon + +lin + Big = adjCompReg3 "gross" "grösser" "grösst"; + Small = adjCompReg "klein" ; + Old = adjCompReg3 "alt" "älter" "ältest"; + Young = adjCompReg3 "jung" "jünger" "jüngst"; + Man = declN2u "Mann" "Männer" ; + Woman = declN1 "Frau" ; + Car = declNs "Auto" ; + House = declN3uS "Haus" "Häuser" ; + Light = declN3 "Licht" ; + Walk = mkVerbSimple (verbLaufen "gehen" "geht" "gegangen") ; + Run = mkVerbSimple (verbLaufen "laufen" "läuft" "gelaufen") ; + Say = mkVerbSimple (regVerb "sagen") ; + Prove = mkVerbSimple (regVerb "beweisen") ; + Send = mkTransVerb (mkVerbSimple (verbLaufen "senden" "sendet" "gesandt")) [] Acc; + Love = mkTransVerb (mkVerbSimple (regVerb "lieben")) [] Acc ; + Wait = mkTransVerb (mkVerbSimple (verbWarten "warten")) "auf" Acc ; + Mother = mkFunC (n2n (declN2uF "Mutter" "Mütter")) "von" Dat ; + Uncle = mkFunC (n2n (declN2i "Onkel")) "von" Dat ; + Connection = mkFunC (n2n (declN1 "Verbindung")) "von" Dat ** + {s3 = "nach" ; c2 = Dat} ; + + Always = mkAdverb "immer" ; + Well = mkAdverb "gut" ; + + SwitchOn = mkTransVerb (mkVerb (verbWarten "schalten") "auf") [] Acc ; + SwitchOff = mkTransVerb (mkVerb (verbWarten "schalten") "aus") [] Acc ; + + John = mkProperName "Johann" ; + Mary = mkProperName "Maria" ; + +} ; + diff --git a/grammars/resource/german/Types.gf b/grammars/resource/german/Types.gf new file mode 100644 index 000000000..d597223cd --- /dev/null +++ b/grammars/resource/german/Types.gf @@ -0,0 +1,98 @@ +--1 German Word Classes and Morphological Parameters +-- +-- This is a resource module for German morphology, defining the +-- morphological parameters and word classes of German. It is so far only +-- complete w.r.t. the syntax part of the resource grammar. +-- It does not include those parameters that are not needed for +-- analysing individual words: such parameters are defined in syntax modules. +-- + +resource Types = open Prelude in { + +--2 Enumerated parameter types +-- +-- These types are the ones found in school grammars. +-- Their parameter values are atomic. + +param + Number = Sg | Pl ; + Gender = Masc | Fem | Neut ; + Person = P1 | P2 | P3 ; + Case = Nom | Acc | Dat | Gen ; + Adjf = Strong | Weak ; -- the main division in adjective declension + Order = Main | Inv | Sub ; -- word order: direct, indirect, subordinate + +-- For abstraction and API compatibility, we define two synonyms: + +oper + singular = Sg ; + plural = Pl ; + +--2 Word classes and hierarchical parameter types +-- +-- Real parameter types (i.e. ones on which words and phrases depend) +-- are mostly hierarchical. The alternative is cross-products of +-- simple parameters, but this cannot be always used since it overgenerates. +-- + +--3 Common nouns +-- +-- Common nouns are inflected in number and case and they have an inherent gender. + + CommNoun : Type = {s : Number => Case => Str ; g : Gender} ; + +--3 Pronouns +-- +-- Pronouns are an example - the worst-case one of noun phrases, +-- which are properly defined in $syntax.Deu.gf$. +-- Their inflection tables has, in addition to the normal genitive, +-- the possessive forms, which are inflected like determiners. + +param + NPForm = NPCase Case | NPPoss GenNum Case ; + +--3 Adjectives +-- +-- Adjectives are a very complex class, and the full table has as many as +-- 99 different forms. The major division is between the comparison degrees. +-- There is no gender distinction in the plural, +-- and the predicative forms ("X ist Adj") are not inflected. + +param + GenNum = GSg Gender | GPl ; + AForm = APred | AMod Adjf GenNum Case ; + +oper + Adjective : Type = {s : AForm => Str} ; + AdjComp : Type = {s : Degree => AForm => Str} ; + +-- Comparison of adjectives: + +param Degree = Pos | Comp | Sup ; + +--3 Verbs +-- +-- We have a reduced conjugation with only the present tense infinitive, +-- indicative, and imperative forms, and past participles. + +param VForm = VInf | VInd Number Person | VImp Number | VPart AForm ; + +oper Verbum : Type = VForm => Str ; + +-- On the general level, we have to account for composite verbs as well, +-- such as "aus" + "sehen" etc. + + Particle = Str ; + + Verb = {s : Verbum ; s2 : Particle} ; + + +--2 Prepositions +-- +-- We define prepositions simply as strings. Thus we do not capture the +-- contractions "vom", "ins", etc. To define them in GF grammar we would need +-- to introduce a parameter system, which we postpone. + + Preposition = Str ; + +} ; diff --git a/grammars/resource/swedish/Morpho.gf b/grammars/resource/swedish/Morpho.gf new file mode 100644 index 000000000..d7b2c66fa --- /dev/null +++ b/grammars/resource/swedish/Morpho.gf @@ -0,0 +1,1039 @@ +--1 A Simple Swedish Resource Morphology +-- +-- Aarne Ranta 2002 +-- +-- This resource morphology contains definitions needed in the resource +-- syntax. It moreover contains copies of the most usual inflectional patterns +-- as defined in functional morphology (in the Haskell file $RulesSw.hs$). +-- +-- We use the parameter types and word classes defined for morphology. + +resource Morpho = Types ** open Prelude in { + +-- The indefinite and definite article +oper + artIndef = table {Utr => "en" ; Neutr => "ett"} ; + + artDef : Bool => GenNum => Str = table { + True => table { + ASg Utr => "den" ; + ASg Neutr => "det" ; -- det gamla huset + APl => variants {"de" ; "dom"} + } ; + False => table {_ => []} -- huset + } ; + +-- A simplified verb category: present tense only. +oper + verbVara = {s = table {Infinit => "vara" ; Indicat => "är" ; Imperat => "var"}} ; + verbHava = {s = table {Infinit => "ha" ; Indicat => "har" ; Imperat => "ha"}} ; + +-- Prepositions are just strings. + Preposition = Str ; + +-- Relative pronouns have a special case system. $RPrep$ is the form used +-- after a preposition (e.g. "det hus i vilket jag bor"). +param + RelCase = RNom | RAcc | RGen | RPrep ; + +oper + relPronForms : RelCase => GenNum => Str = table { + RNom => \\_ => "som" ; + RAcc => \\_ => variants {"som" ; []} ; + RGen => \\_ => "vars" ; + RPrep => pronVilken + } ; + + pronVilken = table { + ASg Utr => "vilken" ; + ASg Neutr => "vilket" ; + APl => "vilka" + } ; + + pronSådan = table { + ASg Utr => "sådan" ; + ASg Neutr => "sådant" ; + APl => "sådana" + } ; + +-- What follows are machine-generated inflection paradigms from functional +-- morphology. Hence they are low-level paradigms, without any +-- abstractions or generalizations: the Haskell code is better in these respects. +-- +-- The variable names are selected in such a way that the paradigms can be read +-- as inflection tables of certain words. + +oper sApa : Str -> Subst = \ap -> + {s = table { + SF Sg Indef Nom => ap + "a" ; + SF Sg Indef Gen => ap + "as" ; + SF Sg Def Nom => ap + "an" ; + SF Sg Def Gen => ap + "ans" ; + SF Pl Indef Nom => ap + "or" ; + SF Pl Indef Gen => ap + "ors" ; + SF Pl Def Nom => ap + "orna" ; + SF Pl Def Gen => ap + "ornas" + } ; + h1 = Utr + } ; + +oper sBil : Str -> Subst = \bil -> + {s = table { + SF Sg Indef Nom => bil ; + SF Sg Indef Gen => bil + "s" ; + SF Sg Def Nom => bil + "en" ; + SF Sg Def Gen => bil + "ens" ; + SF Pl Indef Nom => bil + "ar" ; + SF Pl Indef Gen => bil + "ars" ; + SF Pl Def Nom => bil + "arna" ; + SF Pl Def Gen => bil + "arnas" + } ; + h1 = Utr + } ; + +oper sPojke : Str -> Subst = \pojk -> + {s = table { + SF Sg Indef Nom => pojk + "e" ; + SF Sg Indef Gen => pojk + "es" ; + SF Sg Def Nom => pojk + "en" ; + SF Sg Def Gen => pojk + "ens" ; + SF Pl Indef Nom => pojk + "ar" ; + SF Pl Indef Gen => pojk + "ars" ; + SF Pl Def Nom => pojk + "arna" ; + SF Pl Def Gen => pojk + "arnas" + } ; + h1 = Utr + } ; + +oper sNyckel : Str -> Subst = \nyck -> + {s = table { + SF Sg Indef Nom => nyck + "el" ; + SF Sg Indef Gen => nyck + "els" ; + SF Sg Def Nom => nyck + "eln" ; + SF Sg Def Gen => nyck + "elns" ; + SF Pl Indef Nom => nyck + "lar" ; + SF Pl Indef Gen => nyck + "lars" ; + SF Pl Def Nom => nyck + "larna" ; + SF Pl Def Gen => nyck + "larnas" + } ; + h1 = Utr + } ; + +oper sKam : Str -> Subst = \kam -> + {s = table { + SF Sg Indef Nom => kam ; + SF Sg Indef Gen => kam + "s" ; + SF Sg Def Nom => kam + "men" ; + SF Sg Def Gen => kam + "mens" ; + SF Pl Indef Nom => kam + "mar" ; + SF Pl Indef Gen => kam + "mars" ; + SF Pl Def Nom => kam + "marna" ; + SF Pl Def Gen => kam + "marnas" + } ; + h1 = Utr + } ; + +oper sSak : Str -> Subst = \sak -> + {s = table { + SF Sg Indef Nom => sak ; + SF Sg Indef Gen => sak + "s" ; + SF Sg Def Nom => sak + "en" ; + SF Sg Def Gen => sak + "ens" ; + SF Pl Indef Nom => sak + "er" ; + SF Pl Indef Gen => sak + "ers" ; + SF Pl Def Nom => sak + "erna" ; + SF Pl Def Gen => sak + "ernas" + } ; + h1 = Utr + } ; + +oper sNivå : Str -> Subst = \nivå -> + {s = table { + SF Sg Indef Nom => nivå ; + SF Sg Indef Gen => nivå + "s" ; + SF Sg Def Nom => nivå + "n" ; + SF Sg Def Gen => nivå + "ns" ; + SF Pl Indef Nom => nivå + "er" ; + SF Pl Indef Gen => nivå + "ers" ; + SF Pl Def Nom => nivå + "erna" ; + SF Pl Def Gen => nivå + "ernas" + } ; + h1 = Utr + } ; + +oper sParti : Str -> Subst = \parti -> + {s = table { + SF Sg Indef Nom => parti ; + SF Sg Indef Gen => parti + "s" ; + SF Sg Def Nom => parti + "et" ; + SF Sg Def Gen => parti + "ets" ; + SF Pl Indef Nom => parti + "er" ; + SF Pl Indef Gen => parti + "ers" ; + SF Pl Def Nom => parti + "erna" ; + SF Pl Def Gen => parti + "ernas" + } ; + h1 = Neutr + } ; + +oper sMuseum : Str -> Subst = \muse -> + {s = table { + SF Sg Indef Nom => muse + "um" ; + SF Sg Indef Gen => muse + "ums" ; + SF Sg Def Nom => muse + "et" ; + SF Sg Def Gen => muse + "ets" ; + SF Pl Indef Nom => muse + "er" ; + SF Pl Indef Gen => muse + "ers" ; + SF Pl Def Nom => muse + "erna" ; + SF Pl Def Gen => muse + "ernas" + } ; + h1 = Neutr + } ; + +oper sRike : Str -> Subst = \rike -> + {s = table { + SF Sg Indef Nom => rike ; + SF Sg Indef Gen => rike + "s" ; + SF Sg Def Nom => rike + "t" ; + SF Sg Def Gen => rike + "ts" ; + SF Pl Indef Nom => rike + "n" ; + SF Pl Indef Gen => rike + "ns" ; + SF Pl Def Nom => rike + "na" ; + SF Pl Def Gen => rike + "nas" + } ; + h1 = Neutr + } ; + +oper sLik : Str -> Subst = \lik -> + {s = table { + SF Sg Indef Nom => lik ; + SF Sg Indef Gen => lik + "s" ; + SF Sg Def Nom => lik + "et" ; + SF Sg Def Gen => lik + "ets" ; + SF Pl Indef Nom => lik ; + SF Pl Indef Gen => lik + "s" ; + SF Pl Def Nom => lik + "en" ; + SF Pl Def Gen => lik + "ens" + } ; + h1 = Neutr + } ; + +oper sRum : Str -> Subst = \rum -> + {s = table { + SF Sg Indef Nom => rum ; + SF Sg Indef Gen => rum + "s" ; + SF Sg Def Nom => rum + "met" ; + SF Sg Def Gen => rum + "mets" ; + SF Pl Indef Nom => rum ; + SF Pl Indef Gen => rum + "s" ; + SF Pl Def Nom => rum + "men" ; + SF Pl Def Gen => rum + "mens" + } ; + h1 = Neutr + } ; + +oper sHus : Str -> Subst = \hus -> + {s = table { + SF Sg Indef Nom => hus ; + SF Sg Indef Gen => hus ; + SF Sg Def Nom => hus + "et" ; + SF Sg Def Gen => hus + "ets" ; + SF Pl Indef Nom => hus ; + SF Pl Indef Gen => hus ; + SF Pl Def Nom => hus + "en" ; + SF Pl Def Gen => hus + "ens" + } ; + h1 = Neutr + } ; + +oper sPapper : Str -> Subst = \papp -> + {s = table { + SF Sg Indef Nom => papp + "er" ; + SF Sg Indef Gen => papp + "ers" ; + SF Sg Def Nom => papp + "ret" ; + SF Sg Def Gen => papp + "rets" ; + SF Pl Indef Nom => papp + "er" ; + SF Pl Indef Gen => papp + "ers" ; + SF Pl Def Nom => papp + "ren" ; + SF Pl Def Gen => papp + "rens" + } ; + h1 = Neutr + } ; + +oper sNummer : Str -> Subst = \num -> + {s = table { + SF Sg Indef Nom => num + "mer" ; + SF Sg Indef Gen => num + "mers" ; + SF Sg Def Nom => num + "ret" ; + SF Sg Def Gen => num + "rets" ; + SF Pl Indef Nom => num + "mer" ; + SF Pl Indef Gen => num + "mers" ; + SF Pl Def Nom => num + "ren" ; + SF Pl Def Gen => num + "rens" + } ; + h1 = Neutr + } ; + +oper sKikare : Str -> Subst = \kikar -> + {s = table { + SF Sg Indef Nom => kikar + "e" ; + SF Sg Indef Gen => kikar + "es" ; + SF Sg Def Nom => kikar + "en" ; + SF Sg Def Gen => kikar + "ens" ; + SF Pl Indef Nom => kikar + "e" ; + SF Pl Indef Gen => kikar + "es" ; + SF Pl Def Nom => kikar + "na" ; + SF Pl Def Gen => kikar + "nas" + } ; + h1 = Utr + } ; + +oper sProgram : Str -> Subst = \program -> + {s = table { + SF Sg Indef Nom => program ; + SF Sg Indef Gen => program + "s" ; + SF Sg Def Nom => program + "met" ; + SF Sg Def Gen => program + "mets" ; + SF Pl Indef Nom => program ; + SF Pl Indef Gen => program + "s" ; + SF Pl Def Nom => program + "men" ; + SF Pl Def Gen => program + "mens" + } ; + h1 = Neutr + } ; + +oper aFin : Str -> Adj = \fin -> + {s = table { + AF (Posit (Strong (ASg Utr))) Nom => fin ; + AF (Posit (Strong (ASg Utr))) Gen => fin + "s" ; + AF (Posit (Strong (ASg Neutr))) Nom => fin + "t" ; + AF (Posit (Strong (ASg Neutr))) Gen => fin + "ts" ; + AF (Posit (Strong APl)) Nom => fin + "a" ; + AF (Posit (Strong APl)) Gen => fin + "as" ; + AF (Posit (Weak (AxSg NoMasc))) Nom => fin + "a" ; + AF (Posit (Weak (AxSg NoMasc))) Gen => fin + "as" ; + AF (Posit (Weak (AxSg Masc))) Nom => fin + "e" ; + AF (Posit (Weak (AxSg Masc))) Gen => fin + "es" ; + AF (Posit (Weak AxPl)) Nom => fin + "a" ; + AF (Posit (Weak AxPl)) Gen => fin + "as" ; + AF Compar Nom => fin + "are" ; + AF Compar Gen => fin + "ares" ; + AF (Super SupStrong) Nom => fin + "ast" ; + AF (Super SupStrong) Gen => fin + "asts" ; + AF (Super SupWeak) Nom => fin + "aste" ; + AF (Super SupWeak) Gen => fin + "astes" + } + } ; + +oper aFager : Str -> Adj = \fag -> + {s = table { + AF (Posit (Strong (ASg Utr))) Nom => fag + "er" ; + AF (Posit (Strong (ASg Utr))) Gen => fag + "ers" ; + AF (Posit (Strong (ASg Neutr))) Nom => fag + "ert" ; + AF (Posit (Strong (ASg Neutr))) Gen => fag + "erts" ; + AF (Posit (Strong APl)) Nom => fag + "era" ; + AF (Posit (Strong APl)) Gen => fag + "eras" ; + AF (Posit (Weak (AxSg NoMasc))) Nom => fag + "era" ; + AF (Posit (Weak (AxSg NoMasc))) Gen => fag + "eras" ; + AF (Posit (Weak (AxSg Masc))) Nom => fag + "ere" ; + AF (Posit (Weak (AxSg Masc))) Gen => fag + "eres" ; + AF (Posit (Weak AxPl)) Nom => fag + "era" ; + AF (Posit (Weak AxPl)) Gen => fag + "eras" ; + AF Compar Nom => fag + "erare" ; + AF Compar Gen => fag + "erares" ; + AF (Super SupStrong) Nom => fag + "erast" ; + AF (Super SupStrong) Gen => fag + "erasts" ; + AF (Super SupWeak) Nom => fag + "eraste" ; + AF (Super SupWeak) Gen => fag + "erastes" + } + } ; + +oper aGrund : Str -> Adj = \grun -> + {s = table { + AF (Posit (Strong (ASg Utr))) Nom => grun + "d" ; + AF (Posit (Strong (ASg Utr))) Gen => grun + "ds" ; + AF (Posit (Strong (ASg Neutr))) Nom => grun + "t" ; + AF (Posit (Strong (ASg Neutr))) Gen => grun + "ts" ; + AF (Posit (Strong APl)) Nom => grun + "da" ; + AF (Posit (Strong APl)) Gen => grun + "das" ; + AF (Posit (Weak (AxSg NoMasc))) Nom => grun + "da" ; + AF (Posit (Weak (AxSg NoMasc))) Gen => grun + "das" ; + AF (Posit (Weak (AxSg Masc))) Nom => grun + "de" ; + AF (Posit (Weak (AxSg Masc))) Gen => grun + "des" ; + AF (Posit (Weak AxPl)) Nom => grun + "da" ; + AF (Posit (Weak AxPl)) Gen => grun + "das" ; + AF Compar Nom => grun + "dare" ; + AF Compar Gen => grun + "dares" ; + AF (Super SupStrong) Nom => grun + "dast" ; + AF (Super SupStrong) Gen => grun + "dasts" ; + AF (Super SupWeak) Nom => grun + "daste" ; + AF (Super SupWeak) Gen => grun + "dastes" + } + } ; + +oper aVid : Str -> Adj = \vi -> + {s = table { + AF (Posit (Strong (ASg Utr))) Nom => vi + "d" ; + AF (Posit (Strong (ASg Utr))) Gen => vi + "ds" ; + AF (Posit (Strong (ASg Neutr))) Nom => vi + "tt" ; + AF (Posit (Strong (ASg Neutr))) Gen => vi + "tts" ; + AF (Posit (Strong APl)) Nom => vi + "da" ; + AF (Posit (Strong APl)) Gen => vi + "das" ; + AF (Posit (Weak (AxSg NoMasc))) Nom => vi + "da" ; + AF (Posit (Weak (AxSg NoMasc))) Gen => vi + "das" ; + AF (Posit (Weak (AxSg Masc))) Nom => vi + "de" ; + AF (Posit (Weak (AxSg Masc))) Gen => vi + "des" ; + AF (Posit (Weak AxPl)) Nom => vi + "da" ; + AF (Posit (Weak AxPl)) Gen => vi + "das" ; + AF Compar Nom => vi + "dare" ; + AF Compar Gen => vi + "dares" ; + AF (Super SupStrong) Nom => vi + "dast" ; + AF (Super SupStrong) Gen => vi + "dasts" ; + AF (Super SupWeak) Nom => vi + "daste" ; + AF (Super SupWeak) Gen => vi + "dastes" + } + } ; + +oper aVaken : Str -> Adj = \vak -> + {s = table { + AF (Posit (Strong (ASg Utr))) Nom => vak + "en" ; + AF (Posit (Strong (ASg Utr))) Gen => vak + "ens" ; + AF (Posit (Strong (ASg Neutr))) Nom => vak + "et" ; + AF (Posit (Strong (ASg Neutr))) Gen => vak + "ets" ; + AF (Posit (Strong APl)) Nom => vak + "na" ; + AF (Posit (Strong APl)) Gen => vak + "nas" ; + AF (Posit (Weak (AxSg NoMasc))) Nom => vak + "na" ; + AF (Posit (Weak (AxSg NoMasc))) Gen => vak + "nas" ; + AF (Posit (Weak (AxSg Masc))) Nom => vak + "ne" ; + AF (Posit (Weak (AxSg Masc))) Gen => vak + "nes" ; + AF (Posit (Weak AxPl)) Nom => vak + "na" ; + AF (Posit (Weak AxPl)) Gen => vak + "nas" ; + AF Compar Nom => vak + "nare" ; + AF Compar Gen => vak + "nares" ; + AF (Super SupStrong) Nom => vak + "nast" ; + AF (Super SupStrong) Gen => vak + "nasts" ; + AF (Super SupWeak) Nom => vak + "naste" ; + AF (Super SupWeak) Gen => vak + "nastes" + } + } ; + +oper aKorkad : Str -> Adj = \korka -> + {s = table { + AF (Posit (Strong (ASg Utr))) Nom => korka + "d" ; + AF (Posit (Strong (ASg Utr))) Gen => korka + "ds" ; + AF (Posit (Strong (ASg Neutr))) Nom => korka + "t" ; + AF (Posit (Strong (ASg Neutr))) Gen => korka + "ts" ; + AF (Posit (Strong APl)) Nom => korka + "de" ; + AF (Posit (Strong APl)) Gen => korka + "des" ; + AF (Posit (Weak (AxSg NoMasc))) Nom => korka + "de" ; + AF (Posit (Weak (AxSg NoMasc))) Gen => korka + "des" ; + AF (Posit (Weak (AxSg Masc))) Nom => korka + "de" ; + AF (Posit (Weak (AxSg Masc))) Gen => korka + "des" ; + AF (Posit (Weak AxPl)) Nom => korka + "de" ; + AF (Posit (Weak AxPl)) Gen => korka + "des" ; + AF Compar Nom => variants {} ; + AF Compar Gen => variants {} ; + AF (Super SupStrong) Nom => variants {} ; + AF (Super SupStrong) Gen => variants {} ; + AF (Super SupWeak) Nom => variants {} ; + AF (Super SupWeak) Gen => variants {} + } + } ; + +oper aAbstrakt : Str -> Adj = \abstrakt -> + {s = table { + AF (Posit (Strong (ASg Utr))) Nom => abstrakt ; + AF (Posit (Strong (ASg Utr))) Gen => abstrakt + "s" ; + AF (Posit (Strong (ASg Neutr))) Nom => abstrakt ; + AF (Posit (Strong (ASg Neutr))) Gen => abstrakt + "s" ; + AF (Posit (Strong APl)) Nom => abstrakt + "a" ; + AF (Posit (Strong APl)) Gen => abstrakt + "as" ; + AF (Posit (Weak (AxSg NoMasc))) Nom => abstrakt + "a" ; + AF (Posit (Weak (AxSg NoMasc))) Gen => abstrakt + "as" ; + AF (Posit (Weak (AxSg Masc))) Nom => abstrakt + "e" ; + AF (Posit (Weak (AxSg Masc))) Gen => abstrakt + "es" ; + AF (Posit (Weak AxPl)) Nom => abstrakt + "a" ; + AF (Posit (Weak AxPl)) Gen => abstrakt + "as" ; + AF Compar Nom => abstrakt + "are" ; + AF Compar Gen => abstrakt + "ares" ; + AF (Super SupStrong) Nom => abstrakt + "ast" ; + AF (Super SupStrong) Gen => abstrakt + "asts" ; + AF (Super SupWeak) Nom => abstrakt + "aste" ; + AF (Super SupWeak) Gen => abstrakt + "astes" + } + } ; + +oper vTala : Str -> Verbum = \tal -> + {s = table { + VF (Pres Ind Act) => tal + "ar" ; + VF (Pres Ind Pass) => tal + "as" ; + VF (Pres Cnj Act) => tal + "e" ; + VF (Pres Cnj Pass) => tal + "es" ; + VF (Pret Ind Act) => tal + "ade" ; + VF (Pret Ind Pass) => tal + "ades" ; + VF (Pret Cnj Act) => tal + "ade" ; + VF (Pret Cnj Pass) => tal + "ades" ; + VF Imper => tal + "a" ; + VI (Inf Act) => tal + "a" ; + VI (Inf Pass) => tal + "as" ; + VI (Supin Act) => tal + "at" ; + VI (Supin Pass) => tal + "ats" ; + VI (PtPres Nom) => tal + "ande" ; + VI (PtPres Gen) => tal + "andes" ; + VI (PtPret (Strong (ASg Utr)) Nom) => tal + "ad" ; + VI (PtPret (Strong (ASg Utr)) Gen) => tal + "ads" ; + VI (PtPret (Strong (ASg Neutr)) Nom) => tal + "at" ; + VI (PtPret (Strong (ASg Neutr)) Gen) => tal + "ats" ; + VI (PtPret (Strong APl) Nom) => tal + "ade" ; + VI (PtPret (Strong APl) Gen) => tal + "ades" ; + VI (PtPret (Weak (AxSg NoMasc)) Nom) => tal + "ade" ; + VI (PtPret (Weak (AxSg NoMasc)) Gen) => tal + "ades" ; + VI (PtPret (Weak (AxSg Masc)) Nom) => tal + "ade" ; + VI (PtPret (Weak (AxSg Masc)) Gen) => tal + "ades" ; + VI (PtPret (Weak AxPl) Nom) => tal + "ade" ; + VI (PtPret (Weak AxPl) Gen) => tal + "ades" + } + } ; + +oper vLeka : Str -> Verbum = \lek -> + {s = table { + VF (Pres Ind Act) => lek + "er" ; + VF (Pres Ind Pass) => variants {lek + "s" ; lek + "es"} ; + VF (Pres Cnj Act) => lek + "e" ; + VF (Pres Cnj Pass) => lek + "es" ; + VF (Pret Ind Act) => lek + "te" ; + VF (Pret Ind Pass) => lek + "tes" ; + VF (Pret Cnj Act) => lek + "te" ; + VF (Pret Cnj Pass) => lek + "tes" ; + VF Imper => lek ; + VI (Inf Act) => lek + "a" ; + VI (Inf Pass) => lek + "as" ; + VI (Supin Act) => lek + "t" ; + VI (Supin Pass) => lek + "ts" ; + VI (PtPres Nom) => lek + "ande" ; + VI (PtPres Gen) => lek + "andes" ; + VI (PtPret (Strong (ASg Utr)) Nom) => lek + "t" ; + VI (PtPret (Strong (ASg Utr)) Gen) => lek + "ts" ; + VI (PtPret (Strong (ASg Neutr)) Nom) => lek + "t" ; + VI (PtPret (Strong (ASg Neutr)) Gen) => lek + "ts" ; + VI (PtPret (Strong APl) Nom) => lek + "ta" ; + VI (PtPret (Strong APl) Gen) => lek + "tas" ; + VI (PtPret (Weak (AxSg NoMasc)) Nom) => lek + "ta" ; + VI (PtPret (Weak (AxSg NoMasc)) Gen) => lek + "tas" ; + VI (PtPret (Weak (AxSg Masc)) Nom) => lek + "te" ; + VI (PtPret (Weak (AxSg Masc)) Gen) => lek + "tes" ; + VI (PtPret (Weak AxPl) Nom) => lek + "ta" ; + VI (PtPret (Weak AxPl) Gen) => lek + "tas" + } + } ; + +oper vTyda : Str -> Verbum = \ty -> + {s = table { + VF (Pres Ind Act) => ty + "der" ; + VF (Pres Ind Pass) => variants {ty + "ds" ; ty + "des"} ; + VF (Pres Cnj Act) => ty + "de" ; + VF (Pres Cnj Pass) => ty + "des" ; + VF (Pret Ind Act) => ty + "dde" ; + VF (Pret Ind Pass) => ty + "ddes" ; + VF (Pret Cnj Act) => ty + "dde" ; + VF (Pret Cnj Pass) => ty + "ddes" ; + VF Imper => ty + "d" ; + VI (Inf Act) => ty + "da" ; + VI (Inf Pass) => ty + "das" ; + VI (Supin Act) => ty + "tt" ; + VI (Supin Pass) => ty + "tts" ; + VI (PtPres Nom) => ty + "dande" ; + VI (PtPres Gen) => ty + "dandes" ; + VI (PtPret (Strong (ASg Utr)) Nom) => ty + "dd" ; + VI (PtPret (Strong (ASg Utr)) Gen) => ty + "dds" ; + VI (PtPret (Strong (ASg Neutr)) Nom) => ty + "tt" ; + VI (PtPret (Strong (ASg Neutr)) Gen) => ty + "tts" ; + VI (PtPret (Strong APl) Nom) => ty + "dda" ; + VI (PtPret (Strong APl) Gen) => ty + "ddas" ; + VI (PtPret (Weak (AxSg NoMasc)) Nom) => ty + "dda" ; + VI (PtPret (Weak (AxSg NoMasc)) Gen) => ty + "ddas" ; + VI (PtPret (Weak (AxSg Masc)) Nom) => ty + "dde" ; + VI (PtPret (Weak (AxSg Masc)) Gen) => ty + "ddes" ; + VI (PtPret (Weak AxPl) Nom) => ty + "dda" ; + VI (PtPret (Weak AxPl) Gen) => ty + "ddas" + } + } ; + +oper vVända : Str -> Verbum = \vän -> + {s = table { + VF (Pres Ind Act) => vän + "der" ; + VF (Pres Ind Pass) => variants {vän + "ds" ; vän + "des"} ; + VF (Pres Cnj Act) => vän + "de" ; + VF (Pres Cnj Pass) => vän + "des" ; + VF (Pret Ind Act) => vän + "de" ; + VF (Pret Ind Pass) => vän + "des" ; + VF (Pret Cnj Act) => vän + "de" ; + VF (Pret Cnj Pass) => vän + "des" ; + VF Imper => vän + "d" ; + VI (Inf Act) => vän + "da" ; + VI (Inf Pass) => vän + "das" ; + VI (Supin Act) => vän + "t" ; + VI (Supin Pass) => vän + "ts" ; + VI (PtPres Nom) => vän + "dande" ; + VI (PtPres Gen) => vän + "dandes" ; + VI (PtPret (Strong (ASg Utr)) Nom) => vän + "d" ; + VI (PtPret (Strong (ASg Utr)) Gen) => vän + "ds" ; + VI (PtPret (Strong (ASg Neutr)) Nom) => vän + "t" ; + VI (PtPret (Strong (ASg Neutr)) Gen) => vän + "ts" ; + VI (PtPret (Strong APl) Nom) => vän + "da" ; + VI (PtPret (Strong APl) Gen) => vän + "das" ; + VI (PtPret (Weak (AxSg NoMasc)) Nom) => vän + "da" ; + VI (PtPret (Weak (AxSg NoMasc)) Gen) => vän + "das" ; + VI (PtPret (Weak (AxSg Masc)) Nom) => vän + "de" ; + VI (PtPret (Weak (AxSg Masc)) Gen) => vän + "des" ; + VI (PtPret (Weak AxPl) Nom) => vän + "da" ; + VI (PtPret (Weak AxPl) Gen) => vän + "das" + } + } ; + +oper vByta : Str -> Verbum = \by -> + {s = table { + VF (Pres Ind Act) => by + "ter" ; + VF (Pres Ind Pass) => variants {by + "ts" ; by + "tes"} ; + VF (Pres Cnj Act) => by + "te" ; + VF (Pres Cnj Pass) => by + "tes" ; + VF (Pret Ind Act) => by + "tte" ; + VF (Pret Ind Pass) => by + "ttes" ; + VF (Pret Cnj Act) => by + "tte" ; + VF (Pret Cnj Pass) => by + "ttes" ; + VF Imper => by + "t" ; + VI (Inf Act) => by + "ta" ; + VI (Inf Pass) => by + "tas" ; + VI (Supin Act) => by + "tt" ; + VI (Supin Pass) => by + "tts" ; + VI (PtPres Nom) => by + "tande" ; + VI (PtPres Gen) => by + "tandes" ; + VI (PtPret (Strong (ASg Utr)) Nom) => by + "tt" ; + VI (PtPret (Strong (ASg Utr)) Gen) => by + "tts" ; + VI (PtPret (Strong (ASg Neutr)) Nom) => by + "tt" ; + VI (PtPret (Strong (ASg Neutr)) Gen) => by + "tts" ; + VI (PtPret (Strong APl) Nom) => by + "tta" ; + VI (PtPret (Strong APl) Gen) => by + "ttas" ; + VI (PtPret (Weak (AxSg NoMasc)) Nom) => by + "tta" ; + VI (PtPret (Weak (AxSg NoMasc)) Gen) => by + "ttas" ; + VI (PtPret (Weak (AxSg Masc)) Nom) => by + "tte" ; + VI (PtPret (Weak (AxSg Masc)) Gen) => by + "ttes" ; + VI (PtPret (Weak AxPl) Nom) => by + "tta" ; + VI (PtPret (Weak AxPl) Gen) => by + "ttas" + } + } ; + +oper vGömma : Str -> Verbum = \göm -> + {s = table { + VF (Pres Ind Act) => göm + "mer" ; + VF (Pres Ind Pass) => variants {göm + "s" ; göm + "mes"} ; + VF (Pres Cnj Act) => göm + "me" ; + VF (Pres Cnj Pass) => göm + "mes" ; + VF (Pret Ind Act) => göm + "de" ; + VF (Pret Ind Pass) => göm + "des" ; + VF (Pret Cnj Act) => göm + "de" ; + VF (Pret Cnj Pass) => göm + "des" ; + VF Imper => göm ; + VI (Inf Act) => göm + "ma" ; + VI (Inf Pass) => göm + "mas" ; + VI (Supin Act) => göm + "t" ; + VI (Supin Pass) => göm + "ts" ; + VI (PtPres Nom) => göm + "mande" ; + VI (PtPres Gen) => göm + "mandes" ; + VI (PtPret (Strong (ASg Utr)) Nom) => göm + "d" ; + VI (PtPret (Strong (ASg Utr)) Gen) => göm + "ds" ; + VI (PtPret (Strong (ASg Neutr)) Nom) => göm + "t" ; + VI (PtPret (Strong (ASg Neutr)) Gen) => göm + "ts" ; + VI (PtPret (Strong APl) Nom) => göm + "da" ; + VI (PtPret (Strong APl) Gen) => göm + "das" ; + VI (PtPret (Weak (AxSg NoMasc)) Nom) => göm + "da" ; + VI (PtPret (Weak (AxSg NoMasc)) Gen) => göm + "das" ; + VI (PtPret (Weak (AxSg Masc)) Nom) => göm + "de" ; + VI (PtPret (Weak (AxSg Masc)) Gen) => göm + "des" ; + VI (PtPret (Weak AxPl) Nom) => göm + "da" ; + VI (PtPret (Weak AxPl) Gen) => göm + "das" + } + } ; + +oper vHyra : Str -> Verbum = \hyr -> + {s = table { + VF (Pres Ind Act) => hyr ; + VF (Pres Ind Pass) => variants {hyr + "s" ; hyr + "es"} ; + VF (Pres Cnj Act) => hyr + "e" ; + VF (Pres Cnj Pass) => hyr + "es" ; + VF (Pret Ind Act) => hyr + "de" ; + VF (Pret Ind Pass) => hyr + "des" ; + VF (Pret Cnj Act) => hyr + "de" ; + VF (Pret Cnj Pass) => hyr + "des" ; + VF Imper => hyr ; + VI (Inf Act) => hyr + "a" ; + VI (Inf Pass) => hyr + "as" ; + VI (Supin Act) => hyr + "t" ; + VI (Supin Pass) => hyr + "ts" ; + VI (PtPres Nom) => hyr + "ande" ; + VI (PtPres Gen) => hyr + "andes" ; + VI (PtPret (Strong (ASg Utr)) Nom) => hyr + "d" ; + VI (PtPret (Strong (ASg Utr)) Gen) => hyr + "ds" ; + VI (PtPret (Strong (ASg Neutr)) Nom) => hyr + "t" ; + VI (PtPret (Strong (ASg Neutr)) Gen) => hyr + "ts" ; + VI (PtPret (Strong APl) Nom) => hyr + "da" ; + VI (PtPret (Strong APl) Gen) => hyr + "das" ; + VI (PtPret (Weak (AxSg NoMasc)) Nom) => hyr + "da" ; + VI (PtPret (Weak (AxSg NoMasc)) Gen) => hyr + "das" ; + VI (PtPret (Weak (AxSg Masc)) Nom) => hyr + "de" ; + VI (PtPret (Weak (AxSg Masc)) Gen) => hyr + "des" ; + VI (PtPret (Weak AxPl) Nom) => hyr + "da" ; + VI (PtPret (Weak AxPl) Gen) => hyr + "das" + } + } ; + +oper vTåla : Str -> Verbum = \tål -> + {s = table { + VF (Pres Ind Act) => tål ; + VF (Pres Ind Pass) => variants {tål + "s" ; tål + "es"} ; + VF (Pres Cnj Act) => tål + "e" ; + VF (Pres Cnj Pass) => tål + "es" ; + VF (Pret Ind Act) => tål + "de" ; + VF (Pret Ind Pass) => tål + "des" ; + VF (Pret Cnj Act) => tål + "de" ; + VF (Pret Cnj Pass) => tål + "des" ; + VF Imper => tål ; + VI (Inf Act) => tål + "a" ; + VI (Inf Pass) => tål + "as" ; + VI (Supin Act) => tål + "t" ; + VI (Supin Pass) => tål + "ts" ; + VI (PtPres Nom) => tål + "ande" ; + VI (PtPres Gen) => tål + "andes" ; + VI (PtPret (Strong (ASg Utr)) Nom) => tål + "d" ; + VI (PtPret (Strong (ASg Utr)) Gen) => tål + "ds" ; + VI (PtPret (Strong (ASg Neutr)) Nom) => tål + "t" ; + VI (PtPret (Strong (ASg Neutr)) Gen) => tål + "ts" ; + VI (PtPret (Strong APl) Nom) => tål + "da" ; + VI (PtPret (Strong APl) Gen) => tål + "das" ; + VI (PtPret (Weak (AxSg NoMasc)) Nom) => tål + "da" ; + VI (PtPret (Weak (AxSg NoMasc)) Gen) => tål + "das" ; + VI (PtPret (Weak (AxSg Masc)) Nom) => tål + "de" ; + VI (PtPret (Weak (AxSg Masc)) Gen) => tål + "des" ; + VI (PtPret (Weak AxPl) Nom) => tål + "da" ; + VI (PtPret (Weak AxPl) Gen) => tål + "das" + } + } ; + +oper vFinna : (_,_,_ : Str) -> Verbum = \finn, fann, funn -> + {s = table { + VF (Pres Ind Act) => finn + "er" ; + VF (Pres Ind Pass) => variants {finn + "s" ; finn + "es"} ; + VF (Pres Cnj Act) => finn + "e" ; + VF (Pres Cnj Pass) => finn + "es" ; + VF (Pret Ind Act) => fann ; + VF (Pret Ind Pass) => fann + "s" ; + VF (Pret Cnj Act) => funn + "e" ; + VF (Pret Cnj Pass) => funn + "es" ; + VF Imper => finn ; + VI (Inf Act) => finn + "a" ; + VI (Inf Pass) => finn + "as" ; + VI (Supin Act) => funn + "it" ; + VI (Supin Pass) => funn + "its" ; + VI (PtPres Nom) => finn + "ande" ; + VI (PtPres Gen) => finn + "andes" ; + VI (PtPret (Strong (ASg Utr)) Nom) => funn + "en" ; + VI (PtPret (Strong (ASg Utr)) Gen) => funn + "ens" ; + VI (PtPret (Strong (ASg Neutr)) Nom) => funn + "et" ; + VI (PtPret (Strong (ASg Neutr)) Gen) => funn + "ets" ; + VI (PtPret (Strong APl) Nom) => funn + "a" ; + VI (PtPret (Strong APl) Gen) => funn + "as" ; + VI (PtPret (Weak (AxSg NoMasc)) Nom) => funn + "a" ; + VI (PtPret (Weak (AxSg NoMasc)) Gen) => funn + "as" ; + VI (PtPret (Weak (AxSg Masc)) Nom) => funn + "e" ; + VI (PtPret (Weak (AxSg Masc)) Gen) => funn + "es" ; + VI (PtPret (Weak AxPl) Nom) => funn + "a" ; + VI (PtPret (Weak AxPl) Gen) => funn + "as" + } + } ; + +-- machine-generated exceptional inflection tables from rules.Swe.gf + +oper mor_1 : Subst = + {s = table { + SF Sg Indef Nom => variants {"mor" ; "moder"} ; + SF Sg Indef Gen => variants {"mors" ; "moders"} ; + SF Sg Def Nom => "modern" ; + SF Sg Def Gen => "moderns" ; + SF Pl Indef Nom => "mödrar" ; + SF Pl Indef Gen => "mödrars" ; + SF Pl Def Nom => "mödrarna" ; + SF Pl Def Gen => "mödrarnas" + } ; + h1 = Utr + } ; + +oper farbror_8 : Subst = + {s = table { + SF Sg Indef Nom => variants {"farbror" ; "farbroder"} ; + SF Sg Indef Gen => variants {"farbrors" ; "farbroders"} ; + SF Sg Def Nom => "farbrodern" ; + SF Sg Def Gen => "farbroderns" ; + SF Pl Indef Nom => "farbröder" ; + SF Pl Indef Gen => "farbröders" ; + SF Pl Def Nom => "farbröderna" ; + SF Pl Def Gen => "farbrödernas" + } ; + h1 = Utr + } ; + +oper gammal_16 : Adj = + {s = table { + AF (Posit (Strong (ASg Utr))) Nom => "gammal" ; + AF (Posit (Strong (ASg Utr))) Gen => "gammals" ; + AF (Posit (Strong (ASg Neutr))) Nom => "gammalt" ; + AF (Posit (Strong (ASg Neutr))) Gen => "gammalts" ; + AF (Posit (Strong APl)) Nom => "gamla" ; + AF (Posit (Strong APl)) Gen => "gamlas" ; + AF (Posit (Weak (AxSg NoMasc))) Nom => "gamla" ; + AF (Posit (Weak (AxSg NoMasc))) Gen => "gamlas" ; + AF (Posit (Weak (AxSg Masc))) Nom => "gamle" ; + AF (Posit (Weak (AxSg Masc))) Gen => "gamles" ; + AF (Posit (Weak AxPl)) Nom => "gamla" ; + AF (Posit (Weak AxPl)) Gen => "gamlas" ; + AF Compar Nom => "äldre" ; + AF Compar Gen => "äldres" ; + AF (Super SupStrong) Nom => "äldst" ; + AF (Super SupStrong) Gen => "äldsts" ; + AF (Super SupWeak) Nom => "äldsta" ; + AF (Super SupWeak) Gen => "äldstas" + } + } ; + + +oper stor_25 : Adj = + {s = table { + AF (Posit (Strong (ASg Utr))) Nom => "stor" ; + AF (Posit (Strong (ASg Utr))) Gen => "stors" ; + AF (Posit (Strong (ASg Neutr))) Nom => "stort" ; + AF (Posit (Strong (ASg Neutr))) Gen => "storts" ; + AF (Posit (Strong APl)) Nom => "stora" ; + AF (Posit (Strong APl)) Gen => "storas" ; + AF (Posit (Weak (AxSg NoMasc))) Nom => "stora" ; + AF (Posit (Weak (AxSg NoMasc))) Gen => "storas" ; + AF (Posit (Weak (AxSg Masc))) Nom => "store" ; + AF (Posit (Weak (AxSg Masc))) Gen => "stores" ; + AF (Posit (Weak AxPl)) Nom => "stora" ; + AF (Posit (Weak AxPl)) Gen => "storas" ; + AF Compar Nom => "större" ; + AF Compar Gen => "störres" ; + AF (Super SupStrong) Nom => "störst" ; + AF (Super SupStrong) Gen => "störsts" ; + AF (Super SupWeak) Nom => "största" ; + AF (Super SupWeak) Gen => "störstas" + } + } ; + +oper ung_29 : Adj = + {s = table { + AF (Posit (Strong (ASg Utr))) Nom => "ung" ; + AF (Posit (Strong (ASg Utr))) Gen => "ungs" ; + AF (Posit (Strong (ASg Neutr))) Nom => "ungt" ; + AF (Posit (Strong (ASg Neutr))) Gen => "ungts" ; + AF (Posit (Strong APl)) Nom => "unga" ; + AF (Posit (Strong APl)) Gen => "ungas" ; + AF (Posit (Weak (AxSg NoMasc))) Nom => "unga" ; + AF (Posit (Weak (AxSg NoMasc))) Gen => "ungas" ; + AF (Posit (Weak (AxSg Masc))) Nom => "unge" ; + AF (Posit (Weak (AxSg Masc))) Gen => "unges" ; + AF (Posit (Weak AxPl)) Nom => "unga" ; + AF (Posit (Weak AxPl)) Gen => "ungas" ; + AF Compar Nom => "yngre" ; + AF Compar Gen => "yngres" ; + AF (Super SupStrong) Nom => "yngst" ; + AF (Super SupStrong) Gen => "yngsts" ; + AF (Super SupWeak) Nom => "yngsta" ; + AF (Super SupWeak) Gen => "yngstas" + } + } ; + + +oper jag_32 : ProPN = + {s = table { + PNom => "jag" ; + PAcc => "mig" ; + PGen (ASg Utr) => "min" ; + PGen (ASg Neutr) => "mitt" ; + PGen APl => "mina" + } ; + h1 = Utr ; + h2 = Sg ; + h3 = P1 + } ; + +oper du_33 : ProPN = + {s = table { + PNom => "du" ; + PAcc => "dig" ; + PGen (ASg Utr) => "din" ; + PGen (ASg Neutr) => "ditt" ; + PGen APl => "dina" + } ; + h1 = Utr ; + h2 = Sg ; + h3 = P2 + } ; + +oper han_34 : ProPN = + {s = table { + PNom => "han" ; + PAcc => "honom" ; + PGen (ASg Utr) => "hans" ; + PGen (ASg Neutr) => "hans" ; + PGen APl => "hans" + } ; + h1 = Utr ; + h2 = Sg ; + h3 = P3 + } ; + +oper hon_35 : ProPN = + {s = table { + PNom => "hon" ; + PAcc => "henne" ; + PGen (ASg Utr) => "hennes" ; + PGen (ASg Neutr) => "hennes" ; + PGen APl => "hennes" + } ; + h1 = Utr ; + h2 = Sg ; + h3 = P3 + } ; + +oper vi_36 : ProPN = + {s = table { + PNom => "vi" ; + PAcc => "oss" ; + PGen (ASg Utr) => "vår" ; + PGen (ASg Neutr) => "vårt" ; + PGen APl => "våra" + } ; + h1 = Utr ; + h2 = Pl ; + h3 = P1 + } ; + +oper ni_37 : ProPN = + {s = table { + PNom => "ni" ; + PAcc => "er" ; + PGen (ASg Utr) => "er" ; + PGen (ASg Neutr) => "ert" ; + PGen APl => "era" + } ; + h1 = Utr ; + h2 = Pl ; + h3 = P2 + } ; + +oper de_38 : ProPN = + {s = table { + PNom => "de" ; + PAcc => "dem" ; + PGen (ASg Utr) => "deras" ; + PGen (ASg Neutr) => "deras" ; + PGen APl => "deras" + } ; + h1 = Utr ; + h2 = Pl ; + h3 = P3 + } ; + +oper den_39 : ProPN = + {s = table { + PNom => "den" ; + PAcc => "den" ; + PGen (ASg Utr) => "dess" ; + PGen (ASg Neutr) => "dess" ; + PGen APl => "dess" + } ; + h1 = Utr ; + h2 = Sg ; + h3 = P3 + } ; + +oper det_40 : ProPN = + {s = table { + PNom => "det" ; + PAcc => "det" ; + PGen (ASg Utr) => "dess" ; + PGen (ASg Neutr) => "dess" ; + PGen APl => "dess" + } ; + h1 = Neutr ; + h2 = Sg ; + h3 = P3 + } ; + +oper man_1144 : Subst = + {s = table { + SF Sg Indef Nom => "man" ; + SF Sg Indef Gen => "mans" ; + SF Sg Def Nom => "mannen" ; + SF Sg Def Gen => "mannens" ; + SF Pl Indef Nom => "män" ; + SF Pl Indef Gen => "mäns" ; + SF Pl Def Nom => "männen" ; + SF Pl Def Gen => "männens" + } ; + h1 = Utr + } ; + +oper liten_1146 : Adj = + {s = table { + AF (Posit (Strong (ASg Utr))) Nom => "liten" ; + AF (Posit (Strong (ASg Utr))) Gen => "litens" ; + AF (Posit (Strong (ASg Neutr))) Nom => "litet" ; + AF (Posit (Strong (ASg Neutr))) Gen => "litets" ; + AF (Posit (Strong APl)) Nom => "små" ; + AF (Posit (Strong APl)) Gen => "smås" ; + AF (Posit (Weak (AxSg NoMasc))) Nom => "lilla" ; + AF (Posit (Weak (AxSg NoMasc))) Gen => "lillas" ; + AF (Posit (Weak (AxSg Masc))) Nom => "lille" ; + AF (Posit (Weak (AxSg Masc))) Gen => "lilles" ; + AF (Posit (Weak AxPl)) Nom => "små" ; + AF (Posit (Weak AxPl)) Gen => "smås" ; + AF Compar Nom => "mindre" ; + AF Compar Gen => "mindres" ; + AF (Super SupStrong) Nom => "minst" ; + AF (Super SupStrong) Gen => "minsts" ; + AF (Super SupWeak) Nom => "minsta" ; + AF (Super SupWeak) Gen => "minstas" + } + } ; + +oper gå_1174 : Verbum = + {s = table { + VF (Pres Ind Act) => "går" ; + VF (Pres Ind Pass) => "gås" ; + VF (Pres Cnj Act) => "gå" ; + VF (Pres Cnj Pass) => "gås" ; + VF (Pret Ind Act) => "gick" ; + VF (Pret Ind Pass) => "gicks" ; + VF (Pret Cnj Act) => "ginge" ; + VF (Pret Cnj Pass) => "ginges" ; + VF Imper => "gå" ; + VI (Inf Act) => "gå" ; + VI (Inf Pass) => "gås" ; + VI (Supin Act) => "gått" ; + VI (Supin Pass) => "gåtts" ; + VI (PtPres Nom) => "gående" ; + VI (PtPres Gen) => "gåendes" ; + VI (PtPret (Strong (ASg Utr)) Nom) => "gången" ; + VI (PtPret (Strong (ASg Utr)) Gen) => "gångens" ; + VI (PtPret (Strong (ASg Neutr)) Nom) => "gånget" ; + VI (PtPret (Strong (ASg Neutr)) Gen) => "gångets" ; + VI (PtPret (Strong APl) Nom) => "gångna" ; + VI (PtPret (Strong APl) Gen) => "gångnas" ; + VI (PtPret (Weak (AxSg NoMasc)) Nom) => "gångna" ; + VI (PtPret (Weak (AxSg NoMasc)) Gen) => "gångnas" ; + VI (PtPret (Weak (AxSg Masc)) Nom) => "gångne" ; + VI (PtPret (Weak (AxSg Masc)) Gen) => "gångnes" ; + VI (PtPret (Weak AxPl) Nom) => "gångna" ; + VI (PtPret (Weak AxPl) Gen) => "gångnas" + } + } ; +} diff --git a/grammars/resource/swedish/ResSwe.gf b/grammars/resource/swedish/ResSwe.gf new file mode 100644 index 000000000..747929d59 --- /dev/null +++ b/grammars/resource/swedish/ResSwe.gf @@ -0,0 +1,196 @@ +--1 The Top-Level Swedish Resource Grammar +-- +-- Aarne Ranta 2002 -- 2003 +-- +-- This is the Swedish concrete syntax of the multilingual resource +-- grammar. Most of the work is done in the file $syntax.Swe.gf$. +-- However, for the purpose of documentation, we make here explicit the +-- linearization types of each category, so that their structures and +-- dependencies can be seen. +-- Another substantial part are the linearization rules of some +-- structural words. +-- +-- The users of the resource grammar should not look at this file for the +-- linearization rules, which are in fact hidden in the document version. +-- They should use $resource.Abs.gf$ to access the syntactic rules. +-- This file can be consulted in those, hopefully rare, occasions in which +-- one has to know how the syntactic categories are +-- implemented. The parameter types are defined in $Types.gf$. + +concrete ResSwe of ResAbs = open Prelude, Syntax in { + +flags + startcat=Phr ; + parser=chart ; + +lincat + CN = {s : Number => SpeciesP => Case => Str ; g : Gender ; x : Sex ; + p : IsComplexCN} ; + N = CommNoun ; + -- = {s : Number => Species => Case => Str ; g : Gender ; x : Sex} ; + NP = NounPhrase ; + -- = {s : NPForm => Str ; g : Gender ; n : Number} ; + PN = {s : Case => Str ; g : Gender ; x : Sex} ; + Det = {s : Gender => Sex => Str ; n : Number ; b : SpeciesP} ; + Fun = CommNoun ** {s2 : Preposition} ; + + Adj1 = Adjective ; + -- = {s : AdjFormPos => Case => Str} ; + Adj2 = Adjective ** {s2 : Preposition} ; + AdjDeg = {s : AdjForm => Str} ; + AP = Adjective ** {p : IsPostfixAdj} ; + + V = Verb ; + -- = {s : VForm => Str} ; + VP = Verb ** {s2 : Str ; s3 : Gender => Number => Str} ; + TV = Verb ** {s2 : Preposition} ; + VS = Verb ; + + AdV = {s : Str ; isPost : Bool} ; + + S = Sentence ; + -- = {s : Order => Str} ; + Slash = Sentence ** {s2 : Preposition} ; + RP = {s : RelCase => GenNum => Str ; g : RelGender} ; + RC = {s : GenNum => Str} ; + IP = NounPhrase ; + Qu = {s : QuestForm => Str} ; + Imp = {s : Number => Str} ; + + Phr = {s : Str} ; + + Conj = {s : Str ; n : Number} ; + ConjD = {s1 : Str ; s2 : Str ; n : Number} ; + + ListS = {s1,s2 : Order => Str} ; + ListAP = {s1,s2 : AdjFormPos => Case => Str ; p : Bool} ; + ListNP = {s1,s2 : NPForm => Str ; g : Gender ; n : Number} ; + +--. + +lin + UseN = noun2CommNounPhrase ; + ModAdj = modCommNounPhrase ; + ModGenOne = npGenDet singular ; + ModGenMany = npGenDet plural ; + UsePN = nameNounPhrase ; + UseFun = funAsCommNounPhrase ; + AppFun = appFunComm ; + AdjP1 = adj2adjPhrase ; + ComplAdj = complAdj ; + PositAdjP = positAdjPhrase ; + ComparAdjP = comparAdjPhrase ; + SuperlNP = superlNounPhrase ; + + DetNP = detNounPhrase ; + IndefOneNP = indefNounPhrase singular ; + IndefManyNP = indefNounPhrase plural ; + DefOneNP = defNounPhrase singular ; + DefManyNP = defNounPhrase plural ; + + PredVP = predVerbPhrase ; + PosV = predVerb True ; + NegV = predVerb False ; + PosA = predAdjective True ; + NegA = predAdjective False ; + PosCN = predCommNoun True ; + NegCN = predCommNoun False ; + PosTV = complTransVerb True ; + NegTV = complTransVerb False ; + PosNP = predNounPhrase True ; + NegNP = predNounPhrase False ; + PosVS = complSentVerb True ; + NegVS = complSentVerb False ; + + + AdvVP = adVerbPhrase ; + LocNP = locativeNounPhrase ; + AdvCN = advCommNounPhrase ; + + PosSlashTV = slashTransVerb True ; + NegSlashTV = slashTransVerb False ; + + IdRP = identRelPron ; + FunRP = funRelPron ; + RelVP = relVerbPhrase ; + RelSlash = relSlash ; + ModRC = modRelClause ; + RelSuch = relSuch ; + + WhoOne = intPronWho singular ; + WhoMany = intPronWho plural ; + WhatOne = intPronWhat singular ; + WhatMany = intPronWhat plural ; + FunIP = funIntPron ; + NounIPOne = nounIntPron singular ; + NounIPMany = nounIntPron plural ; + + QuestVP = questVerbPhrase ; + IntVP = intVerbPhrase ; + IntSlash = intSlash ; + QuestAdv = questAdverbial ; + + ImperVP = imperVerbPhrase ; + + IndicPhrase = indicUtt ; + QuestPhrase = interrogUtt ; + ImperOne = imperUtterance singular ; + ImperMany = imperUtterance plural ; + +lin + TwoS = twoSentence ; + ConsS = consSentence ; + ConjS = conjunctSentence ; + ConjDS = conjunctDistrSentence ; + + TwoAP = twoAdjPhrase ; + ConsAP = consAdjPhrase ; + ConjAP = conjunctAdjPhrase ; + ConjDAP = conjunctDistrAdjPhrase ; + + TwoNP = twoNounPhrase ; + ConsNP = consNounPhrase ; + ConjNP = conjunctNounPhrase ; + ConjDNP = conjunctDistrNounPhrase ; + + SubjS = subjunctSentence ; + SubjImper = subjunctImperative ; + SubjQu = subjunctQuestion ; + + PhrNP = useNounPhrase ; + PhrOneCN = useCommonNounPhrase singular ; + PhrManyCN = useCommonNounPhrase plural ; + PhrIP ip = ip ; + PhrIAdv ia = ia ; + + INP = pronNounPhrase jag_32 ; + ThouNP = pronNounPhrase du_33 ; + HeNP = pronNounPhrase han_34 ; + SheNP = pronNounPhrase hon_35 ; + WeNP = pronNounPhrase vi_36 ; + YeNP = pronNounPhrase ni_37 ; + TheyNP = pronNounPhrase de_38 ; + + YouNP = let {ni = pronNounPhrase ni_37 } in {s = ni.s ; g = ni.g ; n = Sg} ; + + EveryDet = varjeDet ; + AllDet = allaDet ; + WhichDet = vilkenDet ; + MostDet = flestaDet ; + + HowIAdv = ss "hur" ; + WhenIAdv = ss "när" ; + WhereIAdv = ss "var" ; + WhyIAdv = ss "varför" ; + + AndConj = ss "och" ** {n = Pl} ; + OrConj = ss "eller" ** {n = Sg} ; + BothAnd = sd2 "både" "och" ** {n = Pl} ; + EitherOr = sd2 "antingen" "eller" ** {n = Sg} ; + NeitherNor = sd2 "varken" "eller" ** {n = Sg} ; + IfSubj = ss "om" ; + WhenSubj = ss "när" ; + + PhrYes = ss ["Ja ."] ; + PhrNo = ss ["Nej ."] ; +} ; diff --git a/grammars/resource/swedish/Svenska.gf b/grammars/resource/swedish/Svenska.gf new file mode 100644 index 000000000..b86c1bb1d --- /dev/null +++ b/grammars/resource/swedish/Svenska.gf @@ -0,0 +1 @@ +resource Svenska = reuse ResSwe ; diff --git a/grammars/resource/swedish/Syntax.gf b/grammars/resource/swedish/Syntax.gf new file mode 100644 index 000000000..dab69b406 --- /dev/null +++ b/grammars/resource/swedish/Syntax.gf @@ -0,0 +1,1000 @@ +--1 A Small Swedish Resource Syntax +-- +-- Aarne Ranta 2002 +-- +-- This resource grammar contains definitions needed to construct +-- indicative, interrogative, and imperative sentences in Swedish. +-- +-- The following modules are presupposed: + +resource Syntax = Morpho ** open Prelude, (CO = Coordination) in { + +--2 Common Nouns +-- +--3 Simple common nouns + +oper + CommNoun : Type = {s : Number => Species => Case => Str ; g : Gender ; x : Sex} ; + +-- When common nouns are extracted from lexicon, the composite noun form is ignored. +-- But we have to indicate a sex. + extCommNoun : Sex -> Subst -> CommNoun = \x,sb -> + {s = \\n,b,c => sb.s ! SF n b c ; + g = sb.h1 ; + x = x} ; + +-- These constants are used for data abstraction over the parameter type $Num$. + singular = Sg ; + plural = Pl ; + +--3 Common noun phrases + +-- The need for this more complex type comes from the variation in the way in +-- which a modifying adjective is inflected after different determiners: +-- "(en) ful orm" / "(den) fula ormen" / "(min) fula orm". +param + SpeciesP = IndefP | DefP Species ; + +-- We also have to be able to decide if a $CommNounPhrase$ is complex +-- (to form the definite form: "bilen" / "den stora bilen"). + +oper + IsComplexCN : Type = Bool ; + +-- Coercions between simple $Species$ and $SpeciesP$: + unSpeciesP : SpeciesP -> Species = \b -> + case b of {IndefP => Indef ; DefP p => p} ; -- bil/bil/bilen + unSpeciesAdjP : SpeciesP -> Species = \b -> + case b of {IndefP => Indef ; DefP _ => Def} ; -- gammal/gamla/gamla + +-- Here's the type itself. + CommNounPhrase : Type = + {s : Number => SpeciesP => Case => Str ; + g : Gender ; x : Sex ; p : IsComplexCN} ; + +-- To use a $CommNoun$ as $CommNounPhrase$. + noun2CommNounPhrase : CommNoun -> CommNounPhrase = \hus -> + {s = \\n,b,c => hus.s ! n ! unSpeciesP b ! c ; + g = hus.g ; x = hus.x ; p = False} ; + + n2n = noun2CommNounPhrase ; + + +--2 Noun Phrases +-- +-- The worst case for noun phrases is pronouns, which have inflection +-- in (what is syntactically) their genitive. Most noun phrases can +-- ignore this variation. + +oper + npCase : NPForm -> Case = \c -> case c of {PGen _ => Gen ; _ => Nom} ; + mkNPForm : Case -> NPForm = \c -> case c of {Gen => PGen APl ; _ => PNom} ; + + NounPhrase : Type = {s : NPForm => Str ; g : Gender ; n : Number} ; + +-- Proper names are a simple kind of noun phrases. However, we want to +-- anticipate the rule that proper names can be modified by +-- adjectives, even though noun phrases in general cannot - hence the sex. + + ProperName : Type = {s : Case => Str ; g : Gender ; x : Sex} ; + + mkProperName : Str -> Gender -> Sex -> ProperName = \john,g,x -> + {s = table {Nom => john ; Gen => john + "s"} ; g = g ; x = x} ; + + nameNounPhrase : ProperName -> NounPhrase = + \john -> {s = table {c => john.s ! npCase c} ; g = john.g ; n = Sg} ; + + pronNounPhrase : ProPN -> NounPhrase = \jag -> + {s = jag.s ; g = jag.h1 ; n = jag.h2} ; + +--2 Determiners +-- +-- Determiners are inflected according to noun in gender and sex. +-- The number and species of the noun are determined by the determiner. + + Determiner : Type = {s : Gender => Sex => Str ; n : Number ; b : SpeciesP} ; + +-- This is the rule for building noun phrases. + + detNounPhrase : Determiner -> CommNounPhrase -> NounPhrase = \en, man -> + {s = table {c => en.s ! man.g ! man.x ++ man.s ! en.n ! en.b ! npCase c} ; + g = man.g ; n = en.n} ; + +-- The following macros are sufficient to define most determiners. +-- All $SpeciesP$ values come into question: +-- "en god vän" - "min gode vän" - "den gode vännen". + + DetSg : Type = Gender => Sex => Str ; + DetPl : Type = Str ; + + mkDeterminerSg : DetSg -> SpeciesP -> Determiner = \en, b -> + {s = en ; n = Sg ; b = b} ; + + mkDeterminerPl : DetPl -> SpeciesP -> Determiner = \alla, b -> + {s = table {_ => table {_ => alla}} ; n = Pl ; b = b} ; + + detSgInvar : Str -> DetSg = \varje -> table {_ => table {_ => varje}} ; + +-- A large class of determiners can be built from a gender-dependent table. + + mkDeterminerSgGender : (Gender => Str) -> SpeciesP -> Determiner = \en -> + mkDeterminerSg (table {g => table {_ => en ! g}}) ; + +-- Here are some examples. We are in fact doing some ad hoc morphology here, +-- instead of importing the lexicon. + + varjeDet = mkDeterminerSg (detSgInvar "varje") IndefP ; + allaDet = mkDeterminerPl "alla" IndefP ; + enDet = mkDeterminerSgGender artIndef IndefP ; + + flestaDet = mkDeterminerPl ["de flesta"] IndefP ; + vilkenDet = mkDeterminerSgGender + (table {Utr => "vilken" ; Neutr => "vilket"}) IndefP ; + vilkaDet = mkDeterminerPl "vilka" IndefP ; + + vilkDet : Number -> Determiner = \n -> case n of { + Sg => vilkenDet ; + Pl => vilkaDet + } ; + + någDet : Number -> Determiner = \n -> case n of { + Sg => mkDeterminerSgGender + (table {Utr => "någon" ; Neutr => "något"}) IndefP ; + Pl => mkDeterminerPl "några" IndefP + } ; + + +-- Genitives of noun phrases can be used like determiners, to build noun phrases. +-- The number argument makes the difference between "min bil" - "mina bilar". + + npGenDet : Number -> NounPhrase -> CommNounPhrase -> NounPhrase = + \n,huset,vin -> { + s = \\c => case n of { + Sg => huset.s ! PGen (ASg vin.g) ++ + vin.s ! Sg ! DefP Indef ! npCase c ; + Pl => huset.s ! PGen APl ++ + vin.s ! Pl ! DefP Indef ! npCase c + } ; + g = vin.g ; + n = n + } ; + +-- *Bare plural noun phrases* like "män", "goda vänner", are built without a +-- determiner word. + + plurDet : CommNounPhrase -> NounPhrase = \cn -> + {s = \\c => cn.s ! Pl ! IndefP ! npCase c ; + g = cn.g ; + n = Pl + } ; + +-- Definite phrases in Swedish are special, since determiner may be absent +-- depending on if the noun is complex: "bilen" - "den nya bilen". + + denDet : CommNounPhrase -> NounPhrase = \cn -> + detNounPhrase + (mkDeterminerSgGender (table {g => artDef ! cn.p ! ASg g}) (DefP Def)) cn ; + deDet : CommNounPhrase -> NounPhrase = \cn -> + detNounPhrase (mkDeterminerPl (artDef ! cn.p ! APl) (DefP Def)) cn ; + +-- It is useful to have macros for indefinite and definite, singular and plural +-- noun-phrase-like syncategorematic expressions. + + indefNounPhrase : Number -> CommNounPhrase -> NounPhrase = \n,hus -> case n of { + Sg => detNounPhrase enDet hus ; + Pl => plurDet hus + } ; + + defNounPhrase : Number -> CommNounPhrase -> NounPhrase = \n,hus -> case n of { + Sg => denDet hus ; + Pl => deDet hus + } ; + + indefNoun : Number -> CommNounPhrase -> Str = \n,man -> case n of { + Sg => artIndef ! man.g ++ man.s ! Sg ! IndefP ! Nom ; + Pl => man.s ! Pl ! IndefP ! Nom + } ; + +--2 Adjectives +--3 Simple adjectives +-- +-- A special type of adjectives just having positive forms (for semantic reasons) +-- is useful, e.g. "finsk", "trekantig". + + Adjective : Type = {s : AdjFormPos => Case => Str} ; + + extAdjective : Adj -> Adjective = \adj -> + {s = table {f => table {c => adj.s ! AF (Posit f) c}}} ; + +-- Coercions between the compound gen-num type and gender and number: + + gNum : Gender -> Number -> GenNum = \g,n -> + case n of {Sg => ASg g ; Pl => APl} ; + + genGN : GenNum -> Gender = \gn -> + case gn of {ASg g => g ; _ => Utr} ; + numGN : GenNum -> Number = \gn -> + case gn of {ASg _ => Sg ; APl => Pl} ; + +--3 Adjective phrases +-- +-- An adjective phrase may contain a complement, e.g. "yngre än Rolf". +-- Then it is used as postfix in modification, e.g. "en man yngre än Rolf". + + IsPostfixAdj = Bool ; + + AdjPhrase : Type = Adjective ** {p : IsPostfixAdj} ; + +-- Simple adjectives are not postfix: + + adj2adjPhrase : Adjective -> AdjPhrase = \ny -> ny ** {p = False} ; + +--3 Comparison adjectives + +-- We take comparison adjectives directly from +-- the lexicon, which has full adjectives: + + AdjDegr = Adj ; + +-- Each of the comparison forms has a characteristic use: +-- +-- Positive forms are used alone, as adjectival phrases ("ung"). + + positAdjPhrase : AdjDegr -> AdjPhrase = \ung -> + {s = table {a => \\c => ung.s ! AF (Posit a) c} ; + p = False + } ; + +-- Comparative forms are used with an object of comparison, as +-- adjectival phrases ("yngre än Rolf"). + + comparAdjPhrase : AdjDegr -> NounPhrase -> AdjPhrase = \yngre,rolf -> + {s = \\_, c => yngre.s ! AF Compar Nom ++ "än" ++ rolf.s ! mkNPForm c ; + p = True + } ; + +-- Superlative forms are used with a modified noun, picking out the +-- maximal representative of a domain ("den yngste mannen"). + + superlNounPhrase : AdjDegr -> CommNounPhrase -> NounPhrase = \yngst,man -> + {s = \\c => let {gn = gNum man.g Sg} in + artDef ! True ! gn ++ + yngst.s ! AF (Super SupWeak) Nom ++ + man.s ! Sg ! DefP Def ! npCase c ; + g = man.g ; + n = Sg + } ; + +-- Moreover, superlatives can be used alone as adjectival phrases +-- ("yngst", "den yngste" - in free variation). +-- N.B. the former is only permitted in predicative position. + + superlAdjPhrase : AdjDegr -> AdjPhrase = \ung -> + {s = \\a,c => variants { + --- artDef ! True ! gn ++ yngst.s ! AF (Super SupWeak) c + ung.s ! AF (Super SupStrong) c + } ; + p = False + } ; + +--3 Two-place adjectives +-- +-- A two-place adjective is an adjective with a preposition used before +-- the complement. (Rem. $Preposition = Str$). + + AdjCompl = Adjective ** {s2 : Preposition} ; + + complAdj : AdjCompl -> NounPhrase -> AdjPhrase = \förtjust,dig -> + {s = \\a,c => förtjust.s ! a ! c ++ förtjust.s2 ++ dig.s ! PAcc ; + p = True + } ; + + +--3 Modification of common nouns +-- +-- The two main functions of adjective are in predication ("Johan är ung") +-- and in modification ("en ung man"). Predication will be defined +-- later, in the chapter on verbs. + + modCommNounPhrase : AdjPhrase -> CommNounPhrase -> CommNounPhrase = \God,Nybil -> + {s = \\n, b, c => + let { + god = God.s ! mkAdjForm (unSpeciesAdjP b) n Nybil.g Nybil.x ! Nom ; + nybil = Nybil.s ! n ! b ! c + } in + preOrPost God.p nybil god ; + g = Nybil.g ; + x = Nybil.x ; + p = True} ; + +-- A special case is modification of a noun that has not yet been modified. +-- But it is simply a special case. + + modCommNoun : Adjective -> CommNoun -> CommNounPhrase = \god,bil -> + modCommNounPhrase (adj2adjPhrase god) (n2n bil) ; + +-- We have used a straightforward +-- method building adjective forms from simple parameters. + + mkAdjForm : Species -> Number -> Gender -> Sex -> AdjFormPos = \b,n,g,x -> + case of { + => Strong (ASg g) ; + => Strong APl ; + => Weak (AxSg x) ; ---- add masc! + => Weak AxPl + } ; + + +--2 Function expressions + +-- A function expression is a common noun together with the +-- preposition prefixed to its argument ("mor till x"). +-- The type is analogous to two-place adjectives and transitive verbs. + + Function = CommNoun ** {s2 : Preposition} ; + + mkFun : CommNoun -> Preposition -> Function = \f,p -> + f ** {s2 = p} ; + +-- The application of a function gives, in the first place, a common noun: +-- "mor/mödrar till Johan". From this, other rules of the resource grammar +-- give noun phrases, such as "modern till Johan", "mödrarna till Johan", +-- "mödrarna till Johan och Maria", and "modern till Johan och Maria" (the +-- latter two corresponding to distributive and collective functions, +-- respectively). Semantics will eventually tell when each +-- of the readings is meaningful. + + appFunComm : Function -> NounPhrase -> CommNounPhrase = \värde,x -> + noun2CommNounPhrase + {s = \\n,b => table { + Gen => nonExist ; + _ => värde.s ! n ! b ! Nom ++ värde.s2 ++ x.s ! PAcc + } ; + g = värde.g ; + x = värde.x + } ; + +-- It is possible to use a function word as a common noun; the semantics is +-- often existential or indexical. + + funAsCommNounPhrase : Function -> CommNounPhrase = + noun2CommNounPhrase ; + +-- The following is an aggregate corresponding to the original function application +-- producing "Johans mor" and "modern till Johan". It does not appear in the +-- resource grammar API any longer. + + appFun : Bool -> Function -> NounPhrase -> NounPhrase = \coll,värde,x -> + let {n = x.n ; nf = if_then_else Number coll Sg n} in + variants { + defNounPhrase nf (appFunComm värde x) ; + npGenDet nf x (noun2CommNounPhrase värde) + } ; + + + +--2 Verbs + +-- Although the Swedish lexicon has full verb inflection, +-- we have limited this first version of the resource syntax to +-- verbs in present tense. Their mode can be infinitive, imperative, and indicative. + + +--3 Verb phrases +-- +-- Verb phrases are discontinuous: the parts of a verb phrase are +-- (s) an inflected verb, (s2) verb adverbials (such as negation), and +-- (s3) complement. This discontinuity is needed in sentence formation +-- to account for word order variations. + + VerbPhrase : Type = Verb ** {s2 : Str ; s3 : Gender => Number => Str} ; + +-- A simple verb can be made into a verb phrase with an empty complement. +-- There are two versions, depending on if we want to negate the verb. +-- N.B. negation is *not* a function applicable to a verb phrase, since +-- double negations with "inte" are not grammatical. + + predVerb : Bool -> Verb -> VerbPhrase = \b,se -> + se ** { + s2 = negation b ; + s3 = \\_,_ => [] + } ; + + negation : Bool -> Str = \b -> if_then_else Str b [] "inte" ; + +-- Sometimes we want to extract the verb part of a verb phrase. + + verbOfPhrase : VerbPhrase -> Verb = \v -> {s = v.s} ; + +-- Verb phrases can also be formed from adjectives ("är snäll"), +-- common nouns ("är en man"), and noun phrases ("är den yngste mannen"). +-- The third rule is overgenerating: "är varje man" has to be ruled out +-- on semantic grounds. + + predAdjective : Bool -> Adjective -> VerbPhrase = \b,arg -> + verbVara ** { + s2 = negation b ; + s3 = \\g,n => arg.s ! mkAdjForm Indef n g NoMasc ! Nom + } ; + + predCommNoun : Bool -> CommNounPhrase -> VerbPhrase = \b,man -> + verbVara ** { + s2 = negation b ; + s3 = \\_,n => indefNoun n man + } ; + + predNounPhrase : Bool -> NounPhrase -> VerbPhrase = \b,john -> + verbVara ** { + s2 = negation b ; + s3 = \\_,_ => john.s ! PNom + } ; + +--3 Transitive verbs +-- +-- Transitive verbs are verbs with a preposition for the complement, +-- in analogy with two-place adjectives and functions. +-- One might prefer to use the term "2-place verb", since +-- "transitive" traditionally means that the inherent preposition is empty. +-- Such a verb is one with a *direct object*. + + TransVerb : Type = Verb ** {s2 : Preposition} ; + + mkTransVerb : Verb -> Preposition -> TransVerb = \v,p -> + v ** {s2 = p} ; + + mkDirectVerb : Verb -> TransVerb = \v -> + mkTransVerb v nullPrep ; + + nullPrep : Preposition = [] ; + + extTransVerb : Verbum -> Preposition -> TransVerb = + \v -> mkTransVerb (extVerb Act v) ; + +-- The rule for using transitive verbs is the complementization rule: + + complTransVerb : Bool -> TransVerb -> NounPhrase -> VerbPhrase = \b,se,dig -> + {s = se.s ; s2 = negation b ; s3 = \\_,_ => se.s2 ++ dig.s ! PAcc} ; + +--2 Adverbials +-- +-- Adverbials that modify verb phrases are either post- or pre-verbal. +-- As a rule of thumb, simple adverbials ("bra","alltid") are pre-verbal, +-- but this is not always the case ("här" is post-verbal). + + Adverb : Type = SS ** {isPost : Bool} ; + + advPre : Str -> Adverb = \alltid -> ss alltid ** {isPost = False} ; + advPost : Str -> Adverb = \bra -> ss bra ** {isPost = True} ; + + adVerbPhrase : VerbPhrase -> Adverb -> VerbPhrase = \spelar, bra -> + let {postp = bra.isPost} in + { + --- this unfortunately generates VP#2 ::= VP#2 + s = spelar.s ; + s2 = (if_then_else Str postp [] bra.s) ++ spelar.s2 ; + s3 = \\g,n => spelar.s3 ! g ! n ++ (if_then_else Str postp bra.s []) + } ; + +-- Adverbials are typically generated by prefixing prepositions. +-- The rule for creating locative noun phrases by the preposition "i" +-- is a little shaky: "i Sverige" but "på Island". + + prepPhrase : Preposition -> NounPhrase -> Adverb = \i,huset -> + advPost (i ++ huset.s ! PAcc) ; + + locativeNounPhrase : NounPhrase -> Adverb = + prepPhrase "i" ; + +-- This is a source of the "mannen med teleskopen" ambiguity, and may produce +-- strange things, like "bilar alltid" (while "bilar idag" is OK). +-- Semantics will have to make finer distinctions among adverbials. + + advCommNounPhrase : CommNounPhrase -> Adverb -> CommNounPhrase = \bil,idag -> + {s = \\n, b, c => bil.s ! n ! b ! c ++ idag.s ; + g = bil.g ; + x = bil.x ; + p = bil.p} ; + + +--2 Sentences +-- +-- Sentences depend on a *word order parameter* selecting between main clause, +-- inverted, and subordinate clause. + +param + Order = Main | Inv | Sub ; + +oper + Sentence : Type = SS1 Order ; + +-- This is the traditional $S -> NP VP$ rule. It takes care of both +-- word order and agreement. + + predVerbPhrase : NounPhrase -> VerbPhrase -> Sentence = + \Jag, serdiginte -> + let { + jag = Jag.s ! PNom ; + ser = serdiginte.s ! Indicat ; + dig = serdiginte.s3 ! Jag.g ! Jag.n ; + inte = serdiginte.s2 + } in + {s = table { + Main => jag ++ ser ++ inte ++ dig ; + Inv => ser ++ jag ++ inte ++ dig ; + Sub => jag ++ inte ++ ser ++ dig + } + } ; + +-- This is a macro for simultaneous predication and complementation. + + predTransVerb : Bool -> NounPhrase -> TransVerb -> NounPhrase -> Sentence = + \b,jag,ser,dig -> predVerbPhrase jag (complTransVerb b ser dig) ; + +--3 Sentence-complement verbs +-- +-- Sentence-complement verbs take sentences as complements. + + SentenceVerb : Type = Verb ; + + complSentVerb : Bool -> SentenceVerb -> Sentence -> VerbPhrase = \b,se,duler -> + {s = se.s ; s2 = negation b ; s3 = \\_,_ => optStr "att" ++ duler.s ! Main} ; + + + +--2 Sentences missing noun phrases +-- +-- This is one instance of Gazdar's *slash categories*, corresponding to his +-- $S/NP$. +-- We cannot have - nor would we want to have - a productive slash-category former. +-- Perhaps a handful more will be needed. +-- +-- Notice that the slash category has the same relation to sentences as +-- transitive verbs have to verbs: it's like a *sentence taking a complement*. + + SentenceSlashNounPhrase : Type = Sentence ** {s2 : Preposition} ; + + slashTransVerb : Bool -> NounPhrase -> TransVerb -> SentenceSlashNounPhrase = + \b, Jag, se -> + let { + jag = Jag.s ! PNom ; + ser = se.s ! Indicat ; + inte = negation b + } in + {s = table { + Main => jag ++ ser ++ inte ; + Inv => ser ++ jag ++ inte ; + Sub => jag ++ inte ++ ser + } ; + s2 = se.s2 + } ; + + +--2 Relative pronouns and relative clauses +-- +-- Relative pronouns can be nominative, accusative, or genitive, and +-- they depend on gender and number just like adjectives. +-- Moreover they may or may not carry their own genders: for instance, +-- "som" just transmits the gender of a noun ("tal som är primt"), whereas +-- "vars efterföljare" is $Utrum$ independently of the noun +-- ("tal vars efterföljare är prim"). +-- This variation is expressed by the $RelGender$ type. + + RelPron : Type = {s : RelCase => GenNum => Str ; g : RelGender} ; + +param + RelGender = RNoGen | RG Gender ; + +-- The following functions are selectors for relative-specific parameters. + +oper + -- this will be needed in "tal som är jämnt" / "tal vars efterföljare är jämn" + mkGenderRel : RelGender -> Gender -> Gender = \rg,g -> case rg of { + RG gen => gen ; + _ => g + } ; + + relCase : RelCase -> Case = \c -> case c of { + RGen => Gen ; + _ => Nom + } ; + +-- The simplest relative pronoun has no gender of its own. As accusative variant, +-- it has the omission of the pronoun ("mannen (som) jag ser"). + + identRelPron : RelPron = + {s = table { + RNom => \\_ => "som" ; + RAcc => \\_ => variants {"som" ; []} ; + RGen => \\_ => "vars" ; + RPrep => pronVilken + } ; + g = RNoGen + } ; + +-- Composite relative pronouns have the same variation as function +-- applications ("efterföljaren till vilket" - "vars efterföljare"). + + funRelPron : Function -> RelPron -> RelPron = \värde,vilken -> + {s = \\c,gn => + variants { + vilken.s ! RGen ! gn ++ värde.s ! numGN gn ! Indef ! relCase c ; + värde.s ! numGN gn ! Def ! Nom ++ värde.s2 ++ vilken.s ! RPrep ! gn + } ; + g = RG värde.g + } ; + +-- Relative clauses can be formed from both verb phrases ("som sover") and +-- slash expressions ("som jag ser"). The latter has moreover the variation +-- as for the place of the preposition ("som jag talar om" - "om vilken jag talar"). + + RelClause : Type = {s : GenNum => Str} ; + + relVerbPhrase : RelPron -> VerbPhrase -> RelClause = \som,sover -> + {s = \\gn => + som.s ! RNom ! gn ++ sover.s2 ++ sover.s ! Indicat ++ + sover.s3 ! mkGenderRel som.g (genGN gn) ! numGN gn + } ; + + relSlash : RelPron -> SentenceSlashNounPhrase -> RelClause = \som,jagTalar -> + {s = \\gn => + let {jagtalar = jagTalar.s ! Sub ; om = jagTalar.s2} in + variants { + som.s ! RAcc ! gn ++ jagtalar ++ om ; + om ++ som.s ! RPrep ! gn ++ jagtalar + } + } ; + +-- A 'degenerate' relative clause is the one often used in mathematics, e.g. +-- "tal x sådant att x är primt". + + relSuch : Sentence -> RelClause = \A -> + {s = \\g => pronSådan ! g ++ "att" ++ A.s ! Sub} ; + +-- The main use of relative clauses is to modify common nouns. +-- The result is a common noun, out of which noun phrases can be formed +-- by determiners. + + modRelClause : CommNounPhrase -> RelClause -> CommNounPhrase = \man,somsover -> + {s = \\n,b,c => man.s ! n ! b ! c ++ somsover.s ! gNum man.g n ; + g = man.g ; + x = man.x ; + p = False + } ; + +-- N.B. we do not get the determinative pronoun +-- construction "den man som sover" in this way, but only "mannen som sover". +-- Thus we need an extra rule: + + detRelClause : Number -> CommNounPhrase -> RelClause -> NounPhrase = + \n,man,somsover -> + {s = \\c => let {gn = gNum man.g n} in + artDef ! True ! gn ++ + man.s ! n ! DefP Indef ! npCase c ++ somsover.s ! gn ; + g = man.g ; + n = n + } ; + + +--2 Interrogative pronouns +-- +-- If relative pronouns are adjective-like, interrogative pronouns are +-- noun-phrase-like. Actually we can use the very same type! + + IntPron : Type = NounPhrase ; + +-- In analogy with relative pronouns, we have a rule for applying a function +-- to a relative pronoun to create a new one. We can reuse the rule applying +-- functions to noun phrases! + + funIntPron : Function -> IntPron -> IntPron = + appFun False ; + +-- There is a variety of simple interrogative pronouns: +-- "vilken bil", "vem", "vad". + + nounIntPron : Number -> CommNounPhrase -> IntPron = \n -> + detNounPhrase (vilkDet n) ; + + intPronWho : Number -> IntPron = \num -> { + s = table { + PGen _ => "vems" ; + _ => "vem" + } ; + g = Utr ; + n = num + } ; + + intPronWhat : Number -> IntPron = \num -> { + s = table { + PGen _ => nonExist ; --- + _ => "vad" + } ; + n = num ; + g = Neutr + } ; + +--2 Utterances + +-- By utterances we mean whole phrases, such as +-- 'can be used as moves in a language game': indicatives, questions, imperative, +-- and one-word utterances. The rules are far from complete. +-- +-- N.B. we have not included rules for texts, which we find we cannot say much +-- about on this level. In semantically rich GF grammars, texts, dialogues, etc, +-- will of course play an important role as categories not reducible to utterances. +-- An example is proof texts, whose semantics show a dependence between premises +-- and conclusions. Another example is intersentential anaphora. + + Utterance = SS ; + + indicUtt : Sentence -> Utterance = \x -> postfixSS "." (defaultSentence x) ; + interrogUtt : Question -> Utterance = \x -> postfixSS "?" (defaultQuestion x) ; + + +--2 Questions +-- +-- Questions are either direct ("vem tog bollen") or indirect +-- ("vem som tog bollen"). + +param + QuestForm = DirQ | IndirQ ; + +oper + Question = SS1 QuestForm ; + +--3 Yes-no questions +-- +-- Yes-no questions are used both independently ("tog du bollen") +-- and after interrogative adverbials ("varför tog du bollen"). +-- It is economical to handle with these two cases by the one +-- rule, $questVerbPhrase'$. The only difference is if "om" appears +-- in the indirect form. + + questVerbPhrase : NounPhrase -> VerbPhrase -> Question = + questVerbPhrase' False ; + + questVerbPhrase' : Bool -> NounPhrase -> VerbPhrase -> Question = + \adv,du,sover -> + let {dusover = (predVerbPhrase du sover).s} in + {s = table { + DirQ => dusover ! Inv ; + IndirQ => (if_then_else Str adv [] "om") ++ dusover ! Sub + } + } ; + +--3 Wh-questions +-- +-- Wh-questions are of two kinds: ones that are like $NP - VP$ sentences, +-- others that are line $S/NP - NP$ sentences. + + intVerbPhrase : IntPron -> VerbPhrase -> Question = \vem,sover -> + let {vemsom : NounPhrase = + {s = \\c => vem.s ! c ++ "som" ; g = vem.g ; n = vem.n} + } in + {s = table { + DirQ => (predVerbPhrase vem sover).s ! Main ; + IndirQ => (predVerbPhrase vemsom sover).s ! Sub + } + } ; + + intSlash : IntPron -> SentenceSlashNounPhrase -> Question = \Vem, jagTalar -> + let { + vem = Vem.s ! PAcc ; + jagtalar = jagTalar.s ! Sub ; + talarjag = jagTalar.s ! Inv ; + om = jagTalar.s2 + } in + {s = table { + DirQ => variants { + vem ++ talarjag ++ om ; + om ++ vem ++ talarjag + } ; + IndirQ => variants { + vem ++ jagtalar ++ om ; + om ++ vem ++ jagtalar + } + } + } ; + +--3 Interrogative adverbials +-- +-- These adverbials will be defined in the lexicon: they include +-- "när", "var", "hur", "varför", etc, which are all invariant one-word +-- expressions. In addition, they can be formed by adding prepositions +-- to interrogative pronouns, in the same way as adverbials are formed +-- from noun phrases. N.B. we rely on record subtyping when ignoring the +-- position component. + + IntAdverb = SS ; + + prepIntAdverb : Preposition -> IntPron -> IntAdverb = + prepPhrase ; + +-- A question adverbial can be applied to anything, and whether this makes +-- sense is a semantic question. + + questAdverbial : IntAdverb -> NounPhrase -> VerbPhrase -> Question = + \hur, du, mår -> + {s = \\q => hur.s ++ (questVerbPhrase' True du mår).s ! q} ; + + +--2 Imperatives +-- +-- We only consider second-person imperatives. + + Imperative = SS1 Number ; + + imperVerbPhrase : VerbPhrase -> Imperative = \titta -> + {s = \\n => titta.s ! Imperat ++ titta.s2 ++ titta.s3 ! Utr ! n} ; + + imperUtterance : Number -> Imperative -> Utterance = \n,I -> + ss (I.s ! n ++ "!") ; + + +--2 Coordination +-- +-- Coordination is to some extent orthogonal to the rest of syntax, and +-- has been treated in a generic way in the module $CO$ in the file +-- $coordination.gf$. The overall structure is independent of category, +-- but there can be differences in parameter dependencies. +-- +--3 Conjunctions +-- +-- Coordinated phrases are built by using conjunctions, which are either +-- simple ("och", "eller") or distributed ("både - och", "antingen - eller"). +-- +-- The conjunction has an inherent number, which is used when conjoining +-- noun phrases: "John och Mary är rika" vs. "John eller Mary är rik"; in the +-- case of "eller", the result is however plural if any of the disjuncts is. + + Conjunction = CO.Conjunction ** {n : Number} ; + ConjunctionDistr = CO.ConjunctionDistr ** {n : Number} ; + + +--3 Coordinating sentences +-- +-- We need a category of lists of sentences. It is a discontinuous +-- category, the parts corresponding to 'init' and 'last' segments +-- (rather than 'head' and 'tail', because we have to keep track of the slot between +-- the last two elements of the list). A list has at least two elements. + + ListSentence : Type = {s1,s2 : Order => Str} ; + + twoSentence : (_,_ : Sentence) -> ListSentence = + CO.twoTable Order ; + + consSentence : ListSentence -> Sentence -> ListSentence = + CO.consTable Order CO.comma ; + +-- To coordinate a list of sentences by a simple conjunction, we place +-- it between the last two elements; commas are put in the other slots, +-- e.g. "månen lyser, solen skiner och stjärnorna blinkar". + + conjunctSentence : Conjunction -> ListSentence -> Sentence = + CO.conjunctTable Order ; + + conjunctOrd : Bool -> Conjunction -> CO.ListTable Order -> {s : Order => Str} = + \b,or,xs -> + {s = \\p => xs.s1 ! p ++ or.s ++ xs.s2 ! p} ; + + +-- To coordinate a list of sentences by a distributed conjunction, we place +-- the first part (e.g. "antingen") in front of the first element, the second +-- part ("eller") between the last two elements, and commas in the other slots. +-- For sentences this is really not used. + + conjunctDistrSentence : ConjunctionDistr -> ListSentence -> Sentence = + CO.conjunctDistrTable Order ; + +--3 Coordinating adjective phrases +-- +-- The structure is the same as for sentences. The result is a prefix adjective +-- if and only if all elements are prefix. + + ListAdjPhrase : Type = + {s1,s2 : AdjFormPos => Case => Str ; p : Bool} ; + + twoAdjPhrase : (_,_ : AdjPhrase) -> ListAdjPhrase = \x,y -> + CO.twoTable2 AdjFormPos Case x y ** {p = andB x.p y.p} ; + consAdjPhrase : ListAdjPhrase -> AdjPhrase -> ListAdjPhrase = \xs,x -> + CO.consTable2 AdjFormPos Case CO.comma xs x ** {p = andB xs.p x.p} ; + + conjunctAdjPhrase : Conjunction -> ListAdjPhrase -> AdjPhrase = \c,xs -> + CO.conjunctTable2 AdjFormPos Case c xs ** {p = xs.p} ; + + conjunctDistrAdjPhrase : ConjunctionDistr -> ListAdjPhrase -> AdjPhrase = \c,xs -> + CO.conjunctDistrTable2 AdjFormPos Case c xs ** {p = xs.p} ; + + +--3 Coordinating noun phrases +-- +-- The structure is the same as for sentences. The result is either always plural +-- or plural if any of the components is, depending on the conjunction. +-- The gender is neuter if any of the components is. + + ListNounPhrase : Type = {s1,s2 : NPForm => Str ; g : Gender ; n : Number} ; + + twoNounPhrase : (_,_ : NounPhrase) -> ListNounPhrase = \x,y -> + CO.twoTable NPForm x y ** {n = conjNumber x.n y.n ; g = conjGender x.g y.g} ; + + consNounPhrase : ListNounPhrase -> NounPhrase -> ListNounPhrase = \xs,x -> + CO.consTable NPForm CO.comma xs x ** + {n = conjNumber xs.n x.n ; g = conjGender xs.g x.g} ; + + conjunctNounPhrase : Conjunction -> ListNounPhrase -> NounPhrase = \c,xs -> + CO.conjunctTable NPForm c xs ** {n = conjNumber c.n xs.n ; g = xs.g} ; + + conjunctDistrNounPhrase : ConjunctionDistr -> ListNounPhrase -> NounPhrase = + \c,xs -> + CO.conjunctDistrTable NPForm c xs ** {n = conjNumber c.n xs.n ; g = xs.g} ; + +-- We hve to define a calculus of numbers of genders. For numbers, +-- it is like the conjunction with $Pl$ corresponding to $False$. For genders, +-- $Neutr$ corresponds to $False$. + + conjNumber : Number -> Number -> Number = \m,n -> case of { + => Sg ; + _ => Pl + } ; + + conjGender : Gender -> Gender -> Gender = \m,n -> case of { + => Utr ; + _ => Neutr + } ; + + +--2 Subjunction +-- +-- Subjunctions ("om", "när", etc) +-- are a different way to combine sentences than conjunctions. +-- The main clause can be a sentences, an imperatives, or a question, +-- but the subjoined clause must be a sentence. +-- +-- There are uniformly two variant word orders, e.g. "om du sover kommer björnen" +-- and "björnen kommer om du sover". + + Subjunction = SS ; + + subjunctSentence : Subjunction -> Sentence -> Sentence -> Sentence = \if, A, B -> + let {As = A.s ! Sub} in + {s = table { + Main => variants {if.s ++ As ++ "," ++ B.s ! Inv ; + B.s ! Main ++ "," ++ if.s ++ As} ; + o => B.s ! o ++ "," ++ if.s ++ As + } + } ; + + subjunctImperative : Subjunction -> Sentence -> Imperative -> Imperative = + \if, A, B -> + {s = \\n => subjunctVariants if A (B.s ! n)} ; + + subjunctQuestion : Subjunction -> Sentence -> Question -> Question = \if, A, B -> + {s = \\q => subjunctVariants if A (B.s ! q)} ; + + subjunctVariants : Subjunction -> Sentence -> Str -> Str = \if,A,B -> + let {As = A.s ! Sub} in + variants {if.s ++ As ++ "," ++ B ; B ++ "," ++ if.s ++ As} ; + +--2 One-word utterances +-- +-- An utterance can consist of one phrase of almost any category, +-- the limiting case being one-word utterances. These +-- utterances are often (but not always) in what can be called the +-- default form of a category, e.g. the nominative. +-- This list is far from exhaustive. + + useNounPhrase : NounPhrase -> Utterance = \john -> + postfixSS "." (defaultNounPhrase john) ; + useCommonNounPhrase : Number -> CommNounPhrase -> Utterance = \n,car -> + useNounPhrase (indefNounPhrase n car) ; + +-- Here are some default forms. + + defaultNounPhrase : NounPhrase -> SS = \john -> + ss (john.s ! PNom) ; + + defaultQuestion : Question -> SS = \whoareyou -> + ss (whoareyou.s ! DirQ) ; + + defaultSentence : Sentence -> Utterance = \x -> ss (x.s ! Main) ; +} ; diff --git a/grammars/resource/swedish/TestSwe.gf b/grammars/resource/swedish/TestSwe.gf new file mode 100644 index 000000000..063119b56 --- /dev/null +++ b/grammars/resource/swedish/TestSwe.gf @@ -0,0 +1,35 @@ +concrete TestSwe of TestAbs = ResSwe ** open Syntax in { + +flags startcat=Phr ; lexer=text ; parser=chart ; unlexer=text ; + +-- a random sample from the lexicon + +lin + Big = stor_25 ; + Small = liten_1146 ; + Old = gammal_16 ; + Young = ung_29 ; + Man = extCommNoun Masc man_1144 ; + Woman = extCommNoun NoMasc (sApa "kvinn") ; + Car = extCommNoun NoMasc (sBil "bil") ; + House = extCommNoun NoMasc (sHus "hus") ; + Light = extCommNoun NoMasc (sHus "ljus") ; + Walk = extVerb Act gå_1174 ; + Run = extVerb Act (vFinna "spring" "sprang" "sprung") ; + Love = extTransVerb (vTala "älsk") [] ; + Send = extTransVerb (vTala "skick") [] ; + Wait = extTransVerb (vTala "vänt") "på" ; + Say = extVerb Act (vLeka "säg") ; --- works in present tense... + Prove = extVerb Act (vTala "bevis") ; + SwitchOn = extTransVerb (vVända "tän") [] ; + SwitchOff = extTransVerb (vLeka "släck") [] ; + + Mother = mkFun (extCommNoun NoMasc mor_1) "till" ; + Uncle = mkFun (extCommNoun Masc farbror_8) "till" ; + + Always = advPre "alltid" ; + Well = advPost "bra" ; + + John = mkProperName "Johan" Utr Masc ; + Mary = mkProperName "Maria" Utr NoMasc ; +} ; diff --git a/grammars/resource/swedish/Types.gf b/grammars/resource/swedish/Types.gf new file mode 100644 index 000000000..21ddfcfc7 --- /dev/null +++ b/grammars/resource/swedish/Types.gf @@ -0,0 +1,150 @@ +--1 Swedish Word Classes and Morphological Parameters +-- +-- This is a resource module for Swedish morphology, defining the +-- morphological parameters and word classes of Swedish. It is aimed +-- to be complete w.r.t. the description of word forms. +-- However, it does not include those parameters that are not needed for +-- analysing individual words: such parameters are defined in syntax modules. +-- +-- This GF grammar was obtained from the functional morphology file TypesSw.hs +-- semi-automatically. The GF inflection engine obtained was obtained automatically. + +resource Types = open Prelude in { + +-- + +--2 Enumerated parameter types +-- +-- These types are the ones found in school grammars. +-- Their parameter values are atomic. + +param + Gender = Utr | Neutr ; + Number = Sg | Pl ; + Species = Indef | Def ; + Case = Nom | Gen ; + Sex = NoMasc | Masc ; + Mode = Ind | Cnj ; + Voice = Act | Pass ; + Degree = Pos | Comp | Sup ; + Person = P1 | P2 | P3 ; + +--2 Word classes and hierarchical parameter types +-- +-- Real parameter types (i.e. ones on which words and phrases depend) +-- are mostly hierarchical. The alternative would be cross-products of +-- simple parameters, but this would usually overgenerate. +-- + +--3 Substantives +-- +-- Substantives (= common nouns) have a parameter of type SubstForm. + +param SubstForm = SF Number Species Case ; + +-- Substantives moreover have an inherent gender. + +oper Subst : Type = {s : SubstForm => Str ; h1 : Gender} ; + +--3 Adjectives +-- +-- Adjectives are a very complex class, and the full table has as many as +-- 18 different forms. The major division is between the comparison degrees; +-- the comparative has only the 2 case forms, whereas the positive has 12 forms. + +param + AdjForm = AF AdjFormGrad Case ; + +-- The positive strong forms depend on gender: "en stor bil" - "ett stort hus". +-- But the weak forms depend on sex: "den stora bilen" - "den store mannen". +-- The plural never makes a gender-sex distinction. + + GenNum = ASg Gender | APl ; + SexNum = AxSg Sex | AxPl ; + + AdjFormPos = Strong GenNum | Weak SexNum ; + AdjFormSup = SupStrong | SupWeak ; + + AdjFormGrad = + Posit AdjFormPos + | Compar + | Super AdjFormSup ; + +oper + Adj : Type = {s : AdjForm => Str} ; + +--3 Verbs +-- +-- Verbs have 9 finite forms and as many as 18 infinite forms; the large number +-- of the latter comes from adjectives. + +oper Verbum : Type = {s : VerbForm => Str} ; + +param + VFin = + Pres Mode Voice + | Pret Mode Voice + | Imper ; --- no passive + + VInf = + Inf Voice + | Supin Voice + | PtPres Case + | PtPret AdjFormPos Case ; + + VerbForm = + VF VFin + | VI VInf ; + +-- However, the syntax only needs a simplified verb category, with +-- present tense only. Such a verb can be extracted from the full verb, +-- and a choice can be made between an active and a passive (deponent) verb. + +param + VForm = Infinit | Indicat | Imperat ; + +oper + Verb : Type = SS1 VForm ; + + extVerb : Voice -> Verbum -> Verb = \v,verb -> {s = table { + Infinit => verb.s ! VI (Inf v) ; + Indicat => verb.s ! VF (Pres Ind v) ; + Imperat => verb.s ! VF Imper --- no passive in Verbum + }} ; + +--3 Other open classes +-- +-- Proper names, adverbs (Adv having comparison forms and AdvIn not having them), +-- and interjections are the remaining open classes. + +oper + PNm : Type = {s : Case => Str ; h1 : Gender} ; + Adv : Type = {s : Degree => Str} ; + AdvInv : Type = {s : Str} ; + Interj : Type = {s : Str} ; + +--3 Closed classes +-- +-- The rest of the Swedish word classes are closed, i.e. not extensible by new +-- lexical entries. Thus we don't have to know how to build them, but only +-- how to use them, i.e. which parameters they have. +-- +-- The most important distinction is between proper-name-like pronouns and +-- adjective-like pronouns, which are inflected in completely different parameters. + +param + NPForm = PNom | PAcc | PGen GenNum ; + AdjPronForm = APron GenNum Case ; + AuxVerbForm = AuxInf | AuxPres | AuxPret | AuxSup ; + +oper + ProPN : Type = {s : NPForm => Str ; h1 : Gender ; h2 : Number ; h3 : Person} ; + ProAdj : Type = {s : AdjPronForm => Str} ; + Prep : Type = {s : Str} ; + Conjunct : Type = {s : Str} ; + Subjunct : Type = {s : Str} ; + Art : Type = {s : GenNum => Str} ; + Part : Type = {s : Str} ; + Infin : Type = {s : Str} ; + VAux : Type = {s : AuxVerbForm => Str} ; +} diff --git a/src/GF.hs b/src/GF.hs new file mode 100644 index 000000000..a75f4ee0c --- /dev/null +++ b/src/GF.hs @@ -0,0 +1,78 @@ +module Main where + +import Operations +import UseIO +import Option +import IOGrammar +import ShellState +import Shell +import SubShell +import PShell +import JGF +import UTF8 + +import Today (today) +import Arch +import System (getArgs) + +-- AR 19/4/2000 -- 11/11/2001 + +main :: IO () +main = do + xs <- getArgs + let (os,fs) = getOptions "-" xs + java = oElem forJava os + putStrLn $ if java then encodeUTF8 welcomeMsg else welcomeMsg + st <- case fs of + f:_ -> useIOE emptyShellState (shellStateFromFiles os emptyShellState f) + _ -> return emptyShellState + if null fs then return () else putCPU + if java then sessionLineJ st else do + gfInteract (initHState st) + return () + +gfInteract :: HState -> IO HState +gfInteract st@(env,_) = do + -- putStrFlush "> " M.F 25/01-02 prompt moved to Arch. + (s,cs) <- getCommandLines + case ifImpure cs of + + -- these are the three impure commands + Just (ICQuit,_) -> do + putStrLn "See you." + return st + Just (ICExecuteHistory file,_) -> do + ss <- readFileIf file + let co = pCommandLines ss + st' <- execLinesH s co st + gfInteract st' + Just (ICEarlierCommand i,_) -> do + let line = earlierCommandH st i + co = pCommandLine $ words line + st' <- execLinesH line [co] st -- s would not work in execLinesH + gfInteract st' + Just (ICEditSession,os) -> + editSession (addOptions os opts) env >> gfInteract st +{- ----- + Just (ICTranslateSession,os) -> + translateSession (addOptions os opts) env >> gfInteract st +-} + -- this is a normal command sequence + _ -> do + st' <- execLinesH s cs st + gfInteract st' + where + opts = globalOptions env + +welcomeMsg = + "Welcome to " ++ authorMsg ++++ welcomeArch ++ "\n\nType 'h' for help." + +authorMsg = unlines [ + "Grammatical Framework, Version 2.0-- (incomplete functionality)", +--- "Compiled March 26, 2003", + "Compiled " ++ today, + "Copyright (c) Markus Forsberg, Thomas Hallgren, Kristofer Johannisson,", + "Janna Khegai, Peter Ljunglöf, Petri Mäenpää, and Aarne Ranta", + "1998-2003, under GNU General Public License (GPL)", + "Bug reports to aarne@cs.chalmers.se" + ] diff --git a/src/GF/API.hs b/src/GF/API.hs new file mode 100644 index 000000000..d2a60d24c --- /dev/null +++ b/src/GF/API.hs @@ -0,0 +1,267 @@ +module API where + +import qualified AbsGF as GF +import qualified AbsGFC as A +import qualified Rename as R +import GetTree +import GFC +import Values + +-----import GetGrammar +-----import Compile +import IOGrammar +import Linear +import Parsing +import Morphology +import PPrCF +import CFIdent +import PGrammar +import Randomized (mkRandomTree) +import Zipper + +import MMacros +import TypeCheck +import CMacros + +import Option +import Custom +import ShellState +import Linear +import GFC +import qualified Grammar as G +import PrGrammar +import qualified Compute as Co +import qualified Ident as I +import qualified GrammarToCanon as GC +import qualified CanonToGrammar as CG + +import Editing + +----import GrammarToXML + +----import GrammarToMGrammar as M + +import Arch (myStdGen) + +import UTF8 +import Operations +import UseIO + +import List (nub) +import Monad (liftM) +import System (system) + +-- Application Programmer's Interface to GF; also used by Shell. AR 10/11/2001 + +type GFGrammar = StateGrammar +type GFCat = CFCat +type Ident = I.Ident + +-- these are enough for many simple applications + +{- ----- +file2grammar :: FilePath -> IO GFGrammar +file2grammar = do + egr <- appIOE $ optFile2grammar (iOpts [beSilent]) + err putStrLn return egr +-} + +linearize :: GFGrammar -> Tree -> String +linearize sgr = err id id . optLinearizeTree opts sgr where + opts = addOption firstLin $ stateOptions sgr + +linearizeToAll :: [GFGrammar] -> Tree -> [String] +linearizeToAll grs t = [linearize gr t | gr <- grs] + +parse :: GFGrammar -> CFCat -> String -> [Tree] +parse sgr cat = errVal [] . parseString noOptions sgr cat + +parseAny :: [GFGrammar] -> CFCat -> String -> [Tree] +parseAny grs cat s = concat [parse gr cat s | gr <- grs] + +translate :: GFGrammar -> GFGrammar -> CFCat -> String -> [String] +translate ig og cat = map (linearize og) . parse ig cat + +translateToAll :: GFGrammar -> [GFGrammar] -> CFCat -> String -> [String] +translateToAll ig ogs cat = concat . map (linearizeToAll ogs) . parse ig cat + +translateFromAny :: [GFGrammar] -> GFGrammar -> CFCat -> String -> [String] +translateFromAny igs og cat s = concat [translate ig og cat s | ig <- igs] + +translateBetweenAll :: [GFGrammar] -> CFCat -> String -> [String] +translateBetweenAll grs cat = concat . map (linearizeToAll grs) . parseAny grs cat + +homonyms :: GFGrammar -> CFCat -> Tree -> [Tree] +homonyms gr cat = nub . parse gr cat . linearize gr + +hasAmbiguousLin :: GFGrammar -> CFCat -> Tree -> Bool +hasAmbiguousLin gr cat t = case (homonyms gr cat t) of + _:_:_ -> True + _ -> False + +{- ---- +-- returns printname if one exists; othewrise linearizes with metas +printOrLin :: GFGrammar -> Fun -> String +printOrLin gr = printOrLinearize (stateGrammarST gr) + +-- reads a syntax file and writes it in a format wanted +transformGrammarFile :: Options -> FilePath -> IO String +transformGrammarFile opts file = do + sy <- useIOE GF.emptySyntax $ getSyntax opts file + return $ optPrintSyntax opts sy +-} + +-- then stg for customizable and internal use + +{- ----- +optFile2grammar :: Options -> FilePath -> IOE GFGrammar +optFile2grammar os f = do + gr <- ioeErr $ compileModule os f + return $ grammar2stateGrammar gr + +optFile2grammarE :: Options -> FilePath -> IOE GFGrammar +optFile2grammarE = optFile2grammar +-} + +string2treeInState :: GFGrammar -> String -> State -> Err Tree +string2treeInState gr s st = do + let metas = allMetas st + t <- pTerm s + annotate (grammar gr) $ qualifTerm (absId gr) $ refreshMetas metas t + +string2srcTerm :: G.SourceGrammar -> I.Ident -> String -> Err G.Term +string2srcTerm gr m s = do + t <- pTerm s + R.renameSourceTerm gr m t + +randomTreesIO :: Options -> GFGrammar -> Int -> IO [Tree] +randomTreesIO opts gr n = do + gen <- myStdGen mx + t <- err (\s -> putStrLnFlush s >> return []) (return . singleton) $ + mkRandomTree gen mx g cat + ts <- if n==1 then return [] else randomTreesIO opts gr (n-1) + return $ t ++ ts + where + cat = firstAbsCat opts gr + g = grammar gr + mx = optIntOrN opts flagDepth 41 + +speechGenerate :: Options -> String -> IO () +speechGenerate opts str = do + let lan = maybe "" (" --language" +++) $ getOptVal opts speechLanguage + system ("echo" +++ "\"" ++ str ++ "\" | festival --tts" ++ lan) + return () + +optLinearizeTreeVal :: Options -> GFGrammar -> Tree -> String +optLinearizeTreeVal opts gr = err id id . optLinearizeTree opts gr + +optLinearizeTree :: Options -> GFGrammar -> Tree -> Err String +optLinearizeTree opts gr t + | oElem showRecord opts = liftM prt $ linearizeNoMark g c t + | otherwise = return $ linTree2string g c t + where + g = grammar gr + c = cncId gr + +{- ---- + untoksl . lin where + gr = concreteOf (stateGrammarST sgr) + lin -- options mutually exclusive, with priority: struct, rec, table, one + | oElem showStruct opts = markedLinString True gr . tree2loc + | oElem showRecord opts = err id prt . linTerm gr + | oElem tableLin opts = err id (concatMap prLinTable) . allLinsAsStrs gr + | oElem firstLin opts = unlines . map sstr . take 1 . allLinStrings gr + | otherwise = unlines . map sstr . optIntOrAll opts flagNumber . allLinStrings gr + untoks = customOrDefault opts' useUntokenizer customUntokenizer sgr + opts' = addOptions opts $ stateOptions sgr + untoksl = unlines . map untoks . lines +-} + +{- +optLinearizeArgForm :: Options -> StateGrammar -> [Term] -> Term -> String +optLinearizeArgForm opts sgr fs ts0 = untoksl $ lin ts where + gr = concreteOf (stateGrammarST sgr) + ts = annotateTrm sgr ts0 + ms = map (renameTrm (lookupConcrete gr)) fs + lin -- options mutually exclusive, with priority: struct, rec, table + | oElem tableLin opts = err id (concatMap prLinTable) . allLinsForForms gr ms + | otherwise = err id (unlines . map sstr . tkStrs . concat) . allLinsForForms gr ms + tkStrs = concat . map snd . concat . map snd + untoks = customOrDefault opts' useUntokenizer customUntokenizer sgr + opts' = addOptions opts $ stateOptions sgr + untoksl = unlines . map untoks . lines +-} + +optParseArg :: Options -> GFGrammar -> String -> [Tree] +optParseArg opts gr = err (const []) id . optParseArgErr opts gr + +optParseArgErr :: Options -> GFGrammar -> String -> Err [Tree] +optParseArgErr opts gr = liftM fst . optParseArgErrMsg opts gr + +optParseArgErrMsg :: Options -> GFGrammar -> String -> Err ([Tree],String) +optParseArgErrMsg opts gr s = + let cat = firstCatOpts opts gr + in parseStringMsg opts gr cat s + +-- analyses word by word +morphoAnalyse :: Options -> GFGrammar -> String -> String +morphoAnalyse opts gr + | oElem beShort opts = morphoTextShort mo + | otherwise = morphoText mo + where + mo = morpho gr + +{- +prExpXML :: StateGrammar -> Term -> [String] +prExpXML gr = prElementX . term2elemx (stateAbstract gr) + +prMultiGrammar :: Options -> ShellState -> String +prMultiGrammar opts = M.showMGrammar (oElem optimizeCanon opts) +-} +-- access to customizable commands + +optPrintGrammar :: Options -> StateGrammar -> String +optPrintGrammar opts = customOrDefault opts grammarPrinter customGrammarPrinter + +optPrintSyntax :: Options -> GF.Grammar -> String +optPrintSyntax opts = customOrDefault opts grammarPrinter customSyntaxPrinter + +{- ---- +optPrintTree :: Options -> GFGrammar -> Tree -> String +optPrintTree opts = customOrDefault opts grammarPrinter customTermPrinter + +-- look for string command (-filter=x) +optStringCommand :: Options -> GFGrammar -> String -> String +optStringCommand opts g = + optIntOrAll opts flagLength . + customOrDefault opts filterString customStringCommand g + +optTreeCommand :: Options -> GFGrammar -> Tree -> [Tree] +optTreeCommand opts st = + optIntOrAll opts flagNumber . + customOrDefault opts termCommand customTermCommand st +-} + +{- +-- wraps term in a function and optionally computes the result + +wrapByFun :: Options -> StateGrammar -> Ident -> Term -> Term +wrapByFun opts g f t = + if oElem doCompute opts + then err (const t) id $ computeAbsTerm (stateAbstract g) (appCons f [t]) + else appCons f [t] + +optTransfer :: Options -> StateGrammar -> Term -> Term +optTransfer opts g = case getOptVal opts transferFun of + Just f -> wrapByFun (addOption doCompute opts) g (string2id f) + _ -> id +-} +optTokenizer :: Options -> GFGrammar -> String -> String +optTokenizer opts gr = show . customOrDefault opts useTokenizer customTokenizer gr + +-- performs UTF8 if the language name is not *U.gf ; should be by gr option --- +optEncodeUTF8 :: Language -> GFGrammar -> String -> String +optEncodeUTF8 lang gr = case reverse (prLanguage lang) of + 'U':_ -> id + _ -> encodeUTF8 + diff --git a/src/GF/API/IOGrammar.hs b/src/GF/API/IOGrammar.hs new file mode 100644 index 000000000..a00ef18a6 --- /dev/null +++ b/src/GF/API/IOGrammar.hs @@ -0,0 +1,42 @@ +module IOGrammar where + +import Option +import Abstract +import qualified GFC +import PGrammar +import TypeCheck +import Compile +import ShellState + +import Operations +import UseIO +import Arch + +import Monad (liftM) + +-- for reading grammars and terms from strings and files + +--- a heuristic way of renaming constants is used +string2absTerm :: String -> String -> Term +string2absTerm m = renameTermIn m . pTrm + +renameTermIn :: String -> Term -> Term +renameTermIn m = refreshMetas [] . rename [] where + rename vs t = case t of + Abs x b -> Abs x (rename (x:vs) b) + Vr c -> if elem c vs then t else Q (zIdent m) c + App f a -> App (rename vs f) (rename vs a) + _ -> t + +string2annotTree :: GFC.CanonGrammar -> Ident -> String -> Err Tree +string2annotTree gr m = annotate gr . string2absTerm (prt m) ---- prt + +----string2paramList :: ConcreteST -> String -> [Term] +---string2paramList st = map (renameTrm (lookupConcrete st) . patt2term) . pPattList + +shellStateFromFiles :: Options -> ShellState -> FilePath -> IOE ShellState +shellStateFromFiles opts st file = do + let osb = addOptions (options [beVerbose, emitCode]) opts --- + grts <- compileModule osb st file + ioeErr $ updateShellState opts st grts + --- liftM (changeModTimes rts) $ grammar2shellState opts gr diff --git a/src/GF/CF/CF.hs b/src/GF/CF/CF.hs new file mode 100644 index 000000000..0cff68b97 --- /dev/null +++ b/src/GF/CF/CF.hs @@ -0,0 +1,180 @@ +module CF where + +import Operations +import Str +import AbsGFC +import GFC +import CFIdent +import List (nub,nubBy) +import Char (isUpper, isLower, toUpper, toLower) + +-- context-free grammars. AR 15/12/1999 -- 30/3/2000 -- 2/6/2001 -- 3/12/2001 + +-- CF grammar data types + +-- abstract type CF. +-- Invariant: each category has all its rules grouped with it +-- also: the list is never empty (the category is just missing then) +newtype CF = CF ([(CFCat,[CFRule])], CFPredef) +type CFRule = (CFFun, (CFCat, [CFItem])) + +-- CFPredef is a hack for variable symbols and literals; normally = const [] +data CFItem = CFTerm RegExp | CFNonterm CFCat deriving (Eq, Ord,Show) + +newtype CFTree = CFTree (CFFun,(CFCat, [CFTree])) deriving (Eq, Show) + +type CFPredef = CFTok -> [(CFCat, CFFun)] -- recognize literals, variables, etc + +-- Wadler style + return information +type CFParser = [CFTok] -> ([(CFTree,[CFTok])],String) + +cfParseResults :: ([(CFTree,[CFTok])],String) -> [CFTree] +cfParseResults rs = [b | (b,[]) <- fst rs] + +-- terminals are regular expressions on words; to be completed to full regexp +data RegExp = + RegAlts [CFWord] -- list of alternative words + | RegSpec CFTok -- special token + deriving (Eq, Ord, Show) + +type CFWord = String + +-- the above types should be kept abstract, and the following functions used + +-- to construct CF grammars + +emptyCF :: CF +emptyCF = CF ([], emptyCFPredef) + +emptyCFPredef :: CFPredef +emptyCFPredef = const [] + +rules2CF :: [CFRule] -> CF +rules2CF rs = CF (groupCFRules rs, emptyCFPredef) + +groupCFRules :: [CFRule] -> [(CFCat,[CFRule])] +groupCFRules = foldr ins [] where + ins rule crs = case crs of + (c,r) : rs | compatCF c cat -> (c,rule:r) : rs + cr : rs -> cr : ins rule rs + _ -> [(cat,[rule])] + where + cat = valCatCF rule + +-- to construct rules + +-- make a rule from a single token without constituents +atomCFRule :: CFCat -> CFFun -> CFTok -> CFRule +atomCFRule c f s = (f, (c, [atomCFTerm s])) + +-- usual terminal +atomCFTerm :: CFTok -> CFItem +atomCFTerm = CFTerm . atomRegExp + +atomRegExp :: CFTok -> RegExp +atomRegExp t = case t of + TS s -> RegAlts [s] + _ -> RegSpec t + +-- terminal consisting of alternatives +altsCFTerm :: [String] -> CFItem +altsCFTerm = CFTerm . RegAlts + + +-- to construct trees + +-- make a tree without constituents +atomCFTree :: CFCat -> CFFun -> CFTree +atomCFTree c f = buildCFTree c f [] + +-- make a tree with constituents. +buildCFTree :: CFCat -> CFFun -> [CFTree] -> CFTree +buildCFTree c f trees = CFTree (f,(c,trees)) + +{- ---- +cfMeta0 :: CFTree +cfMeta0 = atomCFTree uCFCat metaCFFun + +-- used in happy +litCFTree :: String -> CFTree --- Maybe CFTree +litCFTree s = maybe cfMeta0 id $ do + (c,f) <- getCFLiteral s + return $ buildCFTree c f [] +-} + +-- to decide whether a token matches a terminal item + +matchCFTerm :: CFItem -> CFTok -> Bool +matchCFTerm (CFTerm t) s = satRegExp t s +matchCFTerm _ _ = False + +satRegExp :: RegExp -> CFTok -> Bool +satRegExp r t = case (r,t) of + (RegAlts tt, TS s) -> elem s tt + (RegAlts tt, TC s) -> or [elem s' tt | s' <- caseUpperOrLower s] + (RegSpec x, _) -> t == x --- + _ -> False + where + caseUpperOrLower s = case s of + c:cs | isUpper c -> [s, toLower c : cs] + c:cs | isLower c -> [s, toUpper c : cs] + _ -> [s] + +-- to analyse a CF grammar + +catsOfCF :: CF -> [CFCat] +catsOfCF (CF (rr,_)) = map fst rr + +rulesOfCF :: CF -> [CFRule] +rulesOfCF (CF (rr,_)) = concatMap snd rr + +ruleGroupsOfCF :: CF -> [(CFCat,[CFRule])] +ruleGroupsOfCF (CF (rr,_)) = rr + +rulesForCFCat :: CF -> CFCat -> [CFRule] +rulesForCFCat (CF (rr,_)) cat = maybe [] id $ lookup cat rr + +valCatCF :: CFRule -> CFCat +valCatCF (_,(c,_)) = c + +valItemsCF :: CFRule -> [CFItem] +valItemsCF (_,(_,i)) = i + +valFunCF :: CFRule -> CFFun +valFunCF (f,(_,_)) = f + +startCat :: CF -> CFCat +startCat (CF (rr,_)) = fst (head rr) --- hardly useful + +predefOfCF :: CF -> CFPredef +predefOfCF (CF (_,f)) = f + +appCFPredef :: CF -> CFTok -> [(CFCat, CFFun)] +appCFPredef = ($) . predefOfCF + +valCFItem :: CFItem -> Either RegExp CFCat +valCFItem (CFTerm r) = Left r +valCFItem (CFNonterm nt) = Right nt + +cfTokens :: CF -> [CFWord] +cfTokens cf = nub $ concat $ [ wordsOfRegExp i | r <- rulesOfCF cf, + CFTerm i <- valItemsCF r] + +wordsOfRegExp :: RegExp -> [CFWord] +wordsOfRegExp (RegAlts tt) = tt +wordsOfRegExp _ = [] + +forCFItem :: CFTok -> CFRule -> Bool +forCFItem a (_,(_, CFTerm r : _)) = satRegExp r a +forCFItem _ _ = False + +isCircularCF :: CFRule -> Bool +isCircularCF (_,(c', CFNonterm c:[])) = compatCF c' c +isCircularCF _ = False +--- we should make a test of circular chains, too + +-- coercion to the older predef cf type + +predefRules :: CFPredef -> CFTok -> [CFRule] +predefRules pre s = [atomCFRule c f s | (c,f) <- pre s] + diff --git a/src/GF/CF/CFIdent.hs b/src/GF/CF/CFIdent.hs new file mode 100644 index 000000000..d9c451adb --- /dev/null +++ b/src/GF/CF/CFIdent.hs @@ -0,0 +1,151 @@ +module CFIdent where + +import Operations +import GFC +import Ident +import AbsGFC +import PrGrammar +import Str +import Char (toLower, toUpper) + +-- symbols (categories, functions) for context-free grammars. + +-- these types should be abstract + +data CFTok = + TS String -- normal strings + | TC String -- strings that are ambiguous between upper or lower case + | TL String -- string literals + | TI Int -- integer literals + | TV Ident -- variables + | TM Int String -- metavariables; the integer identifies it + deriving (Eq, Ord, Show) + +newtype CFCat = CFCat (CIdent,Label) deriving (Eq, Ord, Show) + +tS, tC, tL, tI, tV, tM :: String -> CFTok +tS = TS +tC = TC +tL = TL +tI = TI . read +tV = TV . identC +tM = TM 0 + +tInt :: Int -> CFTok +tInt = TI + +prCFTok :: CFTok -> String +prCFTok t = case t of + TS s -> s + TC s -> s + TL s -> s + TI i -> show i + TV x -> prt x + TM i _ -> "?" --- + +-- to build trees: the Atom contains a GF function, Cn | Meta | Vr | Literal +newtype CFFun = CFFun (Atom, Profile) deriving (Eq,Show) + +type Profile = [([[Int]],[Int])] + + +-- the following functions should be used instead of constructors + +-- to construct CF functions + +mkCFFun :: Atom -> CFFun +mkCFFun t = CFFun (t,[]) + +{- ---- +getCFLiteral :: String -> Maybe (CFCat, CFFun) +getCFLiteral s = case lookupLiteral' s of + Ok (c, lit) -> Just (cat2CFCat c, mkCFFun lit) + _ -> Nothing +-} + +varCFFun :: Ident -> CFFun +varCFFun = mkCFFun . AV + +consCFFun :: CIdent -> CFFun +consCFFun = mkCFFun . AC + +{- ---- +string2CFFun :: String -> CFFun +string2CFFun = consCFFun . Ident +-} + +cfFun2String :: CFFun -> String +cfFun2String (CFFun (f,_)) = prt f + +cfFun2Profile :: CFFun -> Profile +cfFun2Profile (CFFun (_,p)) = p + +{- ---- +strPro2cfFun :: String -> Profile -> CFFun +strPro2cfFun str p = (CFFun (AC (Ident str), p)) +-} + +metaCFFun :: CFFun +metaCFFun = mkCFFun $ AM 0 + +-- to construct CF categories + +-- belongs elsewhere +mkCIdent :: String -> String -> CIdent +mkCIdent m c = CIQ (identC m) (identC c) + +ident2CFCat :: CIdent -> Ident -> CFCat +ident2CFCat mc d = CFCat (mc, L d) + +-- standard way of making cf cat: label s +string2CFCat :: String -> String -> CFCat +string2CFCat m c = ident2CFCat (mkCIdent m c) (identC "s") + +idents2CFCat :: Ident -> Ident -> CFCat +idents2CFCat m c = ident2CFCat (CIQ m c) (identC "s") + +catVarCF :: CFCat +catVarCF = ident2CFCat (mkCIdent "_" "#Var") (identC "_") ---- + +{- ---- +uCFCat :: CFCat +uCFCat = cat2CFCat uCat +-} + +moduleOfCFCat :: CFCat -> Ident +moduleOfCFCat (CFCat (CIQ m _, _)) = m + +-- the opposite direction +cfCat2Cat :: CFCat -> CIdent +cfCat2Cat (CFCat (s,_)) = s + + +-- to construct CF tokens + +string2CFTok :: String -> CFTok +string2CFTok = tS + +str2cftoks :: Str -> [CFTok] +str2cftoks = map tS . words . sstr + +-- decide if two token lists look the same (in parser postprocessing) + +compatToks :: [CFTok] -> [CFTok] -> Bool +compatToks ts us = and [compatTok t u | (t,u) <- zip ts us] + +compatTok t u = any (`elem` (alts t)) (alts u) where + alts u = case u of + TC (c:s) -> [toLower c : s, toUpper c : s] + _ -> [prCFTok u] + +-- decide if two CFFuns have the same function head (profiles may differ) + +compatCFFun :: CFFun -> CFFun -> Bool +compatCFFun (CFFun (f,_)) (CFFun (g,_)) = f == g + +-- decide whether two categories match +-- the modifiers can be from different modules, but on the same extension +-- path, so there is no clash, and they can be safely ignored --- +compatCF :: CFCat -> CFCat -> Bool +----compatCF = (==) +compatCF (CFCat (CIQ _ c, l)) (CFCat (CIQ _ c', l')) = c==c' && l==l' diff --git a/src/GF/CF/CanonToCF.hs b/src/GF/CF/CanonToCF.hs new file mode 100644 index 000000000..6f7dc6d6b --- /dev/null +++ b/src/GF/CF/CanonToCF.hs @@ -0,0 +1,157 @@ +module CanonToCF where + +import Operations +import Option +import Ident +import AbsGFC +import GFC +import PrGrammar +import CMacros +import qualified Modules as M +import CF +import CFIdent +import List (nub) +import Monad + +-- AR 27/1/2000 -- 3/12/2001 -- 8/6/2003 + +-- The main function: for a given cnc module m, build the CF grammar with all the +-- rules coming from modules that m extends. The categories are qualified by +-- the abstract module name a that m is of. + +canon2cf :: Options -> CanonGrammar -> Ident -> Err CF +canon2cf opts gr c = do + let ms = M.allExtends gr c + a <- M.abstractOfConcrete gr c + let cncs = [m | (n, M.ModMod m) <- M.modules gr, elem n ms] + let mms = [(a, tree2list (M.jments m)) | m <- cncs] + rules0 <- liftM concat $ mapM (uncurry (cnc2cfCond opts)) mms + let rules = filter (not . isCircularCF) rules0 ---- temporarily here + let predef = const [] ---- mkCFPredef cfcats + return $ CF (groupCFRules rules, predef) + +cnc2cfCond :: Options -> Ident -> [(Ident,Info)] -> Err [CFRule] +cnc2cfCond opts m gr = + liftM concat $ + mapM lin2cf [(m,fun,cat,args,lin) | (fun, CncFun cat args lin _) <- gr] + +type IFun = Ident +type ICat = CIdent + +-- all CF rules corresponding to a linearization rule +lin2cf :: (Ident, IFun, ICat, [ArgVar], Term) -> Err [CFRule] +lin2cf (m,fun,cat,args,lin) = errIn ("building CF rule for" +++ prt fun) $ do + rhss0 <- allLinValues lin -- :: [(Label, [([Patt],Term)])] + rhss1 <- mapM (mkCFItems m) (concat rhss0) -- :: [(Label, [[PreCFItem]])] + mapM (mkCfRules m fun cat args) rhss1 >>= return . nub . concat + +-- making sequences of CF items from every branch in a linearization +mkCFItems :: Ident -> (Label, [([Patt],Term)]) -> Err (Label, [[PreCFItem]]) +mkCFItems m (lab,pts) = do + itemss <- mapM (term2CFItems m) (map snd pts) + return (lab, concat itemss) ---- combinations? (test!) + +-- making CF rules from sequences of CF items +mkCfRules :: Ident -> IFun -> ICat -> [ArgVar] -> (Label, [[PreCFItem]]) -> Err [CFRule] +mkCfRules m fun cat args (lab, itss) = mapM mkOneRule itss + where + mkOneRule its = do + let nonterms = zip [0..] [(pos,d,v) | PNonterm _ pos d v <- its] + profile = mkProfile nonterms + cfcat = CFCat (redirectIdent m cat,lab) + cffun = CFFun (AC (CIQ m fun), profile) + cfits = map precf2cf its + return (cffun,(cfcat,cfits)) + mkProfile nonterms = map mkOne args + where + mkOne (A c i) = mkOne (AB c 0 i) + mkOne (AB _ b i) = (map mkB [0..b-1], [k | (k,(j,_,True)) <- nonterms, j==i]) + where + mkB j = [p | (p,(k, LV l,False)) <- nonterms, k == i, l == j] + +-- intermediate data structure of CFItems with information for profiles +data PreCFItem = + PTerm RegExp -- like ordinary Terminal + | PNonterm CIdent Integer Label Bool -- cat, position, part/bind, whether arg + deriving Eq + +precf2cf :: PreCFItem -> CFItem +precf2cf (PTerm r) = CFTerm r +precf2cf (PNonterm cm _ (L c) True) = CFNonterm (ident2CFCat cm c) +precf2cf (PNonterm _ _ _ False) = CFNonterm catVarCF + + +-- the main job in translating linearization rules into sequences of cf items +term2CFItems :: Ident -> Term -> Err [[PreCFItem]] +term2CFItems m t = errIn "forming cf items" $ case t of + S c _ -> t2c c + + T _ cc -> do + its <- mapM t2c [t | Cas _ t <- cc] + tryMkCFTerm (concat its) + + C t1 t2 -> do + its1 <- t2c t1 + its2 <- t2c t2 + return [x ++ y | x <- its1, y <- its2] + + FV ts -> do + its <- mapM t2c ts + tryMkCFTerm (concat its) + + P arg s -> extrR arg s + + K (KS s) -> return [[PTerm (RegAlts [s]) | not (null s)]] + + E -> return [[]] + + K (KP d vs) -> do + let its = [PTerm (RegAlts [s]) | s <- d] + let itss = [[PTerm (RegAlts [s]) | s <- t] | Var t _ <- vs] + tryMkCFTerm (its : itss) + + _ -> prtBad "no cf for" t ---- + + where + + t2c = term2CFItems m + + -- optimize the number of rules by a factorization + tryMkCFTerm :: [[PreCFItem]] -> Err [[PreCFItem]] + tryMkCFTerm ii@(its:itss) | all (\x -> length x == length its) itss = + case mapM mkOne (counterparts ii) of + Ok tt -> return [tt] + _ -> return ii + where + mkOne cfits = case mapM mkOneTerm cfits of + Ok tt -> return $ PTerm (RegAlts (concat (nub tt))) + _ -> mkOneNonTerm cfits + mkOneTerm (PTerm (RegAlts t)) = return t + mkOneTerm _ = Bad "" + mkOneNonTerm (n@(PNonterm _ _ _ _) : cc) = + if all (== n) cc + then return n + else Bad "" + mkOneNonTerm _ = Bad "" + counterparts ll = [map (!! i) ll | i <- [0..length (head ll) - 1]] + tryMkCFTerm itss = return itss + + extrR arg lab = case (arg,lab) of + (Arg (A cat pos), l@(L _)) -> return [[PNonterm (CIQ m cat) pos l True]] + (Arg (A cat pos), l@(LV _)) -> return [[PNonterm (CIQ m cat) pos l False]] + (Arg (AB cat pos b), l@(L _)) -> return [[PNonterm (CIQ m cat) pos l True]] + (Arg (AB cat pos b), l@(LV _)) -> return [[PNonterm (CIQ m cat) pos l False]] + ---- ?? + _ -> prtBad "cannot extract record field from" arg + +{- Proof + 1 @ 4 catVarCF :: CFCat +PNonterm CIdent Integer Label Bool -- cat, position, part/bind, whether arg + + +mkCFPredef :: [CFCat] -> CFPredef +mkCFPredef cats s = + [(cat, metaCFFun) | TM _ _ <- [s], cat <- cats] ++ + [(cat, varCFFun x) | TV x <- [s], cat <- cats] ++ + [(cat, lit) | TL t <- [s], Just (cat,lit) <- [getCFLiteral t]] ++ + [(cat, lit) | TI i <- [s], Just (cat,lit) <- [getCFLiteral (show i)]] --- +-} diff --git a/src/GF/CF/ChartParser.hs b/src/GF/CF/ChartParser.hs new file mode 100644 index 000000000..09d538244 --- /dev/null +++ b/src/GF/CF/ChartParser.hs @@ -0,0 +1,166 @@ + +module ChartParser (chartParser) where + +import Operations +import CF +import CFIdent +import PPrCF (prCFItem) + +import OrdSet +import OrdMap2 + +import List (groupBy) + +type Token = CFTok +type Name = CFFun +type Category = CFItem +type Grammar = ([Production], Terminal) +type Production = (Name, Category, [Category]) +type Terminal = Token -> [(Category, Maybe Name)] +type GParser = Grammar -> Category -> [Token] -> ([ParseTree],String) +data ParseTree = Node Name Category [ParseTree] | Leaf Token + +-------------------------------------------------- +-- converting between GF parsing and CFG parsing + +buildParser :: GParser -> CF -> CFCat -> CFParser +buildParser gparser cf = parse + where + parse = \start input -> + let parse2 = parse' (CFNonterm start) input in + ([(parse2tree t, []) | t <- fst parse2], snd parse2) + parse' = gparser (cf2grammar cf) + +cf2grammar :: CF -> Grammar +cf2grammar cf = (productions, terminal) + where + productions = [ (name, CFNonterm cat, rhs) | + (name, (cat, rhs)) <- cfRules ] + terminal tok = [ (CFNonterm cat, Just name) | + (cat, name) <- cfPredef tok ] + ++ + [ (item, Nothing) | + item <- elems rhsItems, + matchCFTerm item tok ] + cfRules = rulesOfCF cf + cfPredef = predefOfCF cf + rhsItems :: Set Category + rhsItems = union [ makeSet rhs | (_, (_, rhs)) <- cfRules ] + +parse2tree :: ParseTree -> CFTree +parse2tree (Node name (CFNonterm cat) trees) = CFTree (name, (cat, trees')) + where + trees' = [ parse2tree t | t@(Node _ _ _) <- trees ] -- ignore leafs + +maybeNode :: Maybe Name -> Category -> Token -> ParseTree +maybeNode (Just name) cat tok = Node name cat [Leaf tok] +maybeNode Nothing _ tok = Leaf tok + + +-------------------------------------------------- +-- chart parsing (bottom up kilbury-like) + +type Chart = [CState] +type CState = Set Edge +type Edge = (Int, Category, [Category]) +type Passive = (Int, Int, Category) + +chartParser :: CF -> CFCat -> CFParser +chartParser = buildParser chartParser0 + +chartParser0 :: GParser +chartParser0 (productions, terminal) = cparse + where + emptyCats :: Set Category + emptyCats = empties emptySet + where + empties cats | cats==cats' = cats + | otherwise = empties cats' + where cats' = makeSet [ cat | (_, cat, rhs) <- productions, + all (`elemSet` cats) rhs ] + + grammarMap :: Map Category [(Name, [Category])] + grammarMap = makeMapWith (++) + [ (cat, [(name,rhs)]) | (name, cat, rhs) <- productions ] + + leftCornerMap :: Map Category (Set (Category,[Category])) + leftCornerMap = makeMapWith (<++>) [ (a, unitSet (b, bs)) | + (_, b, abs) <- productions, + (a : bs) <- removeNullable abs ] + + removeNullable :: [Category] -> [[Category]] + removeNullable [] = [] + removeNullable cats@(cat:cats') + | cat `elemSet` emptyCats = cats : removeNullable cats' + | otherwise = [cats] + + cparse :: Category -> [Token] -> ([ParseTree], String) + cparse start input = case lookup (0, length input, start) edgeTrees of + Just trees -> (trees, "Chart:" ++++ prChart passiveEdges) + Nothing -> ([], "Chart:" ++++ prChart passiveEdges) + where + finalChart :: Chart + finalChart = map buildState initialChart + + finalChartMap :: [Map Category (Set Edge)] + finalChartMap = map stateMap finalChart + + stateMap :: CState -> Map Category (Set Edge) + stateMap state = makeMapWith (<++>) [ (a, unitSet (i,b,bs)) | + (i, b, a:bs) <- elems state ] + + initialChart :: Chart + initialChart = emptySet : map initialState (zip [0..] input) + where initialState (j, sym) = makeSet [ (j, cat, []) | + (cat, _) <- terminal sym ] + + buildState :: CState -> CState + buildState = limit more + where more (j, a, []) = ordSet [ (j, b, bs) | + (b, bs) <- elems (lookupWith emptySet leftCornerMap a) ] + <++> + lookupWith emptySet (finalChartMap !! j) a + more (j, b, a:bs) = ordSet [ (j, b, bs) | + a `elemSet` emptyCats ] + + passiveEdges :: [Passive] + passiveEdges = [ (i, j, cat) | + (j, state) <- zip [0..] finalChart, + (i, cat, []) <- elems state ] + ++ + [ (i, i, cat) | + i <- [0 .. length input], + cat <- elems emptyCats ] + + edgeTrees :: [ (Passive, [ParseTree]) ] + edgeTrees = [ (edge, treesFor edge) | edge <- passiveEdges ] + + edgeTreesMap :: Map (Int, Category) [(Int, [ParseTree])] + edgeTreesMap = makeMapWith (++) [ ((i,c), [(j,trees)]) | + ((i,j,c), trees) <- edgeTrees ] + + treesFor :: Passive -> [ParseTree] + treesFor (i, j, cat) = [ Node name cat trees | + (name, rhs) <- lookupWith [] grammarMap cat, + trees <- children rhs i j ] + ++ + [ maybeNode name cat tok | + i == j-1, + let tok = input !! i, + Just name <- [lookup cat (terminal tok)] ] + + children :: [Category] -> Int -> Int -> [[ParseTree]] + children [] i k = [ [] | i == k ] + children (c:cs) i k = [ tree : rest | + i <= k, + (j, trees) <- lookupWith [] edgeTreesMap (i,c), + rest <- children cs j k, + tree <- trees ] + + +-- AR 10/12/2002 + +prChart :: [Passive] -> String +prChart = unlines . map (unwords . map prOne) . positions where + prOne (i,j,it) = show i ++ "-" ++ show j ++ "-" ++ prCFItem it + positions = groupBy (\ (i,_,_) (j,_,_) -> i == j) diff --git a/src/GF/CF/PPrCF.hs b/src/GF/CF/PPrCF.hs new file mode 100644 index 000000000..ff4b64e66 --- /dev/null +++ b/src/GF/CF/PPrCF.hs @@ -0,0 +1,59 @@ +module PPrCF where + +import Operations +import CF +import CFIdent +import AbsGFC +import PrGrammar + +-- printing and parsing CF grammars, rules, and trees AR 26/1/2000 -- 9/6/2003 +---- use the Print class instead! + +prCF :: CF -> String +prCF = unlines . (map prCFRule) . rulesOfCF -- hiding the literal recogn function + +prCFTree :: CFTree -> String +prCFTree (CFTree (fun, (_,trees))) = prCFFun fun ++ prs trees where + prs [] = "" + prs ts = " " ++ unwords (map ps ts) + ps t@(CFTree (_,(_,[]))) = prCFTree t + ps t = prParenth (prCFTree t) + +prCFRule :: CFRule -> String +prCFRule (fun,(cat,its)) = + prCFFun fun ++ "." +++ prCFCat cat +++ "::=" +++ + unwords (map prCFItem its) +++ ";" + +prCFFun :: CFFun -> String +prCFFun = prCFFun' True ---- False -- print profiles for debug + +prCFFun' :: Bool -> CFFun -> String +prCFFun' profs (CFFun (t, p)) = prt t ++ pp p where + pp p = if (not profs || normal p) then "" else "_" ++ concat (map show p) + normal p = and [x==y && null b | ((b,x),y) <- zip p (map (:[]) [0..])] + +prCFCat :: CFCat -> String +prCFCat (CFCat (c,l)) = prt c ++ "-" ++ prt l ---- + +prCFItem (CFNonterm c) = prCFCat c +prCFItem (CFTerm a) = prRegExp a + +prRegExp (RegAlts tt) = case tt of + [t] -> prQuotedString t + _ -> prParenth (prTList " | " (map prQuotedString tt)) + +{- ---- +-- rules have an amazingly easy parser, if we use the format +-- fun. C -> item1 item2 ... where unquoted items are treated as cats +-- Actually would be nice to add profiles to this. + +getCFRule :: String -> Maybe CFRule +getCFRule s = getcf (wrds s) where + getcf ww | length ww > 2 && ww !! 2 `elem` ["->", "::="] = + Just (string2CFFun (init fun), (string2CFCat cat, map mkIt its)) where + fun : cat : _ : its = words s + mkIt ('"':w@(_:_)) = atomCFTerm (string2CFTok (init w)) + mkIt w = CFNonterm (string2CFCat w) + getcf _ = Nothing + wrds = takeWhile (/= ";") . words -- to permit semicolon in the end +-} \ No newline at end of file diff --git a/src/GF/CF/Profile.hs b/src/GF/CF/Profile.hs new file mode 100644 index 000000000..6dbb5f85a --- /dev/null +++ b/src/GF/CF/Profile.hs @@ -0,0 +1,95 @@ +module Profile (postParse) where + +import AbsGFC +import GFC +import qualified Ident as I +import CMacros +---import MMacros +import CF +import CFIdent +import PPrCF -- for error msg +import PrGrammar + +import Operations + +import Monad +import List (nub) + + +-- restoring parse trees for discontinuous constituents, bindings, etc. AR 25/1/2001 +-- revised 8/4/2002 for the new profile structure + +postParse :: CFTree -> Err Exp +postParse tree = do + iterm <- errIn "postprocessing initial parse tree" $ tree2term tree + return $ term2trm iterm + +-- an intermediate data structure +data ITerm = ITerm (Atom, BindVs) [ITerm] | IMeta deriving (Eq,Show) +type BindVs = [[I.Ident]] + +-- the job is done in two passes: +-- (1) tree2term: restore constituent order from Profile +-- (2) term2trm: restore Bindings from Binds + +tree2term :: CFTree -> Err ITerm +tree2term (CFTree (cff@(CFFun (fun,pro)), (_,trees))) = case fun of + AM _ -> return IMeta + _ -> do + args <- mapM mkArg pro + binds <- mapM mkBinds pro + return $ ITerm (fun, binds) args + where + mkArg (_,arg) = case arg of + [x] -> do -- one occurrence + trx <- trees !? x + tree2term trx + [] -> return IMeta -- suppression + _ -> do -- reduplication + trees' <- mapM (trees !?) arg + xs1 <- mapM tree2term trees' + xs2 <- checkArity xs1 + unif xs2 + + checkArity xs = if length (nub [length xx | ITerm _ xx <- xs']) > 1 + then Bad "arity error" + else return xs' + where xs' = [t | t@(ITerm _ _) <- xs] + unif [] = return $ IMeta + unif xs@(ITerm fp@(f,_) xx : ts) = do + let hs = [h | ITerm (h,_) _ <- ts] + testErr (all (==f) hs) -- if fails, hs must be nonempty + ("unification expects" +++ prt f +++ "but found" +++ prt (head hs)) + xx' <- mapM unifArg [0 .. length xx - 1] + return $ ITerm fp xx' + where + unifArg i = tryUnif [zz !! i | ITerm _ zz <- xs] + tryUnif xx = case [t | t@(ITerm _ _) <- xx] of + [] -> return IMeta + x:xs -> if all (==x) xs + then return x + else Bad "failed to unify" + + mkBinds (xss,_) = mapM mkBind xss + mkBind xs = do + ts <- mapM (trees !?) xs + let vs = [x | CFTree (CFFun (AV x,_),(_,[])) <- ts] + testErr (length ts == length vs) "non-variable in bound position" + case vs of + [x] -> return x + [] -> return $ I.identC "h_" ---- uBoundVar + y:ys -> do + testErr (all (==y) ys) ("fail to unify bindings of" +++ prt y) + return y + +term2trm :: ITerm -> Exp +term2trm IMeta = EAtom (AM 0) ---- mExp0 +term2trm (ITerm (fun, binds) terms) = + let bterms = zip binds terms + in mkAppAtom fun [mkAbsR xs (term2trm t) | (xs,t) <- bterms] + + --- these are deprecated + where + mkAbsR c e = foldr EAbs e c + mkAppAtom a = mkApp (EAtom a) + mkApp = foldl EApp \ No newline at end of file diff --git a/src/GF/Canon/AbsGFC.hs b/src/GF/Canon/AbsGFC.hs new file mode 100644 index 000000000..361c59d34 --- /dev/null +++ b/src/GF/Canon/AbsGFC.hs @@ -0,0 +1,160 @@ +module AbsGFC where + +import Ident --H + +-- Haskell module generated by the BNF converter, except --H + +-- newtype Ident = Ident String deriving (Eq,Ord,Show) --H +data Canon = + Gr [Module] + deriving (Eq,Ord,Show) + +data Module = + Mod ModType Extend Open [Flag] [Def] + deriving (Eq,Ord,Show) + +data ModType = + MTAbs Ident + | MTCnc Ident Ident + | MTRes Ident + deriving (Eq,Ord,Show) + +data Extend = + Ext Ident + | NoExt + deriving (Eq,Ord,Show) + +data Open = + NoOpens + | Opens [Ident] + deriving (Eq,Ord,Show) + +data Flag = + Flg Ident Ident + deriving (Eq,Ord,Show) + +data Def = + AbsDCat Ident [Decl] [CIdent] + | AbsDFun Ident Exp Exp + | ResDPar Ident [ParDef] + | ResDOper Ident CType Term + | CncDCat Ident CType Term Term + | CncDFun Ident CIdent [ArgVar] Term Term + | AnyDInd Ident Status Ident + deriving (Eq,Ord,Show) + +data ParDef = + ParD Ident [CType] + deriving (Eq,Ord,Show) + +data Status = + Canon + | NonCan + deriving (Eq,Ord,Show) + +data CIdent = + CIQ Ident Ident + deriving (Eq,Ord,Show) + +data Exp = + EApp Exp Exp + | EProd Ident Exp Exp + | EAbs Ident Exp + | EAtom Atom + | EEq [Equation] + deriving (Eq,Ord,Show) + +data Sort = + SType + deriving (Eq,Ord,Show) + +data Equation = + Equ [APatt] Exp + deriving (Eq,Ord,Show) + +data APatt = + APC CIdent [APatt] + | APV Ident + | APS String + | API Integer + | APW + deriving (Eq,Ord,Show) + +data Atom = + AC CIdent + | AD CIdent + | AV Ident + | AM Integer + | AS String + | AI Integer + | AT Sort + deriving (Eq,Ord,Show) + +data Decl = + Decl Ident Exp + deriving (Eq,Ord,Show) + +data CType = + RecType [Labelling] + | Table CType CType + | Cn CIdent + | TStr + deriving (Eq,Ord,Show) + +data Labelling = + Lbg Label CType + deriving (Eq,Ord,Show) + +data Term = + Arg ArgVar + | I CIdent + | Con CIdent [Term] + | LI Ident + | R [Assign] + | P Term Label + | T CType [Case] + | S Term Term + | C Term Term + | FV [Term] + | K Tokn + | E + deriving (Eq,Ord,Show) + +data Tokn = + KS String + | KP [String] [Variant] + deriving (Eq,Ord,Show) + +data Assign = + Ass Label Term + deriving (Eq,Ord,Show) + +data Case = + Cas [Patt] Term + deriving (Eq,Ord,Show) + +data Variant = + Var [String] [String] + deriving (Eq,Ord,Show) + +data Label = + L Ident + | LV Integer + deriving (Eq,Ord,Show) + +data ArgVar = + A Ident Integer + | AB Ident Integer Integer + deriving (Eq,Ord,Show) + +data Patt = + PC CIdent [Patt] + | PV Ident + | PW + | PR [PattAssign] + deriving (Eq,Ord,Show) + +data PattAssign = + PAss Label Patt + deriving (Eq,Ord,Show) + diff --git a/src/GF/Canon/CMacros.hs b/src/GF/Canon/CMacros.hs new file mode 100644 index 000000000..8c1841fcc --- /dev/null +++ b/src/GF/Canon/CMacros.hs @@ -0,0 +1,234 @@ +module CMacros where + +import AbsGFC +import GFC +import qualified Ident as A ---- no need to qualif? 21/9 +import PrGrammar +import Str + +import Operations + +import Char +import Monad + +-- macros for concrete syntax in GFC that do not need lookup in a grammar + +markFocus :: Term -> Term +markFocus = markSubterm "[*" "*]" + +markSubterm :: String -> String -> Term -> Term +markSubterm beg end t = case t of + R rs -> R $ map markField rs + T ty cs -> T ty [Cas p (mark v) | Cas p v <- cs] + _ -> foldr1 C [tK beg, t, tK end] -- t : Str guaranteed? + where + mark = markSubterm beg end + markField lt@(Ass l t) = if isLinLabel l then (Ass l (mark t)) else lt + isLinLabel (L (A.IC s)) = case s of ---- + 's':cs -> all isDigit cs + _ -> False + +tK :: String -> Term +tK = K . KS + +term2patt :: Term -> Err Patt +term2patt trm = case trm of + Con c aa -> do + aa' <- mapM term2patt aa + return (PC c aa') + R r -> do + let (ll,aa) = unzip [(l,a) | Ass l a <- r] + aa' <- mapM term2patt aa + return (PR (map (uncurry PAss) (zip ll aa'))) + LI x -> return $ PV x + _ -> prtBad "no pattern corresponds to term" trm + +patt2term :: Patt -> Term +patt2term p = case p of + PC x ps -> Con x (map patt2term ps) + PV x -> LI x + PW -> anyTerm ---- + PR pas -> R [ Ass lbl (patt2term q) | PAss lbl q <- pas ] + +anyTerm :: Term +anyTerm = LI (A.identC "_") --- should not happen + +matchPatt cs0 trm = term2patt trm >>= match cs0 where + match cs t = + case cs of + Cas ps b :_ | elem t ps -> return b + _:cs' -> match cs' t + [] -> Bad $ "pattern not found for" +++ prt t + +++ "among" ++++ unlines (map prt cs0) ---- debug + +defLinType :: CType +defLinType = RecType [Lbg (L (A.identC "s")) TStr] + +defLindef :: Term +defLindef = R [Ass (L (A.identC "s")) (Arg (A (A.identC "str") 0))] + +strsFromTerm :: Term -> Err [Str] +strsFromTerm t = case t of + K (KS s) -> return [str s] + K (KP d vs) -> return $ [Str [TN d [(s,v) | Var s v <- vs]]] + C s t -> do + s' <- strsFromTerm s + t' <- strsFromTerm t + return [plusStr x y | x <- s', y <- t'] + FV ts -> liftM concat $ mapM strsFromTerm ts + E -> return [str []] + _ -> return [str ("BUG[" ++ prt t ++ "]")] ---- debug +---- _ -> prtBad "cannot get Str from term " t + +-- recursively collect all branches in a table +allInTable :: Term -> [Term] +allInTable t = case t of + T _ ts -> concatMap (\ (Cas _ v) -> allInTable v) ts --- expand ? + _ -> [t] + +-- to gather s-fields; assumes term in normal form, preserves label +allLinFields :: Term -> Err [[(Label,Term)]] +allLinFields trm = case trm of +---- R rs -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good + R rs -> return [[(l,t) | Ass l t <- rs, isLinLabel l]] ---- bad + FV ts -> do + lts <- mapM allLinFields ts + return $ concat lts + _ -> prtBad "fields can only be sought in a record not in" trm + +---- deprecated +isLinLabel l = case l of + L (A.IC ('s':cs)) | all isDigit cs -> True + _ -> False + +-- to gather ultimate cases in a table; preserves pattern list +allCaseValues :: Term -> [([Patt],Term)] +allCaseValues trm = case trm of + T _ cs -> [(p:ps, t) | Cas pp t0 <- cs, p <- pp, (ps,t) <- allCaseValues t0] + _ -> [([],trm)] + +-- to gather all linearizations; assumes normal form, preserves label and args +allLinValues :: Term -> Err [[(Label,[([Patt],Term)])]] +allLinValues trm = do + lts <- allLinFields trm + mapM (mapPairsM (return . allCaseValues)) lts + +redirectIdent n f@(CIQ _ c) = CIQ n c + + +{- ---- to be removed 21/9 +-- to analyse types and terms into eta normal form + +typeForm :: Exp -> Err (Context, Exp, [Exp]) +typeForm e = do + (cont,val) <- getContext e + (cat,args) <- getArgs val + return (cont,cat,args) + +getContext :: Exp -> Err (Context, Exp) +getContext e = case e of + EProd x a b -> do + (g,b') <- getContext b + return ((x,a):g,b') + _ -> return ([],e) + +valAtom :: Exp -> Err Atom +valAtom e = do + (_,val,_) <- typeForm e + case val of + EAtom a -> return a + _ -> prtBad "atom expected instead of" val + +valCat :: Exp -> Err CIdent +valCat e = do + a <- valAtom e + case a of + AC c -> return c + _ -> prtBad "cat expected instead of" a + +termForm :: Exp -> Err ([A.Ident], Exp, [Exp]) +termForm e = do + (cont,val) <- getBinds e + (cat,args) <- getArgs val + return (cont,cat,args) + +getBinds :: Exp -> Err ([A.Ident], Exp) +getBinds e = case e of + EAbs x b -> do + (g,b') <- getBinds b + return (x:g,b') + _ -> return ([],e) + +getArgs :: Exp -> Err (Exp,[Exp]) +getArgs = get [] where + get xs e = case e of + EApp f a -> get (a:xs) f + _ -> return (e, reverse xs) + +-- the inverses of these + +mkProd :: Context -> Exp -> Exp +mkProd c e = foldr (uncurry EProd) e c + +mkApp :: Exp -> [Exp] -> Exp +mkApp = foldl EApp + +mkAppAtom :: Atom -> [Exp] -> Exp +mkAppAtom a = mkApp (EAtom a) + +mkAppCons :: CIdent -> [Exp] -> Exp +mkAppCons c = mkAppAtom $ AC c + +mkType :: Context -> Exp -> [Exp] -> Exp +mkType c e xs = mkProd c $ mkApp e xs + +mkAbs :: Context -> Exp -> Exp +mkAbs c e = foldr EAbs e $ map fst c + +mkTerm :: Context -> Exp -> [Exp] -> Exp +mkTerm c e xs = mkAbs c $ mkApp e xs + +mkAbsR :: [A.Ident] -> Exp -> Exp +mkAbsR c e = foldr EAbs e c + +mkTermR :: [A.Ident] -> Exp -> [Exp] -> Exp +mkTermR c e xs = mkAbsR c $ mkApp e xs + +-- this is used to create heuristic menus +eqCatId :: Cat -> Atom -> Bool +eqCatId (CIQ _ c) b = case b of + AC (CIQ _ d) -> c == d + AD (CIQ _ d) -> c == d + _ -> False + +-- a very weak notion of "compatible value category" +compatCat :: Cat -> Type -> Bool +compatCat c t = case t of + EAtom b -> eqCatId c b + EApp f _ -> compatCat c f + _ -> False + +-- this is the way an atomic category looks as a type + +cat2type :: Cat -> Type +cat2type = EAtom . AC + +compatType :: Type -> Type -> Bool +compatType t = case t of + EAtom (AC c) -> compatCat c + _ -> (t ==) + +type Fun = CIdent +type Cat = CIdent +type Type = Exp + +mkFun, mkCat :: String -> String -> Fun +mkFun m f = CIQ (A.identC m) (A.identC f) +mkCat = mkFun + +mkFunC, mkCatC :: String -> Fun +mkFunC s = let (m,f) = span (/= '.') s in mkFun m (drop 1 f) +mkCatC = mkFunC + +-} + diff --git a/src/GF/Canon/CanonToGrammar.hs b/src/GF/Canon/CanonToGrammar.hs new file mode 100644 index 000000000..550dc37a4 --- /dev/null +++ b/src/GF/Canon/CanonToGrammar.hs @@ -0,0 +1,167 @@ +module CanonToGrammar where + +import AbsGFC +import GFC +import MkGFC +---import CMacros +import qualified Modules as M +import qualified Option as O +import qualified Grammar as G +import qualified Macros as F + +import Ident +import Operations + +import Monad + +-- a decompiler. AR 12/6/2003 + +canon2sourceModule :: CanonModule -> Err G.SourceModule +canon2sourceModule (i,mi) = do + i' <- redIdent i + info' <- case mi of + M.ModMod m -> do + (e,os) <- redExtOpen m + flags <- mapM redFlag $ M.flags m + (abstr,mt) <- case M.mtype m of + M.MTConcrete a -> do + a' <- redIdent a + return (a', M.MTConcrete a') + M.MTAbstract -> return (i',M.MTAbstract) --- c' not needed + M.MTResource -> return (i',M.MTResource) --- c' not needed + defs <- mapMTree redInfo $ M.jments m + return $ M.ModMod $ M.Module mt flags e os defs + _ -> Bad $ "cannot decompile module type" + return (i',info') + where + redExtOpen m = do + e' <- case M.extends m of + Just e -> liftM Just $ redIdent e + _ -> return Nothing + os' <- mapM (\ (M.OSimple i) -> liftM (\i -> M.OQualif i i) (redIdent i)) $ + M.opens m + return (e',os') + +redInfo :: (Ident,Info) -> Err (Ident,G.Info) +redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do + c' <- redIdent c + info' <- case info of + AbsCat cont fs -> do + return $ G.AbsCat (Yes cont) (Yes fs) + AbsFun typ df -> do + return $ G.AbsFun (Yes typ) (Yes df) + + ResPar par -> liftM (G.ResParam . Yes) $ mapM redParam par + + CncCat pty ptr ppr -> do + ty' <- redCType pty + trm' <- redCTerm ptr + ppr' <- redCTerm ppr + return $ G.CncCat (Yes ty') (Yes trm') (Yes ppr') + CncFun (CIQ abstr cat) xx body ppr -> do + xx' <- mapM redArgVar xx + body' <- redCTerm body + ppr' <- redCTerm ppr + return $ G.CncFun Nothing (Yes (F.mkAbs xx' body')) (Yes ppr') + + AnyInd b c -> liftM (G.AnyInd b) $ redIdent c + + return (c',info') + +redQIdent :: CIdent -> Err G.QIdent +redQIdent (CIQ m c) = liftM2 (,) (redIdent m) (redIdent c) + +redIdent :: Ident -> Err Ident +redIdent = return + +redFlag :: Flag -> Err O.Option +redFlag (Flg f x) = return $ O.Opt (prIdent f,[prIdent x]) + +redDecl :: Decl -> Err G.Decl +redDecl (Decl x a) = liftM2 (,) (redIdent x) (redTerm a) + +redType :: Exp -> Err G.Type +redType = redTerm + +redTerm :: Exp -> Err G.Term +redTerm t = return $ trExp t + +-- resource + +redParam (ParD c cont) = do + c' <- redIdent c + cont' <- mapM redCType cont + return $ (c', [(IW,t) | t <- cont']) + +-- concrete syntax + +redCType :: CType -> Err G.Type +redCType t = case t of + RecType lbs -> do + let (ls,ts) = unzip [(l,t) | Lbg l t <- lbs] + ls' = map redLabel ls + ts' <- mapM redCType ts + return $ G.RecType $ zip ls' ts' + Table p v -> liftM2 G.Table (redCType p) (redCType v) + Cn mc -> liftM (uncurry G.QC) $ redQIdent mc + TStr -> return $ F.typeStr + +redCTerm :: Term -> Err G.Term +redCTerm x = case x of + Arg argvar -> liftM G.Vr $ redArgVar argvar + I cident -> liftM (uncurry G.Q) $ redQIdent cident + Con cident terms -> liftM2 F.mkApp + (liftM (uncurry G.QC) $ redQIdent cident) + (mapM redCTerm terms) + LI id -> liftM G.Vr $ redIdent id + R assigns -> do + let (ls,ts) = unzip [(l,t) | Ass l t <- assigns] + let ls' = map redLabel ls + ts' <- mapM redCTerm ts + return $ G.R [(l,(Nothing,t)) | (l,t) <- zip ls' ts'] + P term label -> liftM2 G.P (redCTerm term) (return $ redLabel label) + T ctype cases -> do + ctype' <- redCType ctype + let (ps,ts) = unzip [(p,t) | Cas ps t <- cases, p <- ps] --- destroys sharing + ps' <- mapM redPatt ps + ts' <- mapM redCTerm ts --- duplicates work for shared rhss + let tinfo = case ps' of + [G.PV _] -> G.TTyped ctype' + _ -> G.TComp ctype' + return $ G.T tinfo $ zip ps' ts' + S term0 term -> liftM2 G.S (redCTerm term0) (redCTerm term) + C term0 term -> liftM2 G.C (redCTerm term0) (redCTerm term) + FV terms -> liftM G.FV $ mapM redCTerm terms + K (KS str) -> return $ G.K str + E -> return $ G.Empty + K (KP d vs) -> return $ + G.Alts (tList d,[(tList s, G.Strs $ map G.K v) | Var s v <- vs]) + where + tList ss = case ss of --- this should be in Macros + [] -> G.Empty + _ -> foldr1 G.C $ map G.K ss + +failure x = Bad $ "not yet" +++ show x ---- + +redArgVar :: ArgVar -> Err Ident +redArgVar x = case x of + A x i -> return $ IA (prIdent x, fromInteger i) + AB x b i -> return $ IAV (prIdent x, fromInteger b, fromInteger i) + +redLabel :: Label -> G.Label +redLabel (L x) = G.LIdent $ prIdent x +redLabel (LV i) = G.LVar $ fromInteger i + +redPatt :: Patt -> Err G.Patt +redPatt p = case p of + PV x -> liftM G.PV $ redIdent x + PC mc ps -> do + (m,c) <- redQIdent mc + liftM (G.PP m c) (mapM redPatt ps) + PR rs -> do + let (ls,ts) = unzip [(l,t) | PAss l t <- rs] + ls' = map redLabel ls + ts <- mapM redPatt ts + return $ G.PR $ zip ls' ts + _ -> Bad $ "cannot recompile pattern" +++ show p + diff --git a/src/GF/Canon/GFC.hs b/src/GF/Canon/GFC.hs new file mode 100644 index 000000000..63b697a35 --- /dev/null +++ b/src/GF/Canon/GFC.hs @@ -0,0 +1,48 @@ +module GFC where + +import AbsGFC +import PrintGFC +import qualified Abstract as A + +import Ident +import Option +import Zipper +import Operations +import qualified Modules as M + +import Char + +-- canonical GF. AR 10/9/2002 -- 9/5/2003 -- 21/9 + +type Context = [(Ident,Exp)] + +type CanonGrammar = M.MGrammar Ident Flag Info + +type CanonModInfo = M.ModInfo Ident Flag Info + +type CanonModule = (Ident, CanonModInfo) + +type CanonAbs = M.Module Ident Option Info + +data Info = + AbsCat A.Context [A.Fun] + | AbsFun A.Type A.Term + + | ResPar [ParDef] + | ResOper CType Term -- global constant + | CncCat CType Term Printname + | CncFun CIdent [ArgVar] Term Printname + | AnyInd Bool Ident + deriving (Show) + +type Printname = Term + +-- some printing ---- + +{- +prCanonModInfo :: (Ident,CanonModInfo) -> String +prCanonModInfo = printTree . info2mod + +prGrammar :: CanonGrammar -> String +prGrammar = printTree . grammar2canon +-} diff --git a/src/GF/Canon/GetGFC.hs b/src/GF/Canon/GetGFC.hs new file mode 100644 index 000000000..225b0712a --- /dev/null +++ b/src/GF/Canon/GetGFC.hs @@ -0,0 +1,22 @@ +module GetGFC where + +import Operations +import ParGFC +import GFC +import MkGFC +import Modules +import GetGrammar (err2err) --- +import UseIO + +getCanonModule :: FilePath -> IOE CanonModule +getCanonModule file = do + gr <- getCanonGrammar file + case modules gr of + [m] -> return m + _ -> ioeErr $ Bad "expected exactly one module in a file" + +getCanonGrammar :: FilePath -> IOE CanonGrammar +getCanonGrammar file = do + s <- ioeIO $ readFileIf file + c <- ioeErr $ err2err $ pCanon $ myLexer s + return $ canon2grammar c diff --git a/src/GF/Canon/LexGFC.hs b/src/GF/Canon/LexGFC.hs new file mode 100644 index 000000000..56048dce3 --- /dev/null +++ b/src/GF/Canon/LexGFC.hs @@ -0,0 +1,105 @@ + +module LexGFC where + +import Alex +import ErrM + +pTSpec p = PT p . TS + +ident p = PT p . eitherResIdent TV + +string p = PT p . TL . unescapeInitTail + +int p = PT p . TI + + +data Tok = + TS String -- reserved words + | TL String -- string literals + | TI String -- integer literals + | TV String -- identifiers + | TD String -- double precision float literals + | TC String -- character literals + + deriving (Eq,Show) + +data Token = + PT Posn Tok + | Err Posn + deriving Show + +tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l +tokenPos (Err (Pn _ l _) :_) = "line " ++ show l +tokenPos _ = "end of file" + +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 + +tokens:: String -> [Token] +tokens inp = scan tokens_scan inp + +tokens_scan:: Scan Token +tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx + where + stop_act p "" = [] + stop_act p inp = [Err p] + +eitherResIdent :: (String -> Tok) -> String -> Tok +eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where + isResWord s = isInTree s $ + B "lin" (B "concrete" (B "abstract" (B "Type" (B "Str" N N) N) (B "cat" N N)) (B "fun" (B "flags" (B "data" N N) N) (B "in" N N))) (B "param" (B "open" (B "of" (B "lincat" N N) N) (B "oper" N N)) (B "table" (B "resource" (B "pre" N N) N) (B "variants" N N))) + +data BTree = N | B String BTree BTree deriving (Show) + +isInTree :: String -> BTree -> Bool +isInTree x tree = case tree of + N -> False + B a left right + | x < a -> isInTree x left + | x > a -> isInTree x right + | x == a -> True + +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 + _ -> [] + +tokens_acts = [("ident",ident),("int",int),("pTSpec",pTSpec),("string",string)] + +tokens_lx :: [(Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))] +tokens_lx = [lx__0_0,lx__1_0,lx__2_0,lx__3_0,lx__4_0,lx__5_0,lx__6_0,lx__7_0,lx__8_0,lx__9_0,lx__10_0,lx__11_0] +lx__0_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__0_0 = (False,[],-1,(('\t','\255'),[('\t',1),('\n',1),('\v',1),('\f',1),('\r',1),(' ',1),('!',6),('"',8),('$',6),('(',6),(')',6),('*',2),('+',5),(',',6),('-',3),('.',6),('/',6),('0',11),('1',11),('2',11),('3',11),('4',11),('5',11),('6',11),('7',11),('8',11),('9',11),(':',6),(';',6),('<',6),('=',4),('>',6),('?',6),('@',6),('A',7),('B',7),('C',7),('D',7),('E',7),('F',7),('G',7),('H',7),('I',7),('J',7),('K',7),('L',7),('M',7),('N',7),('O',7),('P',7),('Q',7),('R',7),('S',7),('T',7),('U',7),('V',7),('W',7),('X',7),('Y',7),('Z',7),('[',6),('\\',6),(']',6),('_',6),('a',7),('b',7),('c',7),('d',7),('e',7),('f',7),('g',7),('h',7),('i',7),('j',7),('k',7),('l',7),('m',7),('n',7),('o',7),('p',7),('q',7),('r',7),('s',7),('t',7),('u',7),('v',7),('w',7),('x',7),('y',7),('z',7),('{',6),('|',6),('}',6),('\192',7),('\193',7),('\194',7),('\195',7),('\196',7),('\197',7),('\198',7),('\199',7),('\200',7),('\201',7),('\202',7),('\203',7),('\204',7),('\205',7),('\206',7),('\207',7),('\208',7),('\209',7),('\210',7),('\211',7),('\212',7),('\213',7),('\214',7),('\216',7),('\217',7),('\218',7),('\219',7),('\220',7),('\221',7),('\222',7),('\223',7),('\224',7),('\225',7),('\226',7),('\227',7),('\228',7),('\229',7),('\230',7),('\231',7),('\232',7),('\233',7),('\234',7),('\235',7),('\236',7),('\237',7),('\238',7),('\239',7),('\240',7),('\241',7),('\242',7),('\243',7),('\244',7),('\245',7),('\246',7),('\248',7),('\249',7),('\250',7),('\251',7),('\252',7),('\253',7),('\254',7),('\255',7)])) +lx__1_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__1_0 = (True,[(0,"",[],Nothing,Nothing)],-1,(('\t',' '),[('\t',1),('\n',1),('\v',1),('\f',1),('\r',1),(' ',1)])) +lx__2_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__2_0 = (False,[],-1,(('*','*'),[('*',6)])) +lx__3_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__3_0 = (False,[],-1,(('>','>'),[('>',6)])) +lx__4_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__4_0 = (True,[(1,"pTSpec",[],Nothing,Nothing)],-1,(('>','>'),[('>',6)])) +lx__5_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__5_0 = (True,[(1,"pTSpec",[],Nothing,Nothing)],-1,(('+','+'),[('+',6)])) +lx__6_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__6_0 = (True,[(1,"pTSpec",[],Nothing,Nothing)],-1,(('0','0'),[])) +lx__7_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__7_0 = (True,[(2,"ident",[],Nothing,Nothing)],-1,(('\'','\255'),[('\'',7),('0',7),('1',7),('2',7),('3',7),('4',7),('5',7),('6',7),('7',7),('8',7),('9',7),('A',7),('B',7),('C',7),('D',7),('E',7),('F',7),('G',7),('H',7),('I',7),('J',7),('K',7),('L',7),('M',7),('N',7),('O',7),('P',7),('Q',7),('R',7),('S',7),('T',7),('U',7),('V',7),('W',7),('X',7),('Y',7),('Z',7),('_',7),('a',7),('b',7),('c',7),('d',7),('e',7),('f',7),('g',7),('h',7),('i',7),('j',7),('k',7),('l',7),('m',7),('n',7),('o',7),('p',7),('q',7),('r',7),('s',7),('t',7),('u',7),('v',7),('w',7),('x',7),('y',7),('z',7),('\192',7),('\193',7),('\194',7),('\195',7),('\196',7),('\197',7),('\198',7),('\199',7),('\200',7),('\201',7),('\202',7),('\203',7),('\204',7),('\205',7),('\206',7),('\207',7),('\208',7),('\209',7),('\210',7),('\211',7),('\212',7),('\213',7),('\214',7),('\216',7),('\217',7),('\218',7),('\219',7),('\220',7),('\221',7),('\222',7),('\223',7),('\224',7),('\225',7),('\226',7),('\227',7),('\228',7),('\229',7),('\230',7),('\231',7),('\232',7),('\233',7),('\234',7),('\235',7),('\236',7),('\237',7),('\238',7),('\239',7),('\240',7),('\241',7),('\242',7),('\243',7),('\244',7),('\245',7),('\246',7),('\248',7),('\249',7),('\250',7),('\251',7),('\252',7),('\253',7),('\254',7),('\255',7)])) +lx__8_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__8_0 = (False,[],8,(('\n','\\'),[('\n',-1),('"',10),('\\',9)])) +lx__9_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__9_0 = (False,[],-1,(('"','t'),[('"',8),('\'',8),('\\',8),('n',8),('t',8)])) +lx__10_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__10_0 = (True,[(3,"string",[],Nothing,Nothing)],-1,(('0','0'),[])) +lx__11_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__11_0 = (True,[(4,"int",[],Nothing,Nothing)],-1,(('0','9'),[('0',11),('1',11),('2',11),('3',11),('4',11),('5',11),('6',11),('7',11),('8',11),('9',11)])) + diff --git a/src/GF/Canon/Look.hs b/src/GF/Canon/Look.hs new file mode 100644 index 000000000..a71d024c2 --- /dev/null +++ b/src/GF/Canon/Look.hs @@ -0,0 +1,141 @@ +module Look where + +import AbsGFC +import GFC +import PrGrammar +import CMacros +----import Values +import MMacros +import qualified Modules as M + +import Operations + +import Monad +import List + +-- lookup in GFC. AR 2003 + +-- linearization lookup + +lookupCncInfo :: CanonGrammar -> CIdent -> Err Info +lookupCncInfo gr f@(CIQ m c) = do + mt <- M.lookupModule gr m + case mt of + M.ModMod a -> errIn ("module" +++ prt m) $ + lookupTree prt c $ M.jments a + _ -> prtBad "not concrete module" m + +lookupLin :: CanonGrammar -> CIdent -> Err Term +lookupLin gr f = do + info <- lookupCncInfo gr f + case info of + CncFun _ _ t _ -> return t + CncCat _ t _ -> return t + AnyInd _ n -> lookupLin gr $ redirectIdent n f + +lookupResInfo :: CanonGrammar -> CIdent -> Err Info +lookupResInfo gr f@(CIQ m c) = do + mt <- M.lookupModule gr m + case mt of + M.ModMod a -> lookupTree prt c $ M.jments a + _ -> prtBad "not resource module" m + +lookupGlobal :: CanonGrammar -> CIdent -> Err Term +lookupGlobal gr f = do + info <- lookupResInfo gr f + case info of + ResOper _ t -> return t + AnyInd _ n -> lookupGlobal gr $ redirectIdent n f + _ -> prtBad "cannot find global" f + +lookupParamValues :: CanonGrammar -> CIdent -> Err [Term] +lookupParamValues gr pt@(CIQ m _) = do + info <- lookupResInfo gr pt + case info of + ResPar ps -> liftM concat $ mapM mkPar ps + AnyInd _ n -> lookupParamValues gr $ redirectIdent n pt + _ -> prtBad "cannot find parameter type" pt + where + mkPar (ParD f co) = do + vs <- liftM combinations $ mapM (allParamValues gr) co + return $ map (Con (CIQ m f)) vs + +-- this is needed since param type can also be a record type + +allParamValues :: CanonGrammar -> CType -> Err [Term] +allParamValues cnc ptyp = case ptyp of + Cn pc -> lookupParamValues cnc pc + RecType r -> do + let (ls,tys) = unzip [(l,t) | Lbg l t <- r] + tss <- mapM allPV tys + return [R (map (uncurry Ass) (zip ls ts)) | ts <- combinations tss] + _ -> prtBad "cannot possibly find parameter values for" ptyp + where + allPV = allParamValues cnc + +-- runtime computation on GFC objects + +ccompute :: CanonGrammar -> [Term] -> Term -> Err Term +ccompute cnc = comp [] + where + comp g xs t = case t of + Arg (A _ i) -> errIn ("argument list") $ xs !? fromInteger i + Arg (AB _ _ i) -> errIn ("argument list for binding") $ xs !? fromInteger i + I c -> look c + LI c -> lookVar c g + + -- short-cut computation of selections: compute the table only if needed + S u v -> do + u' <- compt u + case u' of + T _ [Cas [PW] b] -> compt b + T _ [Cas [PV x] b] -> do + v' <- compt v + comp ((x,v') : g) xs b + T _ cs -> do + v' <- compt v + if noVar v' + then matchPatt cs v' >>= compt + else return $ S u' v' + + _ -> liftM (S u') $ compt v + + P u l -> do + u' <- compt u + case u' of + R rs -> maybe (Bad ("unknown label" +++ prt l +++ "in" +++ prt u')) + return $ + lookup l [ (x,y) | Ass x y <- rs] + _ -> return $ P u' l + FV ts -> liftM FV (mapM compt ts) + C E b -> compt b + C a E -> compt a + C a b -> do + a' <- compt a + b' <- compt b + return $ case (a',b') of + (E,_) -> b' + (_,E) -> a' + _ -> C a' b' + R rs -> liftM (R . map (uncurry Ass)) $ + mapPairsM compt [(l,r) | Ass l r <- rs] + + -- only expand the table when the table is really needed: use expandLin + T ty rs -> liftM (T ty . map (uncurry Cas)) $ + mapPairsM compt [(l,r) | Cas l r <- rs] + + Con c xs -> liftM (Con c) $ mapM compt xs + + _ -> return t + where + compt = comp g xs + look c = lookupGlobal cnc c + + lookVar c co = case lookup c co of + Just t -> return t + _ -> return $ LI c --- Bad $ "unknown local variable" +++ prt c --- + + noVar v = case v of + LI _ -> False + R rs -> all noVar [t | Ass _ t <- rs] + _ -> True --- other cases? diff --git a/src/GF/Canon/MkGFC.hs b/src/GF/Canon/MkGFC.hs new file mode 100644 index 000000000..d7641ca21 --- /dev/null +++ b/src/GF/Canon/MkGFC.hs @@ -0,0 +1,121 @@ +module MkGFC where + +import GFC +import AbsGFC +import qualified Abstract as A +import PrGrammar + +import Ident +import Operations +import qualified Modules as M + +prCanonModInfo :: CanonModule -> String +prCanonModInfo = prt . info2mod + +canon2grammar :: Canon -> CanonGrammar +canon2grammar (Gr modules) = M.MGrammar $ map mod2info modules where + mod2info m = case m of + Mod mt e os flags defs -> + let defs' = buildTree $ map def2info defs + (a,mt') = case mt of + MTAbs a -> (a,M.MTAbstract) + MTRes a -> (a,M.MTResource) + MTCnc a x -> (a,M.MTConcrete x) + in (a,M.ModMod (M.Module mt' flags (ee e) (oo os) defs')) + ee (Ext m) = Just m + ee _ = Nothing + oo (Opens ms) = map M.OSimple ms + oo _ = [] + +grammar2canon :: CanonGrammar -> Canon +grammar2canon (M.MGrammar modules) = Gr $ map info2mod modules + +info2mod m = case m of + (a, M.ModMod (M.Module mt flags me os defs)) -> + let defs' = map info2def $ tree2list defs + mt' = case mt of + M.MTAbstract -> MTAbs a + M.MTResource -> MTRes a + M.MTConcrete x -> MTCnc a x + in + Mod mt' (gfcE me) (gfcO os) flags defs' + where + gfcE = maybe NoExt Ext + gfcO os = if null os then NoOpens else Opens [m | M.OSimple m <- os] + + +-- these translations are meant to be trivial + +defs2infos = sorted2tree . map def2info + +def2info d = case d of + AbsDCat c cont fs -> (c,AbsCat (trCont cont) (trFs fs)) + AbsDFun c ty df -> (c,AbsFun (trExp ty) (trExp df)) + ResDPar c df -> (c,ResPar df) + ResDOper c ty df -> (c,ResOper ty df) + CncDCat c ty df pr -> (c, CncCat ty df pr) + CncDFun f c xs li pr -> (f, CncFun c xs li pr) + AnyDInd c b m -> (c, AnyInd (b == Canon) m) + +-- from file to internal + +trCont cont = [(x,trExp t) | Decl x t <- cont] + +trFs = map trQIdent + +trExp t = case t of + EProd x a b -> A.Prod x (trExp a) (trExp b) + EAbs x b -> A.Abs x (trExp b) + EApp f a -> A.App (trExp f) (trExp a) + EEq _ -> A.Eqs [] ---- eqs + _ -> trAt t + where + trAt (EAtom t) = case t of + AC c -> (uncurry A.Q) $ trQIdent c + AD c -> (uncurry A.QC) $ trQIdent c + AV v -> A.Vr v + AM i -> A.Meta $ A.MetaSymb $ fromInteger i + AT s -> A.Sort $ prt s + AS s -> A.K s + AI i -> A.EInt $ fromInteger i + +trQIdent (CIQ m c) = (m,c) + +-- from internal to file + +infos2defs = map info2def . tree2list + +info2def d = case d of + (c,AbsCat cont fs) -> AbsDCat c (rtCont cont) (rtFs fs) + (c,AbsFun ty df) -> AbsDFun c (rtExp ty) (rtExp df) + (c,ResPar df) -> ResDPar c df + (c,ResOper ty df) -> ResDOper c ty df + (c,CncCat ty df pr) -> CncDCat c ty df pr + (f,CncFun c xs li pr) -> CncDFun f c xs li pr + (c,AnyInd b m) -> AnyDInd c (if b then Canon else NonCan) m + +rtCont cont = [Decl (rtIdent x) (rtExp t) | (x,t) <- cont] + +rtFs = map rtQIdent + +rtExp t = case t of + A.Prod x a b -> EProd (rtIdent x) (rtExp a) (rtExp b) + A.Abs x b -> EAbs (rtIdent x) (rtExp b) + A.App f a -> EApp (rtExp f) (rtExp a) + A.Eqs _ -> EEq [] ---- eqs + _ -> EAtom $ rtAt t + where + rtAt t = case t of + A.Q m c -> AC $ rtQIdent (m,c) + A.QC m c -> AD $ rtQIdent (m,c) + A.Vr v -> AV v + A.Meta i -> AM $ toInteger $ A.metaSymbInt i + A.Sort "Type" -> AT SType + A.K s -> AS s + A.EInt i -> AI $ toInteger i + _ -> error $ "MkGFC.rt not defined for" +++ show t + +rtQIdent (m,c) = CIQ (rtIdent m) (rtIdent c) +rtIdent x + | isWildIdent x = identC "h_" --- needed in declarations + | otherwise = identC $ prt x --- diff --git a/src/GF/Canon/PrExp.hs b/src/GF/Canon/PrExp.hs new file mode 100644 index 000000000..6052f9a7f --- /dev/null +++ b/src/GF/Canon/PrExp.hs @@ -0,0 +1,36 @@ +module PrExp where + +import AbsGFC +import GFC + +import Operations + +-- some printing + +-- print trees without qualifications + +prExp :: Exp -> String +prExp e = case e of + EApp f a -> pr1 f +++ pr2 a + EAbsR x b -> "\\" ++ prtt x +++ "->" +++ prExp b + EAbs x _ b -> prExp $ EAbsR x b + EProd x a b -> "(\\" ++ prtt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b + EAtomR a -> prAtom a + EAtom a _ -> prAtom a + _ -> prtt e + where + pr1 e = case e of + EAbsR _ _ -> prParenth $ prExp e + EAbs _ _ _ -> prParenth $ prExp e + EProd _ _ _ -> prParenth $ prExp e + _ -> prExp e + pr2 e = case e of + EApp _ _ -> prParenth $ prExp e + _ -> pr1 e + +prAtom a = case a of + AC c -> prCIdent c + AD c -> prCIdent c + _ -> prtt a + +prCIdent (CIQ _ c) = prtt c diff --git a/src/GF/Canon/PrintGFC.hs b/src/GF/Canon/PrintGFC.hs new file mode 100644 index 000000000..c4f2e7d62 --- /dev/null +++ b/src/GF/Canon/PrintGFC.hs @@ -0,0 +1,319 @@ +module PrintGFC where + +-- pretty-printer generated by the BNF converter, except handhacked spacing --H + +import Ident --H +import AbsGFC +import Char + +-- the top-level printing method +printTree :: Print a => a -> String +printTree = render . prt 0 + +-- you may want to change render and parenth + +render :: [String] -> String +render = rend 0 where + rend i ss = case ss of + "NEW" :ts -> realnew $ rend i ts --H + "<" :ts -> cons "<" $ rend i ts --H + "$" :ts -> cons "$" $ rend i ts --H + "?" :ts -> cons "?" $ rend i ts --H + "[" :ts -> cons "[" $ rend i ts + "(" :ts -> cons "(" $ rend i ts + "{" :ts -> cons "{" $ new (i+1) $ rend (i+1) ts + "}" : ";":ts -> new (i-1) $ space "}" $ cons ";" $ new (i-1) $ rend (i-1) ts + "}" :ts -> new (i-1) $ cons "}" $ new (i-1) $ rend (i-1) ts + ";" :ts -> cons ";" $ new i $ rend i ts + t : "," :ts -> cons t $ space "," $ rend i ts + t : ")" :ts -> cons t $ cons ")" $ rend i ts + t : "]" :ts -> cons t $ cons "]" $ rend i ts + t : ">" :ts -> cons t $ cons ">" $ rend i ts --H + t : "." :ts -> cons t $ cons "." $ rend i ts --H + t :ts -> realspace t $ rend i ts --H + _ -> "" + cons s t = s ++ t + space t s = t ++ " " ++ s --H + realspace t s = if null s then t else t ++ " " ++ s --H + new i s = s --H '\n' : replicate (2*i) ' ' ++ dropWhile isSpace s + realnew s = '\n':s --H + +parenth :: [String] -> [String] +parenth ss = ["("] ++ ss ++ [")"] + +-- the printer class does the job +class Print a where + prt :: Int -> a -> [String] + prtList :: [a] -> [String] + prtList = concat . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Integer where + prt _ = (:[]) . show + +instance Print Double where + prt _ = (:[]) . show + +instance Print Char where + prt _ s = ["'" ++ mkEsc s ++ "'"] + prtList s = ["\"" ++ concatMap mkEsc s ++ "\""] + +mkEsc s = case s of + _ | elem s "\\\"'" -> '\\':[s] + '\n' -> "\\n" + '\t' -> "\\t" + _ -> [s] + +prPrec :: Int -> Int -> [String] -> [String] +prPrec i j = if j (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [","] , prt 0 xs]) + + + +instance Print Canon where + prt i e = case e of + Gr modules -> prPrec i 0 (concat [prt 0 modules]) + + +instance Print Module where + prt i e = case e of + Mod modtype extend open flags defs -> prPrec i 0 (concat [prt 0 modtype , ["="] , prt 0 extend , prt 0 open , ["{"] , prt 0 flags , prt 0 defs , ["}"]]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print ModType where + prt i e = case e of + MTAbs id -> prPrec i 0 (concat [["abstract"] , prt 0 id]) + MTCnc id0 id -> prPrec i 0 (concat [["concrete"] , prt 0 id0 , ["of"] , prt 0 id]) + MTRes id -> prPrec i 0 (concat [["resource"] , prt 0 id]) + + +instance Print Extend where + prt i e = case e of + Ext id -> prPrec i 0 (concat [prt 0 id , ["**"]]) + NoExt -> prPrec i 0 (concat []) + + +instance Print Open where + prt i e = case e of + NoOpens -> prPrec i 0 (concat []) + Opens ids -> prPrec i 0 (concat [["open"] , prt 0 ids , ["in"]]) + + +instance Print Flag where + prt i e = case e of + Flg id0 id -> prPrec i 0 (concat [["flags"] , prt 0 id0 , ["="] , prt 0 id]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Def where + prt i e = case e of + AbsDCat id decls cidents -> prPrec i 0 (concat [["cat"] , prt 0 id , ["["] , prt 0 decls , ["]"] , ["="] , prt 0 cidents]) + AbsDFun id exp0 exp -> prPrec i 0 (concat [["fun"] , prt 0 id , [":"] , prt 0 exp0 , ["="] , prt 0 exp]) + ResDPar id pardefs -> prPrec i 0 (concat [["param"] , prt 0 id , ["="] , prt 0 pardefs]) + ResDOper id ctype term -> prPrec i 0 (concat [["oper"] , prt 0 id , [":"] , prt 0 ctype , ["="] , prt 0 term]) + CncDCat id ctype term0 term -> prPrec i 0 (concat [["lincat"] , prt 0 id , ["="] , prt 0 ctype , ["="] , prt 0 term0 , [";"] , prt 0 term]) + CncDFun id cident argvars term0 term -> prPrec i 0 (concat [["lin"] , prt 0 id , [":"] , prt 0 cident , ["="] , ["\\"] , prt 0 argvars , ["->"] , prt 0 term0 , [";"] , prt 0 term]) + AnyDInd id0 status id -> prPrec i 0 (concat [prt 0 id0 , prt 0 status , ["in"] , prt 0 id]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , [";","NEW"] , prt 0 xs]) --H + +instance Print ParDef where + prt i e = case e of + ParD id ctypes -> prPrec i 0 (concat [prt 0 id , prt 0 ctypes]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs]) + +instance Print Status where + prt i e = case e of + Canon -> prPrec i 0 (concat [["data"]]) + NonCan -> prPrec i 0 (concat []) + + +instance Print CIdent where + prt i e = case e of + CIQ id0 id -> prPrec i 0 (concat [prt 0 id0 , ["."] , prt 0 id]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print Exp where + prt i e = case e of + EApp exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , prt 2 exp]) + EProd id exp0 exp -> prPrec i 0 (concat [["("] , prt 0 id , [":"] , prt 0 exp0 , [")"] , ["->"] , prt 0 exp]) + EAtom atom -> prPrec i 2 (concat [prt 0 atom]) + EAbs id exp -> prPrec i 0 (concat [["\\"] , prt 0 id , ["->"] , prt 0 exp]) + EEq equations -> prPrec i 0 (concat [["{"] , prt 0 equations , ["}"]]) + +instance Print Sort where + prt i e = case e of + SType -> prPrec i 0 (concat [["Type"]]) + +instance Print Equation where + prt i e = case e of + Equ apatts exp -> prPrec i 0 (concat [prt 0 apatts , ["->"] , prt 0 exp]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print APatt where + prt i e = case e of + APC cident apatts -> prPrec i 0 (concat [["("] , prt 0 cident , prt 0 apatts , [")"]]) + APV id -> prPrec i 0 (concat [prt 0 id]) + APS str -> prPrec i 0 (concat [prt 0 str]) + API n -> prPrec i 0 (concat [prt 0 n]) + APW -> prPrec i 0 (concat [["_"]]) + + prtList es = case es of + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print Atom where + prt i e = case e of + AC cident -> prPrec i 0 (concat [prt 0 cident]) + AD cident -> prPrec i 0 (concat [["<"] , prt 0 cident , [">"]]) + AV id -> prPrec i 0 (concat [["$"] , prt 0 id]) + AM n -> prPrec i 0 (concat [["?"] , prt 0 n]) + AS str -> prPrec i 0 (concat [prt 0 str]) + AI n -> prPrec i 0 (concat [prt 0 n]) + AT sort -> prPrec i 0 (concat [prt 0 sort]) + + +instance Print Decl where + prt i e = case e of + Decl id exp -> prPrec i 0 (concat [prt 0 id , [":"] , prt 0 exp]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print CType where + prt i e = case e of + RecType labellings -> prPrec i 0 (concat [["{"] , prt 0 labellings , ["}"]]) + Table ctype0 ctype -> prPrec i 0 (concat [["("] , prt 0 ctype0 , ["=>"] , prt 0 ctype , [")"]]) + Cn cident -> prPrec i 0 (concat [prt 0 cident]) + TStr -> prPrec i 0 (concat [["Str"]]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print Labelling where + prt i e = case e of + Lbg label ctype -> prPrec i 0 (concat [prt 0 label , [":"] , prt 0 ctype]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Term where + prt i e = case e of + Arg argvar -> prPrec i 2 (concat [prt 0 argvar]) + I cident -> prPrec i 2 (concat [prt 0 cident]) + Con cident terms -> prPrec i 2 (concat [["<"] , prt 0 cident , prt 2 terms , [">"]]) + LI id -> prPrec i 2 (concat [["$"] , prt 0 id]) + R assigns -> prPrec i 2 (concat [["{"] , prt 0 assigns , ["}"]]) + P term label -> prPrec i 1 (concat [prt 2 term , ["."] , prt 0 label]) + T ctype cases -> prPrec i 1 (concat [["table"] , prt 0 ctype , ["{"] , prt 0 cases , ["}"]]) + S term0 term -> prPrec i 1 (concat [prt 1 term0 , ["!"] , prt 2 term]) + C term0 term -> prPrec i 0 (concat [prt 0 term0 , ["++"] , prt 1 term]) + FV terms -> prPrec i 1 (concat [["variants"] , ["{"] , prt 2 terms , ["}"]]) + K tokn -> prPrec i 2 (concat [prt 0 tokn]) + E -> prPrec i 2 (concat [["["] , ["]"]]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 2 x , prt 2 xs]) + +instance Print Tokn where + prt i e = case e of + KS str -> prPrec i 0 (concat [prt 0 str]) + KP strs variants -> prPrec i 0 (concat [["["] , ["pre"] , prt 0 strs , ["{"] , prt 0 variants , ["}"] , ["]"]]) + + +instance Print Assign where + prt i e = case e of + Ass label term -> prPrec i 0 (concat [prt 0 label , ["="] , prt 0 term]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Case where + prt i e = case e of + Cas patts term -> prPrec i 0 (concat [prt 0 patts , ["=>"] , prt 0 term]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Variant where + prt i e = case e of + Var strs0 strs -> prPrec i 0 (concat [prt 0 strs0 , ["/"] , prt 0 strs]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Label where + prt i e = case e of + L id -> prPrec i 0 (concat [prt 0 id]) + LV n -> prPrec i 0 (concat [["$"] , prt 0 n]) + + +instance Print ArgVar where + prt i e = case e of + A id n -> prPrec i 0 (concat [prt 0 id , ["@"] , prt 0 n]) + AB id n0 n -> prPrec i 0 (concat [prt 0 id , ["+"] , prt 0 n0 , ["@"] , prt 0 n]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [","] , prt 0 xs]) + +instance Print Patt where + prt i e = case e of + PC cident patts -> prPrec i 0 (concat [["("] , prt 0 cident , prt 0 patts , [")"]]) + PV id -> prPrec i 0 (concat [prt 0 id]) + PW -> prPrec i 0 (concat [["_"]]) + PR pattassigns -> prPrec i 0 (concat [["{"] , prt 0 pattassigns , ["}"]]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print PattAssign where + prt i e = case e of + PAss label patt -> prPrec i 0 (concat [prt 0 label , ["="] , prt 0 patt]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + + diff --git a/src/GF/Canon/Share.hs b/src/GF/Canon/Share.hs new file mode 100644 index 000000000..fc4d82b06 --- /dev/null +++ b/src/GF/Canon/Share.hs @@ -0,0 +1,116 @@ +module Share (shareModule, OptSpec, basicOpt, fullOpt) where + +import AbsGFC +import Ident +import GFC +import qualified CMacros as C +import Operations +import List +import qualified Modules as M + +-- optimization: sharing branches in tables. AR 25/4/2003 +-- following advice of Josef Svenningsson + +type OptSpec = [Integer] --- +doOptFactor opt = elem 2 opt +basicOpt = [] +fullOpt = [2] + +shareModule :: OptSpec -> (Ident, CanonModInfo) -> (Ident, CanonModInfo) +shareModule opt (i,m) = case m of + M.ModMod (M.Module mt fs me ops js) -> + (i,M.ModMod (M.Module mt fs me ops (mapTree (shareInfo opt) js))) + _ -> (i,m) + +shareInfo opt (c, CncCat ty t m) = (c, CncCat ty (shareOpt opt t) m) +shareInfo opt (c, CncFun k xs t m) = (c, CncFun k xs (shareOpt opt t) m) +shareInfo _ i = i + +-- the function putting together optimizations +shareOpt :: OptSpec -> Term -> Term +shareOpt opt + | doOptFactor opt = share . factor 0 + | otherwise = share + +-- we need no counter to create new variable names, since variables are +-- local to tables + +share :: Term -> Term +share t = case t of + T ty cs -> shareT ty [(p, share v) | Cas ps v <- cs, p <- ps] -- only substant. + R lts -> R [Ass l (share t) | Ass l t <- lts] + P t l -> P (share t) l + S t a -> S (share t) (share a) + C t a -> C (share t) (share a) + FV ts -> FV (map share ts) + + _ -> t -- including D, which is always born shared + + where + shareT ty = finalize ty . groupC . sortC + + sortC :: [(Patt,Term)] -> [(Patt,Term)] + sortC = sortBy $ \a b -> compare (snd a) (snd b) + + groupC :: [(Patt,Term)] -> [[(Patt,Term)]] + groupC = groupBy $ \a b -> snd a == snd b + + finalize :: CType -> [[(Patt,Term)]] -> Term + finalize ty css = T ty [Cas (map fst ps) t | ps@((_,t):_) <- css] + + +-- do even more: factor parametric branches + +factor :: Int -> Term -> Term +factor i t = case t of + T _ [_] -> t + T _ [] -> t + T ty cs -> T ty $ factors i [Cas [p] (factor (i+1) v) | Cas ps v <- cs, p <- ps] + R lts -> R [Ass l (factor i t) | Ass l t <- lts] + P t l -> P (factor i t) l + S t a -> S (factor i t) (factor i a) + C t a -> C (factor i t) (factor i a) + FV ts -> FV (map (factor i) ts) + + _ -> t + where + + factors i psvs = -- we know psvs has at least 2 elements + let p = pIdent i + vs' = map (mkFun p) psvs + in if allEqs vs' + then mkCase p vs' + else psvs + + mkFun p (Cas [patt] val) = replace (C.patt2term patt) (LI p) val + + allEqs (v:vs) = all (==v) vs + + mkCase p (v:_) = [Cas [PV p] v] + +pIdent i = identC ("p__" ++ show i) + + +-- we need to replace subterms + +replace :: Term -> Term -> Term -> Term +replace old new trm = case trm of + T ty cs -> T ty [Cas p (repl v) | Cas p v <- cs] + P t l -> P (repl t) l + S t a -> S (repl t) (repl a) + C t a -> C (repl t) (repl a) + FV ts -> FV (map repl ts) + + -- these are the important cases, since they can correspond to patterns + Con c ts | trm == old -> new + Con c ts -> Con c (map repl ts) + R _ | isRec && trm == old -> new + R lts -> R [Ass l (repl t) | Ass l t <- lts] + + _ -> trm + where + repl = replace old new + isRec = case trm of + R _ -> True + _ -> False + diff --git a/src/GF/Canon/SkelGFC.hs b/src/GF/Canon/SkelGFC.hs new file mode 100644 index 000000000..e75b66636 --- /dev/null +++ b/src/GF/Canon/SkelGFC.hs @@ -0,0 +1,199 @@ +module SkelGFC where + +import Ident + +-- Haskell module generated by the BNF converter + +import AbsGFC +import ErrM +type Result = Err String + +failure :: Show a => a -> Result +failure x = Bad $ "Undefined case: " ++ show x + +transIdent :: Ident -> Result +transIdent x = case x of + _ -> failure x + + +transCanon :: Canon -> Result +transCanon x = case x of + Gr modules -> failure x + + +transModule :: Module -> Result +transModule x = case x of + Mod modtype extend open flags defs -> failure x + + +transModType :: ModType -> Result +transModType x = case x of + MTAbs id -> failure x + MTCnc id0 id -> failure x + MTRes id -> failure x + + +transExtend :: Extend -> Result +transExtend x = case x of + Ext id -> failure x + NoExt -> failure x + + +transOpen :: Open -> Result +transOpen x = case x of + NoOpens -> failure x + Opens ids -> failure x + + +transFlag :: Flag -> Result +transFlag x = case x of + Flg id0 id -> failure x + + +transDef :: Def -> Result +transDef x = case x of + AbsDCat id decls cidents -> failure x + AbsDFun id exp0 exp -> failure x + ResDPar id pardefs -> failure x + ResDOper id ctype term -> failure x + CncDCat id ctype term0 term -> failure x + CncDFun id cident argvars term0 term -> failure x + AnyDInd id0 status id -> failure x + + +transParDef :: ParDef -> Result +transParDef x = case x of + ParD id ctypes -> failure x + + +transStatus :: Status -> Result +transStatus x = case x of + Canon -> failure x + NonCan -> failure x + + +transCIdent :: CIdent -> Result +transCIdent x = case x of + CIQ id0 id -> failure x + + +transExp :: Exp -> Result +transExp x = case x of + EApp exp0 exp -> failure x + EProd id exp0 exp -> failure x + EAbs id exp -> failure x + EAtom atom -> failure x + EEq equations -> failure x + + +transSort :: Sort -> Result +transSort x = case x of + SType -> failure x + + +transEquation :: Equation -> Result +transEquation x = case x of + Equ apatts exp -> failure x + + +transAPatt :: APatt -> Result +transAPatt x = case x of + APC cident apatts -> failure x + APV id -> failure x + APS str -> failure x + API n -> failure x + APW -> failure x + + +transAtom :: Atom -> Result +transAtom x = case x of + AC cident -> failure x + AD cident -> failure x + AV id -> failure x + AM n -> failure x + AS str -> failure x + AI n -> failure x + AT sort -> failure x + + +transDecl :: Decl -> Result +transDecl x = case x of + Decl id exp -> failure x + + +transCType :: CType -> Result +transCType x = case x of + RecType labellings -> failure x + Table ctype0 ctype -> failure x + Cn cident -> failure x + TStr -> failure x + + +transLabelling :: Labelling -> Result +transLabelling x = case x of + Lbg label ctype -> failure x + + +transTerm :: Term -> Result +transTerm x = case x of + Arg argvar -> failure x + I cident -> failure x + Con cident terms -> failure x + LI id -> failure x + R assigns -> failure x + P term label -> failure x + T ctype cases -> failure x + S term0 term -> failure x + C term0 term -> failure x + FV terms -> failure x + K tokn -> failure x + E -> failure x + + +transTokn :: Tokn -> Result +transTokn x = case x of + KS str -> failure x + KP strs variants -> failure x + + +transAssign :: Assign -> Result +transAssign x = case x of + Ass label term -> failure x + + +transCase :: Case -> Result +transCase x = case x of + Cas patts term -> failure x + + +transVariant :: Variant -> Result +transVariant x = case x of + Var strs0 strs -> failure x + + +transLabel :: Label -> Result +transLabel x = case x of + L id -> failure x + LV n -> failure x + + +transArgVar :: ArgVar -> Result +transArgVar x = case x of + A id n -> failure x + AB id n0 n -> failure x + + +transPatt :: Patt -> Result +transPatt x = case x of + PC cident patts -> failure x + PV id -> failure x + PW -> failure x + PR pattassigns -> failure x + + +transPattAssign :: PattAssign -> Result +transPattAssign x = case x of + PAss label patt -> failure x + + + diff --git a/src/GF/Canon/TestGFC.hs b/src/GF/Canon/TestGFC.hs new file mode 100644 index 000000000..2210f4df3 --- /dev/null +++ b/src/GF/Canon/TestGFC.hs @@ -0,0 +1,25 @@ +-- automatically generated by BNF Converter +module TestGFC where + +import LexGFC +import ParGFC +import SkelGFC +import PrintGFC +import AbsGFC + +import ErrM + +type ParseFun a = [Token] -> Err a + +myLLexer = myLexer + +runFile :: (Print a, Show a) => ParseFun a -> FilePath -> IO() +runFile p f = readFile f >>= run p + +run :: (Print a, Show a) => ParseFun a -> String -> IO() +run p s = case (p (myLLexer s)) of + Bad s -> do putStrLn "\nParse Failed...\n" + putStrLn s + Ok tree -> do putStrLn "\nParse Successful!" + putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree + putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree diff --git a/src/GF/Canon/Unlex.hs b/src/GF/Canon/Unlex.hs new file mode 100644 index 000000000..f665f4c85 --- /dev/null +++ b/src/GF/Canon/Unlex.hs @@ -0,0 +1,37 @@ +module Unlex where + +import Operations +import Str + +import Char +import List (isPrefixOf) + +-- elementary text postprocessing. AR 21/11/2001 + +formatAsText :: String -> String +formatAsText = unwords . format . cap . words where + format ws = case ws of + w : c : ww | major c -> (w ++ c) : format (cap ww) + w : c : ww | minor c -> (w ++ c) : format ww + c : ww | para c -> "\n\n" : format ww + w : ww -> w : format ww + [] -> [] + cap (p:(c:cs):ww) | para p = p : (toUpper c : cs) : ww + cap ((c:cs):ww) = (toUpper c : cs) : ww + cap [] = [] + major = flip elem (map (:[]) ".!?") + minor = flip elem (map (:[]) ",:;") + para = (=="

") + +unlex :: [Str] -> String +unlex = formatAsText . performBinds . concat . map sstr . take 1 ---- + +-- modified from GF/src/Text by adding hyphen +performBinds :: String -> String +performBinds = unwords . format . words where + format ws = case ws of + w : "-" : u : ws -> format ((w ++ "-" ++ u) : ws) + w : "&+" : u : ws -> format ((w ++ u) : ws) + w : ws -> w : format ws + [] -> [] + diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs new file mode 100644 index 000000000..544214cb9 --- /dev/null +++ b/src/GF/Compile/CheckGrammar.hs @@ -0,0 +1,665 @@ +module CheckGrammar where + +import Grammar +import Ident +import Modules +import Refresh ---- + +import TypeCheck + +import PrGrammar +import Lookup +import LookAbs +import Macros +import ReservedWords ---- +import PatternMatch + +import Operations +import CheckM + +import List +import Monad + +-- 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 + +showCheckModule :: [SourceModule] -> SourceModule -> Err ([SourceModule],String) +showCheckModule mos m = do + (st,(_,msg)) <- checkStart $ checkModule mos m + return (st, unlines $ reverse msg) + +-- checking is performed in dependency order of modules + +checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule] +checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of + + ModMod mo@(Module mt fs me ops js) -> case mt of + MTAbstract -> do + js' <- mapMTree (checkAbsInfo gr name) js + return $ (name, ModMod (Module mt fs me ops js')) : ms + + MTResource -> do + js' <- mapMTree (checkResInfo gr) js + return $ (name, ModMod (Module mt fs me ops js')) : ms + + MTConcrete a -> do + ModMod abs <- checkErr $ lookupModule gr a + checkCompleteGrammar abs mo + js' <- mapMTree (checkCncInfo gr name (a,abs)) js + return $ (name, ModMod (Module mt fs me ops js')) : ms + _ -> return $ (name,mod) : ms + where + gr = MGrammar $ (name,mod):ms + +checkAbsInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) +checkAbsInfo st m (c,info) = do +---- checkReservedId c + case info of + AbsCat (Yes cont) _ -> mkCheck "category" $ + checkContext st cont ---- also cstrs + AbsFun (Yes typ) (Yes d) -> mkCheck "function" $ + checkTyp st typ ----- ++ + ----- checkEquation st (m,c) d ---- also if there's no def! + _ -> return (c,info) + where + mkCheck cat ss = case ss of + [] -> return (c,info) + ["[]"] -> return (c,info) ---- + _ -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c + +checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check () +checkCompleteGrammar abs cnc = mapM_ checkWarn $ + checkComplete [f | (f, AbsFun (Yes _) _) <- abs'] cnc' + where + abs' = tree2list $ jments abs + cnc' = mapTree fst $ jments cnc + checkComplete sought given = foldr ckOne [] sought + where + ckOne f = if isInBinTree f given + then id + else (("Warning: no linearization of" +++ prt f):) + +-- General Principle: only Yes-values are checked. +-- A May-value has always been checked in its origin module. + +checkResInfo :: SourceGrammar -> (Ident,Info) -> Check (Ident,Info) +checkResInfo gr (c,info) = do + checkReservedId c + case info of + + ResOper pty pde -> chIn "operation" $ do + (pty', pde') <- case (pty,pde) of + (Yes ty, Yes de) -> do + ty' <- check ty typeType >>= comp . fst + (de',_) <- check de ty' + return (Yes ty', Yes de') + (Nope, Yes de) -> do + (de',ty') <- infer de + return (Yes ty', Yes de') + _ -> return (pty, pde) --- other cases are uninteresting + return (c, ResOper pty' pde') + + ResParam (Yes pcs) -> chIn "parameter type" $ do + mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs + return (c,info) + + _ -> return (c,info) + where + infer = inferLType gr + check = checkLType gr + chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") + comp = computeLType gr + +checkCncInfo :: SourceGrammar -> Ident -> (Ident,SourceAbs) -> + (Ident,Info) -> Check (Ident,Info) +checkCncInfo gr m (a,abs) (c,info) = do + checkReservedId c + case info of + + CncFun _ (Yes trm) mpr -> chIn "linearization of" $ do + typ <- checkErr $ lookupFunTypeSrc gr a c + cat0 <- checkErr $ valCat typ + (cont,val) <- linTypeOfType gr m typ -- creates arg vars + (trm',_) <- check trm (mkFunType (map snd cont) val) -- erases arg vars + checkPrintname gr mpr + cat <- return $ snd cat0 + return (c, CncFun (Just (cat,(cont,val))) (Yes trm') mpr) + -- cat for cf, typ for pe + + CncCat (Yes typ) mdef mpr -> chIn "linearization type of" $ do + typ' <- checkIfLinType gr typ + mdef' <- case mdef of + Yes def -> do + (def',_) <- checkLType gr def (mkFunType [typeStr] typ) + return $ Yes def' + _ -> return mdef + checkPrintname gr mpr + return (c,CncCat (Yes typ') mdef' mpr) + + _ -> return (c,info) + + where + env = gr + infer = inferLType gr + comp = computeLType gr + check = checkLType gr + chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") + +checkIfParType :: SourceGrammar -> Type -> Check () +checkIfParType st typ = checkCond ("Not parameter type" +++ prt typ) (isParType typ) + where + isParType ty = True ---- +{- case ty of + Cn typ -> case lookupConcrete st typ of + Ok (CncParType _ _ _) -> True + Ok (CncOper _ ty' _) -> isParType ty' + _ -> False + Q p t -> case lookupInPackage st (p,t) of + Ok (CncParType _ _ _) -> True + _ -> False + RecType r -> all (isParType . snd) r + _ -> False +-} + +checkIfStrType :: SourceGrammar -> Type -> Check () +checkIfStrType st typ = case typ of + Table arg val -> do + checkIfParType st arg + checkIfStrType st val + _ | typ == typeStr -> return () + _ -> prtFail "not a string type" typ + + +checkIfLinType :: SourceGrammar -> Type -> Check Type +checkIfLinType st typ0 = do + typ <- computeLType st typ0 + case typ of + RecType r -> do + let (lins,ihs) = partition (isLinLabel .fst) r + --- checkErr $ checkUnique $ map fst r + mapM_ checkInh ihs + mapM_ checkLin lins + _ -> prtFail "a linearization type must be a record type instead of" typ + return typ + + where + checkInh (label,typ) = checkIfParType st typ + checkLin (label,typ) = checkIfStrType st typ + + +computeLType :: SourceGrammar -> Type -> Check Type +computeLType gr t = do + g0 <- checkGetContext + let g = [(x, Vr x) | (x,_) <- g0] + checkInContext g $ comp t + where + comp ty = case ty of + + Q m ident -> do + ty' <- checkErr (lookupResDef gr m ident) + if ty' == ty then return ty else comp ty' --- is this necessary to test? + + Vr ident -> checkLookup ident -- never needed to compute! + + App f a -> do + f' <- comp f + a' <- comp a + case f' of + Abs x b -> checkInContext [(x,a')] $ comp b + _ -> return $ App f' a' + + Prod x a b -> do + a' <- comp a + b' <- checkInContext [(x,Vr x)] $ comp b + return $ Prod x a' b' + + Abs x b -> do + b' <- checkInContext [(x,Vr x)] $ comp b + return $ Abs x b' + + ExtR r s -> do + r' <- comp r + s' <- comp s + case (r',s') of + (RecType rs, RecType ss) -> return $ RecType (rs ++ ss) + _ -> return $ ExtR r' s' + + _ | isPredefConstant ty -> return ty + + _ -> composOp comp ty + +checkPrintname :: SourceGrammar -> Perh Term -> Check () +checkPrintname st (Yes t) = checkLType st t typeStr >> return () +checkPrintname _ _ = return () + +-- for grammars obtained otherwise than by parsing ---- update!! +checkReservedId :: Ident -> Check () +checkReservedId x = let c = prt x in + if isResWord c + then checkWarn ("Warning: reserved word used as identifier:" +++ c) + else return () + +-- the underlying algorithms + +inferLType :: SourceGrammar -> Term -> Check (Term, Type) +inferLType gr trm = case trm of + + Q m ident -> checks [ + termWith trm $ checkErr (lookupResType gr m ident) + , + checkErr (lookupResDef gr m ident) >>= infer + , + prtFail "cannot infer type of constant" trm + ] + + QC m ident -> checks [ + termWith trm $ checkErr (lookupResType gr m ident) + , + checkErr (lookupResDef gr m ident) >>= infer + , + prtFail "cannot infer type of canonical constant" trm + ] + + Vr ident -> termWith trm $ checkLookup ident + + App f a -> do + (f',fty) <- infer f + fty' <- comp fty + case fty' of + Prod z arg val -> do + a' <- justCheck a arg + ty <- if isWildIdent z + then return val + else substituteLType [(z,a')] val + return (App f' a',ty) + _ -> prtFail ("function type expected for" +++ prt f +++ "instead of") fty + + S f x -> do + (f', fty) <- infer f + case fty of + Table arg val -> do + x'<- justCheck x arg + return (S f' x', val) + _ -> prtFail "table lintype expected for the table in" trm + + P t i -> do + (t',ty) <- infer t --- ?? + ty' <- comp ty + termWith (P t' i) $ checkErr $ case ty' of + RecType ts -> maybeErr ("unknown label" +++ show i +++ "in" +++ show ty') $ + lookup i ts + _ -> prtBad ("record type expected for" +++ prt t +++ "instead of") ty' + + R r -> do + let (ls,fs) = unzip r + fsts <- mapM inferM fs + let ts = [ty | (Just ty,_) <- fsts] + checkCond ("cannot infer type of record"+++ prt trm) (length ts == length fsts) + return $ (R (zip ls fsts), RecType (zip ls ts)) + + T (TTyped arg) pts -> do + (_,val) <- checks $ map (inferCase (Just arg)) pts + check trm (Table arg val) + T (TComp arg) pts -> do + (_,val) <- checks $ map (inferCase (Just arg)) pts + check trm (Table arg val) + T ti pts -> do -- tries to guess: good in oper type inference + let pts' = [pt | pt@(p,_) <- pts, isConstPatt p] + if null pts' + then prtFail "cannot infer table type of" trm + else do + (arg,val) <- checks $ map (inferCase Nothing) pts' + check trm (Table arg val) + + K s -> do + if elem ' ' s + then checkWarn ("Warning: space in token \"" ++ s ++ + "\". Lexical analysis may fail.") + else return () + return (trm, typeTok) + + EInt i -> return (trm, typeInt) + + Empty -> return (trm, typeTok) + + C s1 s2 -> + check2 (flip justCheck typeStr) C s1 s2 typeStr + + Glue s1 s2 -> + check2 (flip justCheck typeStr) Glue s1 s2 typeStr ---- typeTok + + Strs ts -> do + ts' <- mapM (\t -> justCheck t typeStr) ts + return (Strs ts', typeStrs) + + Alts (t,aa) -> do + t' <- justCheck t typeStr + aa' <- flip mapM aa (\ (c,v) -> do + c' <- justCheck c typeStr + v' <- justCheck v typeStrs + return (c',v')) + return (Alts (t',aa'), typeStr) + + RecType r -> do + let (ls,ts) = unzip r + ts' <- mapM (flip justCheck typeType) ts + return (RecType (zip ls ts'), typeType) + + ExtR r s -> do + (r',rT) <- infer r + rT' <- comp rT + (s',sT) <- infer s + sT' <- comp sT + let trm' = ExtR r' s' + case (rT', sT') of + (RecType rs, RecType ss) -> return (trm', RecType (rs ++ ss)) + _ | rT' == typeType && sT' == typeType -> return (trm', typeType) + _ -> prtFail "records or record types expected in" trm + + Sort _ -> + termWith trm $ return typeType + + Prod x a b -> do + a' <- justCheck a typeType + b' <- checkInContext [(x,a')] $ justCheck b typeType + return (Prod x a' b', typeType) + + Table p t -> do + p' <- justCheck p typeType --- check p partype! + t' <- justCheck t typeType + return $ (Table p' t', typeType) + + FV vs -> do + (ty,_) <- checks $ map infer vs +--- checkIfComplexVariantType trm ty + check trm ty + + _ -> prtFail "cannot infer lintype of" trm + + where + env = gr + infer = inferLType env + comp = computeLType env + + check = checkLType env + + justCheck ty te = check ty te >>= return . fst + + -- for record fields, which may be typed + inferM (mty, t) = do + (t', ty') <- case mty of + Just ty -> check ty t + _ -> infer t + return (Just ty',t') + + inferCase mty (patt,term) = do + arg <- maybe (inferPatt patt) return mty + cont <- pattContext env arg patt + i <- checkUpdates cont + (_,val) <- infer term + checkResets i + return (arg,val) + isConstPatt p = case p of + PC _ ps -> True --- all isConstPatt ps + PP _ _ ps -> True --- all isConstPatt ps + PR ps -> all (isConstPatt . snd) ps + PT _ p -> isConstPatt p + _ -> False + + inferPatt p = case p of + PP q c ps -> checkErr $ lookupResType gr q c >>= valTypeCnc + _ -> infer (patt2term p) >>= return . snd + +checkLType :: SourceGrammar -> Term -> Type -> Check (Term, Type) +checkLType env trm typ0 = do + + typ <- comp typ0 + + case trm of + + Abs x c -> do + case typ of + Prod z a b -> do + checkUpdate (x,a) + (c',b') <- if isWildIdent z + then check c b + else do + b' <- checkIn "abs" $ substituteLType [(z,Vr x)] b + check c b' + checkReset + return $ (Abs x c', Prod x a b') + _ -> prtFail "product expected instead of" typ + + T _ [] -> + prtFail "found empty table in type" typ + T _ cs -> case typ of + Table arg val -> do + case allParamValues env arg of + Ok vs -> do + let ps0 = map fst cs + ps <- checkErr $ testOvershadow ps0 vs + if null ps + then return () + else checkWarn $ "Warning: patterns never reached:" +++ + concat (intersperse ", " (map prt ps)) + + _ -> return () -- happens with variable types + cs' <- mapM (checkCase arg val) cs + return (T (TTyped arg) cs', typ) + _ -> prtFail "table type expected for table instead of" typ + + R r -> case typ of --- why needed? because inference may be too difficult + RecType rr -> do + let (ls,_) = unzip rr -- labels of expected type + fsts <- mapM (checkM r) rr -- check that they are found in the record + return $ (R fsts, typ) -- normalize record + + _ -> prtFail "record type expected in type checking instead of" typ + + ExtR r s -> case typ of + _ | typ == typeType -> do + trm' <- comp trm + case trm' of + RecType _ -> termWith trm $ return typeType + _ -> prtFail "invalid record type extension" trm + RecType rr -> checks [ + do (r',ty) <- infer r + case ty of + RecType rr1 -> do + s' <- justCheck s (minusRecType rr rr1) + return $ (ExtR r' s', typ) + _ -> prtFail "record type expected in extension of" r + , + do (s',ty) <- infer s + case ty of + RecType rr2 -> do + r' <- justCheck r (minusRecType rr rr2) + return $ (ExtR r' s', typ) + _ -> prtFail "record type expected in extension with" s + ] + _ -> prtFail "record extension not meaningful for" typ + + FV vs -> do + ttys <- mapM (flip check typ) vs +--- checkIfComplexVariantType trm typ + return (FV (map fst ttys), typ) --- typ' ? + + S tab arg -> do + (tab',ty) <- infer tab + ty' <- comp ty + case ty' of + Table p t -> do + (arg',val) <- check arg p + checkEq typ t trm + return (S tab' arg', t) + _ -> prtFail "table type expected for applied table instead of" ty' + + Let (x,(mty,def)) body -> case mty of + Just ty -> do + (def',ty') <- check def ty + checkUpdate (x,ty') + body' <- justCheck body typ + checkReset + return (Let (x,(Just ty',def')) body', typ) + _ -> do + (def',ty) <- infer def -- tries to infer type of local constant + check (Let (x,(Just ty,def')) body) typ + + _ -> do + (trm',ty') <- infer trm + termWith trm' $ checkEq typ ty' trm' + where + cnc = env + infer = inferLType env + comp = computeLType env + + check = checkLType env + + justCheck ty te = check ty te >>= return . fst + + checkEq = checkEqLType env + + minusRecType rr rr1 = RecType [(l,v) | (l,v) <- rr, notElem l (map fst rr1)] + + checkM rms (l,ty) = case lookup l rms of + Just (Just ty0,t) -> do + checkEq ty ty0 t + (t',ty') <- check t ty + return (l,(Just ty',t')) + Just (_,t) -> do + (t',ty') <- check t ty + return (l,(Just ty',t')) + _ -> prtFail "cannot find value for label" l + + checkCase arg val (p,t) = do + cont <- pattContext env arg p + i <- checkUpdates cont + t' <- justCheck t val + checkResets i + return (p,t') + +pattContext :: LTEnv -> Type -> Patt -> Check Context +pattContext env typ p = case p of + PV x -> return [(x,typ)] + PP q c ps -> do + t <- checkErr $ lookupResType cnc q c + (cont,v) <- checkErr $ typeFormCnc t + checkCond ("wrong number of arguments for constructor in" +++ prt p) + (length cont == length ps) + checkEqLType env typ v (patt2term p) + mapM (uncurry (pattContext env)) (zip (map snd cont) ps) >>= return . concat + PR r -> do + typ' <- computeLType env typ + case typ' of + RecType t -> do + let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]] + mapM (uncurry (pattContext env)) pts >>= return . concat + _ -> prtFail "record type expected for pattern instead of" typ' + PT t p' -> do + checkEqLType env typ t (patt2term p') + pattContext env typ p' + + _ -> return [] ---- + where + cnc = env + +-- auxiliaries + +type LTEnv = SourceGrammar + +termWith :: Term -> Check Type -> Check (Term, Type) +termWith t ct = do + ty <- ct + return (t,ty) + +-- light-weight substitution for dep. types +substituteLType :: Context -> Type -> Check Type +substituteLType g t = case t of + Vr x -> return $ maybe t id $ lookup x g + _ -> composOp (substituteLType g) t + +-- compositional check/infer of binary operations +check2 :: (Term -> Check Term) -> (Term -> Term -> Term) -> + Term -> Term -> Type -> Check (Term,Type) +check2 chk con a b t = do + a' <- chk a + b' <- chk b + return (con a' b', t) + +checkEqLType :: LTEnv -> Type -> Type -> Term -> Check Type +checkEqLType env t u trm = do + t' <- comp t + u' <- comp u + if alpha [] t' u' + then return t' + else raise ("type of" +++ prt trm +++ + ": expected" +++ prt t' ++ ", inferred" +++ prt u') + where + alpha g t u = case (t,u) of --- quick hack version of TC.eqVal + (Prod x a b, Prod y c d) -> alpha g a c && alpha ((x,y):g) b d + + ---- this should be made in Rename + (Q m a, Q n b) | a == b -> elem m (allExtends env n) + || elem n (allExtends env m) + (QC m a, QC n b) | a == b -> elem m (allExtends env n) + || elem n (allExtends env m) + + (RecType rs, RecType ts) -> and [alpha g a b && l == k --- too strong req + | ((l,a),(k,b)) <- zip rs ts] + || -- if fails, try subtyping: + all (\ (l,a) -> + any (\ (k,b) -> alpha g a b && l == k) ts) rs + + (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) + + sTypes = [typeStr, typeTok, typeString] + comp = computeLType env + +-- linearization types and defaults + +linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type) +linTypeOfType cnc m typ = do + (cont,cat) <- checkErr $ typeSkeleton typ + val <- lookLin cat + args <- mapM mkLinArg (zip [0..] cont) + return (args, val) + where + mkLinArg (i,(n,mc@(m,cat))) = do + val <- lookLin mc + let vars = mkRecType varLabel $ replicate n typeStr + symb = argIdent n cat i + rec <- checkErr $ errIn ("extending" +++ prt vars +++ "with" +++ prt val) $ + plusRecType vars val + return (symb,rec) + lookLin (_,c) = checks [ --- rather: update with defLinType ? + checkErr (lookupLincat cnc m c) >>= computeLType cnc + ,return defLinType + ] + +{- +-- check if a type is complex in variants +-- Not so useful as one might think, since variants of a complex type +-- can be created indirectly: f (variants {True,False}) + +checkIfComplexVariantType :: Term -> Type -> Check () +checkIfComplexVariantType e t = case t of + Prod _ _ _ -> cs + Table _ _ -> cs + RecType (_:_:_) -> cs + _ -> return () + where + cs = case e of + FV (_:_) -> checkWarn $ "Warning:" +++ prt e +++ "has complex type" +++ prt t + _ -> return () + +-} diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs new file mode 100644 index 000000000..1e49946a6 --- /dev/null +++ b/src/GF/Compile/Compile.hs @@ -0,0 +1,207 @@ +module Compile where + +import Grammar +import Ident +import Option +import PrGrammar +import Update +import Lookup +import Modules +import ModDeps +import ReadFiles +import ShellState +import MkResource + +-- the main compiler passes +import GetGrammar +import Rename +import Refresh +import CheckGrammar +import Optimize +import GrammarToCanon +import Share + +import qualified CanonToGrammar as CG + +import qualified GFC +import qualified MkGFC +import GetGFC + +import Operations +import UseIO +import Arch + +import Monad + +-- in batch mode: write code in a file + +batchCompile f = liftM fst $ compileModule defOpts emptyShellState f + where + defOpts = options [beVerbose, emitCode] +batchCompileOpt f = liftM fst $ compileModule defOpts emptyShellState f + where + defOpts = options [beVerbose, emitCode, optimizeCanon] + +batchCompileOld f = compileOld defOpts f + where + defOpts = options [beVerbose, emitCode] + +-- compile with one module as starting point + +compileModule :: Options -> ShellState -> FilePath -> + IOE (GFC.CanonGrammar, (SourceGrammar,[(FilePath,ModTime)])) +compileModule opts st file = do + let ps = pathListOpts opts + ioeIO $ print ps ---- + let putp = putPointE opts + let rfs = readFiles st + files <- getAllFiles ps rfs file + ioeIO $ print files ---- + let names = map (fileBody . justFileName) files + ioeIO $ print names ---- + let env0 = compileEnvShSt st names + (_,sgr,cgr) <- foldM (compileOne opts) env0 files + t <- ioeIO getNowTime + return $ (reverseModules cgr, -- to preserve dependency order + (reverseModules sgr, --- keepResModules opts sgr, --- keep all so far + [(f,t) | f <- files])) -- pass on the time of creation + +compileEnvShSt :: ShellState -> [ModName] -> CompileEnv +compileEnvShSt st fs = (0,sgr,cgr) where + cgr = MGrammar [m | m@(i,_) <- modules (canModules st), notInc i] + sgr = MGrammar [m | m@(i,_) <- modules (srcModules st), notIns i] + notInc i = notElem (prt i) $ map fileBody fs + notIns i = notElem (prt i) $ map fileBody fs + +pathListOpts :: Options -> [InitPath] +pathListOpts opts = maybe [""] pFilePaths $ getOptVal opts pathList + +reverseModules (MGrammar ms) = MGrammar $ reverse ms + +keepResModules :: Options -> SourceGrammar -> SourceGrammar +keepResModules opts gr = + if oElem retainOpers opts + then MGrammar $ reverse [(i,mi) | (i,mi) <- modules gr, isResourceModule mi] + else emptyMGrammar + + +-- the environment + +type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar) + +emptyCompileEnv :: CompileEnv +emptyCompileEnv = (0,emptyMGrammar,emptyMGrammar) + +extendCompileEnvInt (_,MGrammar ss, MGrammar cs) (k,sm,cm) = + return (k,MGrammar (sm:ss), MGrammar (cm:cs)) --- reverse later + +extendCompileEnv (k,s,c) (sm,cm) = extendCompileEnvInt (k,s,c) (k,sm,cm) + +compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv +compileOne opts env file = do + + let putp = putPointE opts + let gf = fileSuffix file + let path = justInitPath file + let name = fileBody file + + case gf of + -- for canonical gf, just read the file and update environment + "gfc" -> do + cm <- putp ("+ reading" +++ file) $ getCanonModule file + sm <- ioeErr $ CG.canon2sourceModule cm + extendCompileEnv env (sm, cm) + + -- for compiled resource, parse and organize, then update environment + "gfr" -> do + sm0 <- putp ("| parsing" +++ file) $ getSourceModule file + let mos = case env of (_,gr,_) -> modules gr + sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm0 + let gfc = gfcFile name + cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc + extendCompileEnv env (sm,cm) + + -- for gf source, do full compilation + _ -> do + sm0 <- putp ("- parsing" +++ file) $ getSourceModule file + (k',sm) <- makeSourceModule opts env sm0 + cm <- putp " generating code... " $ generateModuleCode opts path sm + extendCompileEnvInt env (k',sm,cm) + +-- dispatch reused resource at early stage + +makeSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule) +makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of + + ModMod m -> case mtype m of + MTReuse c -> do + sm <- ioeErr $ makeReuse gr i (extends m) c + let mo2 = (i, ModMod sm) + mos = modules gr + putp " type checking reused" $ ioeErr $ showCheckModule mos mo2 + return $ (k,mo2) + _ -> compileSourceModule opts env mo + where + putp = putPointE opts + +compileSourceModule :: Options -> CompileEnv -> SourceModule -> + IOE (Int,SourceModule) +compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do + + let putp = putPointE opts + mos = modules gr + + mo2:_ <- putp " renaming " $ ioeErr $ renameModule mos mo + + (mo3:_,warnings) <- putp " type checking" $ ioeErr $ showCheckModule mos mo2 + putStrE warnings + + (k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3 + + mo4:_ <- putp " optimizing" $ ioeErr $ evalModule mos mo3r + + return (k',mo4) + +generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule +generateModuleCode opts path minfo@(name,info) = do + let pname = prefixPathName path (prt name) + minfo0 <- ioeErr $ redModInfo minfo + minfo' <- return $ if optim + then shareModule fullOpt minfo0 -- parametrization and sharing + else shareModule basicOpt minfo0 -- sharing only + + -- for resource, also emit gfr + case info of + ModMod m | mtype m == MTResource && emit && nomulti -> do + let (file,out) = (gfrFile pname, prGrammar (MGrammar [minfo])) + ioeIO $ writeFile file out >> putStr (" wrote file" +++ file) + _ -> return () + (file,out) <- do + code <- return $ MkGFC.prCanonModInfo minfo' + return (gfcFile pname, code) + if emit && nomulti + then ioeIO $ writeFile file out >> putStr (" wrote file" +++ file) + else return () + return minfo' + where + nomulti = not $ oElem makeMulti opts + emit = oElem emitCode opts + optim = oElem optimizeCanon opts + +-- for old GF: sort into modules, write files, compile as usual + +compileOld :: Options -> FilePath -> IOE GFC.CanonGrammar +compileOld opts file = do + let putp = putPointE opts + grammar1 <- putp ("- parsing old gf" +++ file) $ getOldGrammar file + files <- mapM writeNewGF $ modules grammar1 + (_,_,grammar) <- foldM (compileOne opts) emptyCompileEnv files + return grammar + +writeNewGF :: SourceModule -> IOE FilePath +writeNewGF m@(i,_) = do + let file = gfFile $ prt i + ioeIO $ writeFile file $ prGrammar (MGrammar [m]) + ioeIO $ putStrLn $ "wrote file" +++ file + return file + diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs new file mode 100644 index 000000000..66a632445 --- /dev/null +++ b/src/GF/Compile/Extend.hs @@ -0,0 +1,77 @@ +module Extend where + +import Grammar +import Ident +import PrGrammar +import Modules +import Update +import Macros +import Operations + +import Monad + +-- AR 14/5/2003 + +-- The top-level function $extendModInfo$ +-- extends a module symbol table by indirections to the module it extends + +extendModInfo :: Ident -> SourceModInfo -> SourceModInfo -> Err SourceModInfo +extendModInfo name old new = case (old,new) of + (ModMod m0, ModMod (Module mt fs _ ops js)) -> do + testErr (mtype m0 == mt) ("illegal extension type at module" +++ show name) + js' <- extendMod name (jments m0) js + return $ ModMod (Module mt fs Nothing ops js) + +-- this is what happens when extending a module: new information is inserted, +-- and the process is interrupted if unification fails + +extendMod :: Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) -> + Err (BinTree (Ident,Info)) +extendMod name old new = + foldM (tryInsert (extendAnyInfo name) (indirInfo name)) new $ tree2list old + +indirInfo :: Ident -> Info -> Info +indirInfo n info = AnyInd b n' where + (b,n') = case info of + ResValue _ -> (True,n) + ResParam _ -> (True,n) + AnyInd b k -> (b,k) + _ -> (False,n) ---- canonical in Abs + +{- ---- +case info of + AbsFun pty ptr -> AbsFun (perhIndir n pty) (perhIndir n ptr) + ---- find a suitable indirection for cat info! + + ResOper pty ptr -> ResOper (perhIndir n pty) (perhIndir n ptr) + ResParam pp -> ResParam (perhIndir n pp) + _ -> info + + CncCat pty ptr ppr -> CncCat (perhIndir n pty) (perhIndir n ptr) (perhIndir n ppr) + CncFun m ptr ppr -> CncFun m (perhIndir n ptr) (perhIndir n ppr) +-} + +perhIndir :: Ident -> Perh a -> Perh a +perhIndir n p = case p of + Yes _ -> May n + _ -> p + +extendAnyInfo :: Ident -> Info -> Info -> Err Info +extendAnyInfo n i j = case (i,j) of + (AbsCat mc1 mf1, AbsCat mc2 mf2) -> + liftM2 AbsCat (updatePerhaps n mc1 mc2) (updatePerhaps n mf1 mf2) --- add cstrs + (AbsFun mt1 md1, AbsFun mt2 md2) -> + liftM2 AbsFun (updatePerhaps n mt1 mt2) (updatePerhaps n md1 md2) --- add defs + + (ResParam mt1, ResParam mt2) -> liftM ResParam $ updatePerhaps n mt1 mt2 + (ResValue mt1, ResValue mt2) -> liftM ResValue $ updatePerhaps n mt1 mt2 + (ResOper mt1 m1, ResOper mt2 m2) -> + liftM2 ResOper (updatePerhaps n mt1 mt2) (updatePerhaps n m1 m2) + + (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> + liftM3 CncCat (updatePerhaps n mc1 mc2) + (updatePerhaps n mf1 mf2) (updatePerhaps n mp1 mp2) + (CncFun m mt1 md1, CncFun _ mt2 md2) -> + liftM2 (CncFun m) (updatePerhaps n mt1 mt2) (updatePerhaps n md1 md2) + + _ -> Bad $ "cannot unify information for" +++ show n diff --git a/src/GF/Compile/GetGrammar.hs b/src/GF/Compile/GetGrammar.hs new file mode 100644 index 000000000..fb3fbf5ad --- /dev/null +++ b/src/GF/Compile/GetGrammar.hs @@ -0,0 +1,71 @@ +module GetGrammar where + +import Operations +import qualified ErrM as E ---- + +import UseIO +import Grammar +import Modules +import PrGrammar +import qualified AbsGF as A +import SourceToGrammar +---- import Macros +---- import Rename +import Option +--- import Custom +import ParGF + +import ReadFiles ---- + +import List (nub) +import Monad (foldM) + +-- this module builds the internal GF grammar that is sent to the type checker + +getSourceModule :: FilePath -> IOE SourceModule +getSourceModule file = do + string <- readFileIOE file + let tokens = myLexer string + mo1 <- ioeErr $ err2err $ pModDef tokens + ioeErr $ transModDef mo1 + + +-- for old GF format with includes + +getOldGrammar :: FilePath -> IOE SourceGrammar +getOldGrammar file = do + defs <- parseOldGrammarFiles file + let g = A.OldGr A.NoIncl defs + ioeErr $ transOldGrammar g file + +parseOldGrammarFiles :: FilePath -> IOE [A.TopDef] +parseOldGrammarFiles file = do + putStrE $ "reading grammar of old format" +++ file + (_, g) <- getImports "" ([],[]) file + return g -- now we can throw away includes + where + getImports oldInitPath (oldImps, oldG) f = do + (path,s) <- readFileLibraryIOE oldInitPath f + if not (elem path oldImps) + then do + (imps,g) <- parseOldGrammar path + foldM (getImports (initFilePath path)) (path : oldImps, g ++ oldG) imps + else + return (oldImps, oldG) + +parseOldGrammar :: FilePath -> IOE ([FilePath],[A.TopDef]) +parseOldGrammar file = do + putStrE $ "reading old file" +++ file + s <- ioeIO $ readFileIf file + A.OldGr incl topdefs <- ioeErr $ err2err $ pOldGrammar $ myLexer $ fixNewlines s + includes <- ioeErr $ transInclude incl + return (includes, topdefs) + +---- + +err2err :: E.Err a -> Err a +err2err (E.Ok v) = Ok v +err2err (E.Bad s) = Bad s + +ioeEErr = ioeErr . err2err + diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs new file mode 100644 index 000000000..d5977b510 --- /dev/null +++ b/src/GF/Compile/GrammarToCanon.hs @@ -0,0 +1,224 @@ +module GrammarToCanon where + +import Operations +import Zipper +import Option +import Grammar +import Ident +import PrGrammar +import Modules +import Macros +import qualified AbsGFC as G +import qualified GFC as C +import MkGFC +---- import Alias +import qualified PrintGFC as P + +import Monad + +-- compilation of optimized grammars to canonical GF. AR 5/10/2001 -- 12/5/2003 + +-- This is the top-level function printing a gfc file + +showGFC :: SourceGrammar -> String +showGFC = err id id . liftM (P.printTree . grammar2canon) . redGrammar + +-- any grammar, first trying without dependent types + +-- abstract syntax without dependent types + +redGrammar :: SourceGrammar -> Err C.CanonGrammar +redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo gr + +redModInfo :: (Ident, SourceModInfo) -> Err (Ident, C.CanonModInfo) +redModInfo (c,info) = do + c' <- redIdent c + info' <- case info of + ModMod m -> do + (e,os) <- redExtOpen m + flags <- mapM redFlag $ flags m + (a,mt) <- case mtype m of + MTConcrete a -> do + a' <- redIdent a + return (a', MTConcrete a') + MTAbstract -> return (c',MTAbstract) --- c' not needed + MTResource -> return (c',MTResource) --- c' not needed + defss <- mapM (redInfo a) $ tree2list $ jments m + defs <- return $ sorted2tree $ concat defss -- sorted, but reduced + return $ ModMod $ Module mt flags e os defs + return (c',info') + where + redExtOpen m = do + e' <- case extends m of + Just e -> liftM Just $ redIdent e + _ -> return Nothing + os' <- mapM (\ (OQualif _ i) -> liftM OSimple (redIdent i)) $ opens m + return (e',os') + +redInfo :: Ident -> (Ident,Info) -> Err [(Ident,C.Info)] +redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do + c' <- redIdent c + case info of + AbsCat (Yes cont) pfs -> do + returns c' $ C.AbsCat cont [] ---- constrs + AbsFun (Yes typ) pdf -> do + returns c' $ C.AbsFun typ (Eqs []) ---- df + + ResParam (Yes ps) -> do + ps' <- mapM redParam ps + returns c' $ C.ResPar ps' + + CncCat pty ptr ppr -> case (pty,ptr) of + (Yes ty, Yes (Abs _ t)) -> do + ty' <- redCType ty + trm' <- redCTerm t + ppr' <- return $ G.FV [] ---- redCTerm + return [(c', C.CncCat ty' trm' ppr')] + _ -> prtBad "cannot reduce rule for" c + + CncFun mt ptr ppr -> case (mt,ptr) of + (Just (cat,_), Yes trm) -> do + cat' <- redIdent cat + (xx,body,_) <- termForm trm + xx' <- mapM redArgvar xx + body' <- errIn (prt body) $ redCTerm body ---- debug + ppr' <- return $ G.FV [] ---- redCTerm + return [(c',C.CncFun (G.CIQ am cat') xx' body' ppr')] + _ -> prtBad ("cannot reduce rule" +++ show info +++ "for") c ---- debug + + AnyInd s b -> do + b' <- redIdent b + returns c' $ C.AnyInd s b' + + _ -> return [] --- retain some operations + where + returns f i = return [(f,i)] + +redQIdent :: QIdent -> Err G.CIdent +redQIdent (m,c) = return $ G.CIQ m c + +redIdent :: Ident -> Err Ident +redIdent x + | isWildIdent x = return $ identC "h_" --- needed in declarations + | otherwise = return $ identC $ prt x --- + +redFlag :: Option -> Err G.Flag +redFlag (Opt (f,[x])) = return $ G.Flg (identC f) (identC x) +redFlag o = Bad $ "cannot reduce option" +++ prOpt o + +redDecl :: Decl -> Err G.Decl +redDecl (x,a) = liftM2 G.Decl (redIdent x) (redType a) + +redType :: Type -> Err G.Exp +redType = redTerm + +redTerm :: Type -> Err G.Exp +redTerm t = return $ rtExp t + +-- resource + +redParam :: Param -> Err G.ParDef +redParam (c,cont) = do + c' <- redIdent c + cont' <- mapM (redCType . snd) cont + return $ G.ParD c' cont' + +redArgvar :: Ident -> Err G.ArgVar +redArgvar x = case x of + IA (x,i) -> return $ G.A (identC x) (toInteger i) + IAV (x,b,i) -> return $ G.AB (identC x) (toInteger b) (toInteger i) + _ -> Bad $ "cannot reduce" +++ show x +++ "as argument variable" + +redLindef :: Term -> Err G.Term +redLindef t = case t of + Abs x b -> redCTerm b --- + _ -> redCTerm t + +redCType :: Type -> Err G.CType +redCType t = case t of + RecType lbs -> do + let (ls,ts) = unzip lbs + ls' = map redLabel ls + ts' <- mapM redCType ts + return $ G.RecType $ map (uncurry G.Lbg) $ zip ls' ts' + Table p v -> liftM2 G.Table (redCType p) (redCType v) + Q m c -> liftM G.Cn $ redQIdent (m,c) + QC m c -> liftM G.Cn $ redQIdent (m,c) + Sort "Str" -> return $ G.TStr + _ -> prtBad "cannot reduce to canonical the type" t + +redCTerm :: Term -> Err G.Term +redCTerm t = case t of + Vr x -> liftM G.Arg $ redArgvar x + App _ _ -> do -- only constructor applications can remain + (_,c,xx) <- termForm t + xx' <- mapM redCTerm xx + case c of + QC p c -> liftM2 G.Con (redQIdent (p,c)) (return xx') + _ -> prtBad "expected constructor head instead of" c + Q p c -> liftM G.I (redQIdent (p,c)) + QC p c -> liftM2 G.Con (redQIdent (p,c)) (return []) + R rs -> do + let (ls,tts) = unzip rs + ls' = map redLabel ls + ts <- mapM (redCTerm . snd) tts + return $ G.R $ map (uncurry G.Ass) $ zip ls' ts + P tr l -> do + tr' <- redCTerm tr + return $ G.P tr' (redLabel l) + T i cs -> do + ty <- getTableType i + ty' <- redCType ty + let (ps,ts) = unzip cs + ps' <- mapM redPatt ps + ts' <- mapM redCTerm ts + return $ G.T ty' $ map (uncurry G.Cas) $ zip (map singleton ps') ts' + S u v -> liftM2 G.S (redCTerm u) (redCTerm v) + K s -> return $ G.K (G.KS s) + C u v -> liftM2 G.C (redCTerm u) (redCTerm v) + FV ts -> liftM G.FV $ mapM redCTerm ts +--- Ready ss -> return $ G.Ready [redStr ss] --- obsolete + + Alts (d,vs) -> do --- + d' <- redCTermTok d + vs' <- mapM redVariant vs + return $ G.K $ G.KP d' vs' + + Empty -> return $ G.E + +--- Strs ss -> return $ G.Strs [s | K s <- ss] --- + +---- Glue obsolete in canon, should not occur here + Glue x y -> redCTerm (C x y) + + _ -> Bad ("cannot reduce term" +++ prt t) + +redPatt :: Patt -> Err G.Patt +redPatt p = case p of + PP m c ps -> liftM2 G.PC (redQIdent (m,c)) (mapM redPatt ps) + PR rs -> do + let (ls,tts) = unzip rs + ls' = map redLabel ls + ts <- mapM redPatt tts + return $ G.PR $ map (uncurry G.PAss) $ zip ls' ts + PT _ q -> redPatt q + _ -> prtBad "cannot reduce pattern" p + +redLabel :: Label -> G.Label +redLabel (LIdent s) = G.L $ identC s +redLabel (LVar i) = G.LV $ toInteger i + +redVariant :: (Term, Term) -> Err G.Variant +redVariant (v,c) = do + v' <- redCTermTok v + c' <- redCTermTok c + return $ G.Var v' c' + +redCTermTok :: Term -> Err [String] +redCTermTok t = case t of + K s -> return [s] + Empty -> return [] + C a b -> liftM2 (++) (redCTermTok a) (redCTermTok b) + Strs ss -> return [s | K s <- ss] --- + _ -> prtBad "cannot get strings from term" t + diff --git a/src/GF/Compile/MkResource.hs b/src/GF/Compile/MkResource.hs new file mode 100644 index 000000000..8b3a01793 --- /dev/null +++ b/src/GF/Compile/MkResource.hs @@ -0,0 +1,75 @@ +module MkResource where + +import Grammar +import Ident +import Modules +import Macros +import PrGrammar + +import Operations + +import Monad + +-- extracting resource r from abstract + concrete syntax +-- AR 21/8/2002 -- 22/6/2003 for GF with modules + +makeReuse :: SourceGrammar -> Ident -> Maybe Ident -> Ident -> Err SourceRes +makeReuse gr r me c = do + mc <- lookupModule gr c + + flags <- return [] --- no flags are passed: they would not make sense + + (ops,jms) <- case mc of + ModMod m -> case mtype m of + MTConcrete a -> do + ma <- lookupModule gr a + jmsA <- case ma of + ModMod m' -> return $ jments m' + _ -> prtBad "expected abstract to be the type of" a + liftM ((,) (opens m)) $ mkResDefs r a me (extends m) jmsA (jments m) + _ -> prtBad "expected concrete to be the type of" c + _ -> prtBad "expected concrete to be the type of" c + + return $ Module MTResource flags me ops jms + +mkResDefs :: Ident -> Ident -> Maybe Ident -> Maybe Ident -> + BinTree (Ident,Info) -> BinTree (Ident,Info) -> + Err (BinTree (Ident,Info)) +mkResDefs r a mext maext abs cnc = mapMTree mkOne abs where + + mkOne (f,info) = case info of + AbsCat _ _ -> do + typ <- err (const (return defLinType)) return $ look f + return (f, ResOper (Yes typeType) (Yes typ)) + AbsFun (Yes typ0) _ -> do + trm <- look f + typ <- redirTyp typ0 --- if isHardType typ0 then compute typ0 else ... + return (f, ResOper (Yes typ) (Yes trm)) + AnyInd b _ -> case mext of + Just ext -> return (f,AnyInd b ext) + _ -> prtBad "no indirection possible in" r + + look f = do + info <- lookupTree prt f cnc + case info of + CncCat (Yes ty) _ _ -> return ty + CncCat _ _ _ -> return defLinType + CncFun _ (Yes tr) _ -> return tr + _ -> prtBad "not enough information to reuse" f + + -- type constant qualifications changed from abstract to resource + redirTyp ty = case ty of + Q n c | n == a -> return $ Q r c + Q n c | Just n == maext -> case mext of + Just ext -> return $ Q ext c + _ -> prtBad "no indirection of type possible in" r + _ -> composOp redirTyp ty + +{- +-- for nicer printing of type signatures: preserves synonyms if not HO/dep type + +isHardType t = case t of + Prod x a b -> not (isWildIdent x) || isHardType a || isHardType b + App _ _ -> True + _ -> False +-} diff --git a/src/GF/Compile/ModDeps.hs b/src/GF/Compile/ModDeps.hs new file mode 100644 index 000000000..2aa042a95 --- /dev/null +++ b/src/GF/Compile/ModDeps.hs @@ -0,0 +1,88 @@ +module ModDeps where + +import Grammar +import Ident +import Option +import PrGrammar +import Update +import Lookup +import Modules + +import Operations + +import Monad + +-- AR 13/5/2003 + +-- to check uniqueness of module names and import names, the +-- appropriateness of import and extend types, +-- to build a dependency graph of modules, and to sort them topologically + +mkSourceGrammar :: [(Ident,SourceModInfo)] -> Err SourceGrammar +mkSourceGrammar ms = do + let ns = map fst ms + checkUniqueErr ns + mapM (checkUniqueImportNames ns . snd) ms + deps <- moduleDeps ms + deplist <- either + return + (\ms -> Bad $ "circular modules" +++ unwords (map show ms)) $ + topoTest deps + return $ MGrammar [(m, maybe undefined id $ lookup m ms) | IdentM m _ <- deplist] + +checkUniqueErr :: (Show i, Eq i) => [i] -> Err () +checkUniqueErr ms = do + let msg = checkUnique ms + if null msg then return () else Bad $ unlines msg + +-- check that import names don't clash with module names + +checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err () +checkUniqueImportNames ns mo = case mo of + ModMod m -> test [n | OQualif n v <- opens m, n /= v] + + where + + test ms = testErr (all (`notElem` ns) ms) + ("import names clashing with module names among" +++ + unwords (map prt ms)) + +-- to decide what modules immediately depend on what, and check if the +-- dependencies are appropriate + +type Dependencies = [(IdentM Ident,[IdentM Ident])] + +moduleDeps :: [(Ident,SourceModInfo)] -> Err Dependencies +moduleDeps ms = mapM deps ms where + deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of + ModMod m -> case mtype m of + MTConcrete a -> do + aty <- lookupModuleType gr a + testErr (aty == MTAbstract) "the for-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 <- case es of + Just e -> liftM singleton $ lookupModuleType gr e + _ -> return [] + testErr (all (compatMType ety) ests) "inappropriate extension module type" + osts <- mapM (lookupModuleType gr . openedModule) os + testErr (all (==oty) osts) "inappropriate open module type" + let ab = case it of + IdentM _ (MTConcrete a) -> [IdentM a MTAbstract] + _ -> [] ---- + return (it, ab ++ + [IdentM e ety | Just e <- [es]] ++ + [IdentM (openedModule o) oty | o <- os]) + + -- check for superficial compatibility, not submodule relation etc + compatMType mt0 mt = case (mt0,mt) of + (MTConcrete _, MTConcrete _) -> True + (MTResourceImpl _, MTResourceImpl _) -> True + (MTReuse _, MTReuse _) -> True + ---- some more + _ -> mt0 == mt + + gr = MGrammar ms --- hack diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs new file mode 100644 index 000000000..c901c3911 --- /dev/null +++ b/src/GF/Compile/Optimize.hs @@ -0,0 +1,171 @@ +module Optimize where + +import Grammar +import Ident +import Modules +import PrGrammar +import Macros +import Lookup +import Refresh +import Compute +import CheckGrammar +import Update + +import Operations +import CheckM + +import Monad +import List + +-- partial evaluation of concrete syntax. AR 6/2001 -- 16/5/2003 +{- +evalGrammar :: SourceGrammar -> Err SourceGrammar +evalGrammar gr = do + gr2 <- refreshGrammar gr + mos <- foldM evalModule [] $ modules gr2 + return $ MGrammar $ reverse mos +-} +evalModule :: [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) -> + Err [(Ident,SourceModInfo)] +evalModule ms mo@(name,mod) = case mod of + + ModMod (Module mt fs me ops js) -> case mt of + MTResource -> do + let deps = allOperDependencies name js + ids <- topoSortOpers deps + MGrammar (mod' : _) <- foldM evalOp gr ids + return $ mod' : ms + MTConcrete a -> do + js' <- mapMTree (evalCncInfo gr0 name a) js + return $ (name, ModMod (Module mt fs me ops js')) : ms + + _ -> return $ (name,mod):ms + where + gr0 = MGrammar $ ms + gr = MGrammar $ (name,mod) : ms + + evalOp g@(MGrammar ((_, ModMod m) : _)) i = do + info <- lookupTree prt i $ jments m + info' <- evalResInfo 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 :: SourceGrammar -> (Ident,Info) -> Err Info +evalResInfo gr (c,info) = case info of + + ResOper pty pde -> eIn "operation" $ do + pde' <- case pde of + Yes de -> liftM yes $ comp de + _ -> return pde + return $ ResOper pty pde' + + _ -> return info + where + comp = computeConcrete gr + eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") + + +evalCncInfo :: + SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info) +evalCncInfo gr cnc abs (c,info) = case info of + + CncCat ptyp pde ppr -> do + + pde' <- case (ptyp,pde) of + (Yes typ, Yes de) -> + liftM yes $ pEval ([(strVar, typeStr)], typ) de + (Yes typ, Nope) -> + liftM yes $ mkLinDefault gr typ >>= pEval ([(strVar, typeStr)],typ) + (May b, Nope) -> + return $ May b + _ -> return pde -- indirection + + ppr' <- return ppr ---- + + return (c, CncCat ptyp pde' ppr') + + CncFun (mt@(Just (_,ty))) pde ppr -> eIn ("linearization in type" +++ + show ty +++ "of") $ do + pde' <- case pde of + Yes de -> do + liftM yes $ pEval ty de + _ -> return pde + ppr' <- case ppr of + Yes pr -> liftM yes $ comp pr + _ -> return ppr + return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed + + _ -> return (c,info) + where + comp = computeConcrete gr + pEval = partEval gr + eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") + +-- the main function for compiling linearizations + +partEval :: SourceGrammar -> (Context,Type) -> Term -> Err Term +partEval gr (context, val) trm = do + let vars = map fst context + args = map Vr vars + subst = [(v, Vr v) | v <- vars] + trm1 = mkApp trm args + trm2 <- etaExpand val trm1 + trm3 <- comp subst trm2 + return $ mkAbs vars trm3 + + where + + comp g t = {- refreshTerm t >>= -} computeTerm gr g t + + etaExpand val t = recordExpand val t --- >>= caseEx -- done by comp + +-- 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 + +allOperDependencies :: Ident -> BinTree (Ident,Info) -> [(Ident,[Ident])] +allOperDependencies m b = + [(f, nub (opty pty ++ opty pt)) | (f, ResOper pty pt) <- tree2list b] + where + opersIn t = case t of + Q n c | n == m -> [c] + _ -> collectOp opersIn t + opty (Yes ty) = opersIn ty + opty _ = [] + +topoSortOpers :: [(Ident,[Ident])] -> Err [Ident] +topoSortOpers st = do + let eops = topoTest st + either return (\ops -> Bad ("circular operations" +++ unwords (map prt (head ops)))) eops + +mkLinDefault :: SourceGrammar -> Type -> Err Term +mkLinDefault gr typ = do + case unComputed typ of + RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign) + _ -> prtBad "linearization type must be a record type, not" typ + where + mkDefField typ = case unComputed typ of + Table p t -> do + t' <- mkDefField t + let T _ cs = mkWildCases t' + return $ T (TWild p) cs + Sort "Str" -> return $ Vr strVar + QC q p -> lookupFirstTag gr q p + RecType r -> do + let (ls,ts) = unzip r + ts' <- mapM mkDefField ts + return $ R $ [assign l t | (l,t) <- zip ls ts'] + _ -> prtBad "linearization type field cannot be" typ + diff --git a/src/GF/Compile/PGrammar.hs b/src/GF/Compile/PGrammar.hs new file mode 100644 index 000000000..06d9fc72e --- /dev/null +++ b/src/GF/Compile/PGrammar.hs @@ -0,0 +1,58 @@ +module PGrammar where + +---import LexGF +import ParGF +import SourceToGrammar +import Grammar +import Ident +import qualified AbsGFC as A +import qualified GFC as G +import GetGrammar +import Macros + +import Operations + +pTerm :: String -> Err Term +pTerm s = do + e <- err2err $ pExp $ myLexer s + transExp e + +pTrm :: String -> Term +pTrm = errVal (vr (zIdent "x")) . pTerm --- + +pTrms :: String -> [Term] +pTrms = map pTrm . sep [] where + sep t cs = case cs of + ',' : cs2 -> reverse t : sep [] cs2 + c : cs2 -> sep (c:t) cs2 + _ -> [reverse t] + +pTrm' :: String -> [Term] +pTrm' = err (const []) singleton . pTerm + +pMeta :: String -> Integer +pMeta _ = 0 --- + +pzIdent :: String -> Ident +pzIdent = zIdent + +{- +string2formsAndTerm :: String -> ([Term],Term) +string2formsAndTerm s = case s of + '[':_:_ -> case span (/=']') s of + (x,_:y) -> (pTrms (tail x), pTrm y) + _ -> ([],pTrm s) + _ -> ([], pTrm s) + +string2ident :: String -> Err Ident +string2ident s = return $ case s of + c:'_':i -> identV (readIntArg i,[c]) --- + _ -> zIdent s + +-- reads the Haskell datatype +readGrammar :: String -> Err GrammarST +readGrammar s = case [x | (x,t) <- reads s, ("","") <- lex t] of + [x] -> return x + [] -> Bad "no parse of Grammar" + _ -> Bad "ambiguous parse of Grammar" +-} diff --git a/src/GF/Compile/PrOld.hs b/src/GF/Compile/PrOld.hs new file mode 100644 index 000000000..acce0ab67 --- /dev/null +++ b/src/GF/Compile/PrOld.hs @@ -0,0 +1,69 @@ +module PrOld where + +import PrGrammar +import CanonToGrammar +import qualified GFC +import Grammar +import Ident +import Macros +import Modules +import qualified PrintGF as P +import GrammarToSource + +import List +import Operations +import UseIO + +-- a hack to print gf2 into gf1 readable files +-- Works only for canonical grammars, printed into GFC. Otherwise we would have +-- problems with qualified names. +--- printnames are not preserved, nor are lindefs + +printGrammarOld :: GFC.CanonGrammar -> String +printGrammarOld gr = err id id $ do + as0 <- mapM canon2sourceModule [im | im@(_,ModMod m) <- modules gr, isModAbs m] + cs0 <- mapM canon2sourceModule + [im | im@(_,ModMod m) <- modules gr, isModCnc m || isModRes m] + as1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) as0 + cs1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) cs0 + return $ unlines $ map prj $ srt as1 ++ srt cs1 + where + js (ModMod m) = jments m + srt = sortBy (\ (i,_) (j,_) -> compare i j) + prj ii = P.printTree $ trAnyDef ii + +stripInfo :: (Ident,Info) -> [(Ident,Info)] +stripInfo (c,i) = case i of + AbsCat (Yes co) (Yes fs) -> rc $ AbsCat (Yes (stripContext co)) nope + AbsFun (Yes ty) (Yes tr) -> rc $ AbsFun (Yes (stripTerm ty)) (Yes(stripTerm tr)) + AbsFun (Yes ty) _ -> rc $ AbsFun (Yes (stripTerm ty)) nope + ResParam (Yes ps) -> rc $ ResParam (Yes [(c,stripContext co) | (c,co)<- ps]) + CncCat (Yes ty) _ _ -> rc $ + CncCat (Yes (stripTerm ty)) nope nope + CncFun _ (Yes tr) _ -> rc $ CncFun Nothing (Yes (stripTerm tr)) nope + _ -> [] + where + rc j = [(c,j)] + +stripContext co = [(x, stripTerm t) | (x,t) <- co] + +stripTerm t = case t of + Q _ c -> Vr c + QC _ c -> Vr c + T ti cs -> T ti' [(stripPattern p, stripTerm c) | (p,c) <- cs] where + ti' = case ti of + TTyped ty -> TTyped $ stripTerm ty + TComp ty -> TComp $ stripTerm ty + TWild ty -> TWild $ stripTerm ty + _ -> ti + _ -> composSafeOp stripTerm t + +stripPattern p = case p of + PC c [] -> PV c + PP _ c [] -> PV c + PC c ps -> PC c (map stripPattern ps) + PP _ c ps -> PC c (map stripPattern ps) + PR lps -> PR [(l, stripPattern p) | (l,p) <- lps] + PT t p -> PT (stripTerm t) (stripPattern p) + _ -> p + diff --git a/src/GF/Compile/RemoveLiT.hs b/src/GF/Compile/RemoveLiT.hs new file mode 100644 index 000000000..0e45be8c0 --- /dev/null +++ b/src/GF/Compile/RemoveLiT.hs @@ -0,0 +1,51 @@ +module RemoveLiT (removeLiT) where + +import Grammar +import Ident +import Modules +import Macros +import Lookup + +import Operations + +import Monad + +-- remove obsolete (Lin C) expressions before doing anything else. AR 21/6/2003 + +-- What the program does is replace the occurrences of Lin C with the actual +-- definition T given in lincat C = T ; with {s : Str} if no lincat is found. +-- The procedule is uncertain, if T contains another Lin. + +removeLiT :: SourceGrammar -> Err SourceGrammar +removeLiT gr = liftM MGrammar $ mapM (remlModule gr) (modules gr) + +remlModule :: SourceGrammar -> (Ident,SourceModInfo) -> Err (Ident,SourceModInfo) +remlModule gr mi@(name,mod) = case mod of + ModMod (Module mt fs me ops js) -> do + js1 <- mapMTree (remlResInfo gr) js + let mod2 = ModMod $ Module mt fs me ops js1 + return $ (name,mod2) + _ -> return mi + +remlResInfo :: SourceGrammar -> (Ident,Info) -> Err (Ident,Info) +remlResInfo gr mi@(i,info) = case info of + ResOper pty ptr -> liftM ((,) i) $ liftM2 ResOper (ren pty) (ren ptr) + CncCat pty ptr ppr -> liftM ((,) i) $ liftM3 CncCat (ren pty) (ren ptr) (ren ppr) + CncFun mt ptr ppr -> liftM ((,) i) $ liftM2 (CncFun mt) (ren ptr) (ren ppr) + _ -> return mi + where + ren = remlPerh gr + +remlPerh gr pt = case pt of + Yes t -> liftM Yes $ remlTerm gr t + _ -> return pt + +remlTerm :: SourceGrammar -> Term -> Err Term +remlTerm gr trm = case trm of + LiT c -> look c >>= remlTerm gr + _ -> composOp (remlTerm gr) trm + where + look c = err (const $ return defLinType) return $ lookupLincat gr m c + m = case [cnc | (cnc,ModMod m) <- modules gr, isModCnc m] of + cnc:_ -> cnc -- actually there is always exactly one + _ -> zIdent "CNC" diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs new file mode 100644 index 000000000..1e45b5fcc --- /dev/null +++ b/src/GF/Compile/Rename.hs @@ -0,0 +1,263 @@ +module Rename where + +import Grammar +import Modules +import Ident +import Macros +import PrGrammar +import Lookup +import Extend +import Operations + +import Monad + +-- 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'. + +renameGrammar :: SourceGrammar -> Err SourceGrammar +renameGrammar g = liftM (MGrammar . reverse) $ foldM renameModule [] (modules g) + +-- this gives top-level access to renaming term input in the cc command +renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term +renameSourceTerm g m t = do + mo <- lookupErr m (modules g) + status <- buildStatus g m mo + renameTerm status [] t + +renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule] +renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of + ModMod (Module mt fs me ops js) -> do + (_,mod1@(ModMod m)) <- extendModule ms (name,mod) + let js1 = jments m + status <- buildStatus (MGrammar ms) name mod1 + js2 <- mapMTree (renameInfo status) js1 + let mod2 = ModMod $ Module mt fs me (map forceQualif ops) js2 + return $ (name,mod2) : ms + +extendModule :: [SourceModule] -> SourceModule -> Err SourceModule +extendModule ms (name,mod) = case mod of + ModMod (Module mt fs me ops js0) -> do + js <- case mt of +{- --- building the {s : Str} lincat + MTConcrete a -> do + ModMod ma <- lookupModule (MGrammar ms) a + let cats = [c | (c,AbsCat _ _) <- tree2list $ jments ma] + jscs = [(c,CncCat (yes defLinType) nope nope) | c <- cats] + return $ updatesTreeNondestr jscs js0 +-} + _ -> return js0 + js1 <- case me of + Just n -> do + m0 <- case lookup n ms of + Just (ModMod m) -> do + testErr (sameMType (mtype m) mt) + ("illegal extension type to module" +++ prt name) + return m + _ -> Bad $ "cannot find extended module" +++ prt n + extendMod n (jments m0) js + _ -> return js + return $ (name,ModMod (Module mt fs Nothing ops js1)) + + +type Status = (StatusTree, [(OpenSpec Ident, StatusTree)]) + +type StatusTree = BinTree (Ident,StatusInfo) + +type StatusInfo = Ident -> Term + +renameIdentTerm :: Status -> Term -> Err Term +renameIdentTerm env@(act,imps) t = case t of + Vr c -> do + f <- lookupTreeMany prt opens c + return $ f c + Cn c -> do + f <- lookupTreeMany prt opens c + return $ f c + Q m' c -> do + m <- lookupErr m' qualifs + f <- lookupTree prt c m + return $ f c + QC m' c -> do + m <- lookupErr m' qualifs + f <- lookupTree prt c m + return $ f c + _ -> return t + where + opens = act : [st | (OSimple _,st) <- imps] + qualifs = [ (m, st) | (OQualif m _, st) <- imps] + +--- would it make sense to optimize this by inlining? +renameIdentPatt :: Status -> Patt -> Err Patt +renameIdentPatt env p = do + let t = patt2term p + t' <- renameIdentTerm env t + term2patt t' + +info2status :: Maybe Ident -> (Ident,Info) -> (Ident,StatusInfo) +info2status mq (c,i) = (c, case i of + AbsFun _ (Yes (Con g)) | g == c -> maybe Con QC mq + ResValue _ -> maybe Con QC mq + ResParam _ -> maybe Con QC mq + AnyInd True m -> maybe Con (const (QC m)) mq + AnyInd False m -> maybe Cn (const (Q m)) mq + _ -> maybe Cn Q mq + ) + +tree2status :: OpenSpec Ident -> BinTree (Ident,Info) -> BinTree (Ident,StatusInfo) +tree2status o = case o of + OSimple i -> mapTree (info2status (Just i)) + OQualif i j -> mapTree (info2status (Just j)) + +buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status +buildStatus gr c mo = let mo' = self2status c mo in case mo of + ModMod m -> do + let ops = opens m + mods <- mapM (lookupModule gr . openedModule) ops + let sts = map modInfo2status $ zip ops mods + return $ if isModCnc m + then (NT, sts) -- the module itself does not define any names + else (mo',sts) -- so the empty ident is not needed + +modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree) +modInfo2status (o,i) = (o,case i of + ModMod m -> tree2status o (jments m) + ) + +self2status :: Ident -> SourceModInfo -> StatusTree +self2status c i = case i of + ModMod m -> mapTree (info2status (Just c)) (jments m) -- qualify internal +--- ModMod m -> mapTree (resInfo2status Nothing) (jments m) +-- change Lookup.qualifAnnot if you change this + +forceQualif o = case o of + OSimple i -> OQualif i i + OQualif _ i -> OQualif i i + +renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info) +renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $ + liftM ((,) i) $ case info of + AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco) + (return pfs) ---- + AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr) + + ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr) + ResParam pp -> liftM ResParam (renPerh (mapM (renameParam status)) pp) + ResValue t -> liftM ResValue (ren t) + CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr) + CncFun mt ptr ppr -> liftM2 (CncFun mt) (ren ptr) (ren ppr) + _ -> return info + where + ren = renPerh rent + rent = renameTerm status [] + +renPerh ren pt = case pt of + Yes t -> liftM Yes $ ren t + _ -> return pt + +renameTerm :: Status -> [Ident] -> Term -> Err Term +renameTerm env vars = ren vars where + ren vs trm = case trm of + Abs x b -> liftM (Abs x) (ren (x:vs) b) + Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b) + Vr x + | elem x vs -> return trm + | otherwise -> renid trm + Cn _ -> renid trm + Con _ -> renid trm + Q _ _ -> renid trm + QC _ _ -> renid trm + +---- Eqs eqs -> Eqs (map (renameEquation consts vs) eqs) + T i cs -> do + i' <- case i of + TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source + _ -> return i + liftM (T i') $ mapM (renCase vs) cs + + Let (x,(m,a)) b -> do + m' <- case m of + Just ty -> liftM Just $ ren vs ty + _ -> return m + a' <- ren vs a + b' <- ren (x:vs) b + return $ Let (x,(m',a')) b' + + P t@(Vr r) l -- for constant t we know it is projection + | elem r vs -> return trm -- var proj first + | otherwise -> case renid (Q r (label2ident l)) of -- qualif second + Ok t -> return t + _ -> liftM (flip P l) $ renid t -- const proj last + + _ -> composOp (ren vs) trm + + renid = renameIdentTerm env + renCase vs (p,t) = do + (p',vs') <- renpatt p + t' <- ren (vs' ++ vs) t + return (p',t') + renpatt = renamePattern env + +-- vars not needed in env, since patterns always overshadow old vars + +renamePattern :: Status -> Patt -> Err (Patt,[Ident]) +renamePattern env patt = case patt of + + PC c ps -> do + c' <- renameIdentTerm env $ Cn c + psvss <- mapM renp ps + let (ps',vs) = unzip psvss + return $ case c' of + QC p d -> (PP p d ps', concat vs) + _ -> (PC c ps', concat vs) + +---- PP p c ps -> (PP p c ps',concat vs') where (ps',vs') = unzip $ map renp ps + + PV x -> case renid patt of + Ok p -> return (p,[]) + _ -> return (patt, [x]) + + PR r -> do + let (ls,ps) = unzip r + psvss <- mapM renp ps + let (ps',vs') = unzip psvss + return (PR (zip ls ps'), concat vs') + + _ -> return (patt,[]) + + where + renp = renamePattern env + renid = renameIdentPatt env + +renameParam :: Status -> (Ident, Context) -> Err (Ident, Context) +renameParam env (c,co) = do + co' <- renameContext env co + return (c,co') + +renameContext :: Status -> Context -> Err Context +renameContext b = renc [] where + renc vs cont = case cont of + (x,t) : xts + | isWildIdent x -> do + t' <- ren vs t + xts' <- renc vs xts + return $ (x,t') : xts' + | otherwise -> do + t' <- ren vs t + let vs' = x:vs + xts' <- renc vs' xts + return $ (x,t') : xts' + _ -> return cont + ren = renameTerm b + +{- +renameEquation :: Status -> [Ident] -> Equation -> Equation +renameEquation b vs (ps,t) = (ps',renameTerm b (concat vs' ++ vs) t) where + (ps',vs') = unzip $ map (renamePattern b vs) ps +-} + diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs new file mode 100644 index 000000000..f24c3b87c --- /dev/null +++ b/src/GF/Compile/ShellState.hs @@ -0,0 +1,338 @@ +module ShellState where + +import Operations +import GFC +import AbsGFC +---import CMacros +import Look +import qualified Modules as M +import qualified Grammar as G +import qualified PrGrammar as P +import CF +import CFIdent +import CanonToCF +import Morphology +import Option +import Ident +import Arch (ModTime) + +-- AR 11/11/2001 -- 17/6/2003 (for modules) ---- unfinished + +-- multilingual state with grammars and options +data ShellState = ShSt { + abstract :: Maybe Ident , -- pointer to actual abstract; nothing in empty st + concrete :: Maybe Ident , -- pointer to primary concrete + concretes :: [(Ident,Ident)], -- list of all concretes + canModules :: CanonGrammar , -- the place where abstracts and concretes reside + srcModules :: G.SourceGrammar , -- the place of saved resource modules + cfs :: [(Ident,CF)] , -- context-free grammars + morphos :: [(Ident,Morpho)], -- morphologies + gloptions :: Options, -- global options + readFiles :: [(FilePath,ModTime)],-- files read + absCats :: [(G.Cat,(G.Context, -- cats, their contexts, + [(G.Fun,G.Type)], -- functions to them, + [((G.Fun,Int),G.Type)]))], -- functions on them + statistics :: [Statistics] -- statistics on grammars + } + +data Statistics = + StDepTypes Bool -- whether there are dependent types + | StBoundVars [G.Cat] -- which categories have bound variables + --- -- etc + deriving (Eq,Ord) + +emptyShellState = ShSt { + abstract = Nothing, + concrete = Nothing, + concretes = [], + canModules = M.emptyMGrammar, + srcModules = M.emptyMGrammar, + cfs = [], + morphos = [], + gloptions = noOptions, + readFiles = [], + absCats = [], + statistics = [] + } + +type Language = Ident +language = identC +prLanguage = prIdent + +-- grammar for one language in a state, comprising its abs and cnc + +data StateGrammar = StGr { + absId :: Ident, + cncId :: Ident, + grammar :: CanonGrammar, + cf :: CF, + morpho :: Morpho + } + +emptyStateGrammar = StGr { + absId = identC "#EMPTY", --- + cncId = identC "#EMPTY", --- + grammar = M.emptyMGrammar, + cf = emptyCF, + morpho = emptyMorpho + } + +-- analysing shell grammar into parts +stateGrammarST = grammar +stateCF = cf +stateMorpho = morpho +stateOptions _ = noOptions ---- + +cncModuleIdST = stateGrammarST + +-- form a shell state from a canonical grammar + +grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState +grammar2shellState opts (gr,sgr) = updateShellState opts emptyShellState (gr,(sgr,[])) + +-- update a shell state from a canonical grammar + +updateShellState :: Options -> ShellState -> + (CanonGrammar,(G.SourceGrammar,[(FilePath,ModTime)])) -> + Err ShellState +updateShellState opts sh (gr,(sgr,rts)) = do + let cgr = M.updateMGrammar (canModules sh) gr + a' = ifNull Nothing (return . last) $ allAbstracts cgr + abstr0 <- case abstract sh of + Just a -> do + --- test that abstract is compatible + return $ Just a + _ -> return a' + let concrs = maybe [] (allConcretes cgr) abstr0 + concr0 = ifNull Nothing (return . last) concrs + notInrts f = notElem f $ map fst rts + cfs <- mapM (canon2cf opts cgr) concrs --- would not need to update all... + + let funs = [] ---- funRulesOf cgr + let cats = [] ---- allCatsOf cgr + let csi = [] ---- +{- + [(c,(co, + [(fun,typ) | (fun,typ) <- funs, compatType tc typ], + funsOnTypeFs compatType funs tc)) + | (c,co) <- cats, let tc = cat2type c] +-} + let deps = True ---- not $ null $ allDepCats cgr + let binds = [] ---- allCatsWithBind cgr + + return $ ShSt { + abstract = abstr0, + concrete = concr0, + concretes = zip concrs concrs, + canModules = cgr, + srcModules = M.updateMGrammar (srcModules sh) sgr, + cfs = zip concrs cfs, + morphos = zip concrs (repeat emptyMorpho), + gloptions = opts, ---- -- global options + readFiles = [ft | ft@(f,_) <- readFiles sh, notInrts f] ++ rts, + absCats = csi, + statistics = [StDepTypes deps,StBoundVars binds] + } + +prShellStateInfo :: ShellState -> String +prShellStateInfo sh = unlines [ + "main abstract : " +++ maybe "(none)" P.prt (abstract sh), + "main concrete : " +++ maybe "(none)" P.prt (concrete sh), + "all concretes : " +++ unwords (map (P.prt . fst) (concretes sh)), + "canonical modules :" +++ unwords (map (P.prt .fst) (M.modules (canModules sh))), + "source modules : " +++ unwords (map (P.prt .fst) (M.modules (srcModules sh))), + "global options : " +++ prOpts (gloptions sh) + ] + + +-- form just one state grammar, if unique, from a canonical grammar + +grammar2stateGrammar :: Options -> CanonGrammar -> Err StateGrammar +grammar2stateGrammar opts gr = do + st <- grammar2shellState opts (gr,M.emptyMGrammar) + concr <- maybeErr "no concrete syntax" $ concrete st + return $ stateGrammarOfLang st concr + +-- all abstract modules +allAbstracts :: CanonGrammar -> [Ident] +allAbstracts gr = [i | (i,M.ModMod m) <- M.modules gr, M.mtype m == M.MTAbstract] + +-- the last abstract in dependency order +greatestAbstract :: CanonGrammar -> Maybe Ident +greatestAbstract gr = case allAbstracts gr of + [] -> Nothing + a -> return $ last a + +-- all concretes for a given abstract +allConcretes :: CanonGrammar -> Ident -> [Ident] +allConcretes gr a = [i | (i,M.ModMod m) <- M.modules gr, M.mtype m== M.MTConcrete a] + +stateGrammarOfLang :: ShellState -> Language -> StateGrammar +stateGrammarOfLang st l = StGr { + absId = maybe (identC "Abs") id (abstract st), --- + cncId = l, + grammar = canModules st, ---- only those needed for l + cf = maybe emptyCF id (lookup l (cfs st)), + morpho = maybe emptyMorpho id (lookup l (morphos st)) + } + +grammarOfLang st = stateGrammarST . stateGrammarOfLang st +cfOfLang st = stateCF . stateGrammarOfLang st +morphoOfLang st = stateMorpho . stateGrammarOfLang st +optionsOfLang st = stateOptions . stateGrammarOfLang st + +-- the last introduced grammar, stored in options, is the default for operations + +firstStateGrammar :: ShellState -> StateGrammar +firstStateGrammar st = errVal emptyStateGrammar $ do + concr <- maybeErr "no concrete syntax" $ concrete st + return $ stateGrammarOfLang st concr + +mkStateGrammar :: ShellState -> Language -> StateGrammar +mkStateGrammar = stateGrammarOfLang + +-- analysing shell state into parts +globalOptions = gloptions +allLanguages = map fst . concretes + +allStateGrammars = map snd . allStateGrammarsWithNames + +allStateGrammarsWithNames st = [(c, mkStateGrammar st c) | (c,_) <- concretes st] + +allGrammarFileNames st = [prLanguage c ++ ".gf" | (c,_) <- concretes st] --- + +{- +allActiveStateGrammarsWithNames (ShSt (ma,gs,_)) = + [(l, mkStateGrammar a c) | (l,((_,True),c)) <- gs, Just a <- [ma]] + + + +allActiveGrammars = map snd . allActiveStateGrammarsWithNames + +allGrammarSTs = map stateGrammarST . allStateGrammars +allCFs = map stateCF . allStateGrammars + +firstGrammarST = stateGrammarST . firstStateGrammar +firstAbstractST = abstractOf . firstGrammarST +firstConcreteST = concreteOf . firstGrammarST +-} +-- command-line option -language=foo overrides the actual grammar in state +grammarOfOptState :: Options -> ShellState -> StateGrammar +grammarOfOptState opts st = + maybe (firstStateGrammar st) (stateGrammarOfLang st . language) $ + getOptVal opts useLanguage + +-- command-line option -cat=foo overrides the possible start cat of a grammar +firstCatOpts :: Options -> StateGrammar -> CFCat +firstCatOpts opts sgr = + maybe (stateFirstCat sgr) (string2CFCat (P.prt (absId sgr))) $ + getOptVal opts firstCat + +-- a grammar can have start category as option startcat=foo ; default is S +stateFirstCat sgr = + maybe (string2CFCat a "S") (string2CFCat a) $ + getOptVal (stateOptions sgr) gStartCat + where + a = P.prt (absId sgr) + +-- the first cat for random generation +firstAbsCat :: Options -> StateGrammar -> G.QIdent +firstAbsCat opts sgr = + maybe (absId sgr, identC "S") (\c -> (absId sgr, identC c)) $ ---- + getOptVal opts firstCat + +{- +-- command-line option -cat=foo overrides the possible start cat of a grammar +stateTransferFun :: StateGrammar -> Maybe Fun +stateTransferFun sgr = getOptVal (stateOptions sgr) transferFun >>= return . zIdent + +stateConcrete = concreteOf . stateGrammarST +stateAbstract = abstractOf . stateGrammarST + +maybeStateAbstract (ShSt (ma,_,_)) = ma +hasStateAbstract = maybe False (const True) . maybeStateAbstract +abstractOfState = maybe emptyAbstractST id . maybeStateAbstract + +stateIsWord sg = isKnownWord (stateMorpho sg) + + +-- getting info on a language +existLang :: ShellState -> Language -> Bool +existLang st lang = elem lang (allLanguages st) + +stateConcreteOfLang :: ShellState -> Language -> StateConcrete +stateConcreteOfLang (ShSt (_,gs,_)) lang = + maybe emptyStateConcrete snd $ lookup lang gs + +fileOfLang :: ShellState -> Language -> FilePath +fileOfLang (ShSt (_,gs,_)) lang = + maybe nonExistingLangFile (fst .fst) $ lookup lang gs + +nonExistingLangFile = "NON-EXISTING LANGUAGE" --- + + +allLangOptions st lang = unionOptions (optionsOfLang st lang) (globalOptions st) + +-- construct state + +stateGrammar st cf mo opts = StGr ((st,cf,mo),opts) + +initShellState ab fs gs opts = + ShSt (Just ab, [(getLangName f, ((f,True),g)) | (f,g) <- zip fs gs], opts) +emptyInitShellState opts = ShSt (Nothing, [], opts) + +-- the second-last part of a file name is the default language name +getLangName :: String -> Language +getLangName file = language (if notElem '.' file then file else langname) where + elif = reverse file + xiferp = tail (dropWhile (/='.') elif) + langname = reverse (takeWhile (flip notElem "./") xiferp) + +-- option -language=foo overrides the default language name +getLangNameOpt :: Options -> String -> Language +getLangNameOpt opts file = + maybe (getLangName file) language $ getOptVal opts useLanguage +-} +-- modify state + +type ShellStateOper = ShellState -> ShellState + +reinitShellState :: ShellStateOper +reinitShellState = const emptyShellState + +{- +languageOn = languageOnOff True +languageOff = languageOnOff False + +languageOnOff :: Bool -> Language -> ShellStateOper +languageOnOff b lang (ShSt (ab,gs,os)) = ShSt (ab, gs', os) where + gs' = [if lang==l then (l,((f,b),g)) else i | i@(l,((f,_),g)) <- gs] + +updateLanguage :: FilePath -> (Language, StateConcrete) -> ShellStateOper +updateLanguage file (lang,gr) (ShSt (ab,gs,os)) = + ShSt (ab, updateAssoc (lang,((file,True),gr)) gs, os') where + os' = changeOptVal os useLanguage (prLanguage lang) -- actualizes the new lang + +initWithAbstract :: AbstractST -> ShellStateOper +initWithAbstract ab st@(ShSt (ma,cs,os)) = + maybe (ShSt (Just ab,cs,os)) (const st) ma + +removeLanguage :: Language -> ShellStateOper +removeLanguage lang (ShSt (ab,gs,os)) = ShSt (ab,removeAssoc lang gs, os) +-} +changeOptions :: (Options -> Options) -> ShellStateOper +changeOptions f (ShSt a c cs can src cfs ms os ff ts ss) = + ShSt a c cs can src cfs ms (f os) ff ts ss + +changeModTimes :: [(FilePath,ModTime)] -> ShellStateOper +changeModTimes mfs (ShSt a c cs can src cfs ms os ff ts ss) = + ShSt a c cs can src cfs ms os ff' ts ss + where + ff' = mfs ++ [mf | mf@(f,_) <- ff, notElem f (map fst mfs)] + +addGlobalOptions :: Options -> ShellStateOper +addGlobalOptions = changeOptions . addOptions + +removeGlobalOptions :: Options -> ShellStateOper +removeGlobalOptions = changeOptions . removeOptions + diff --git a/src/GF/Compile/Update.hs b/src/GF/Compile/Update.hs new file mode 100644 index 000000000..9bc16f03a --- /dev/null +++ b/src/GF/Compile/Update.hs @@ -0,0 +1,98 @@ +module Update where + +import Ident +import Grammar +import PrGrammar +import Modules + +import Operations + +import List +import Monad + +-- update a resource module by adding a new or changing an old definition + +updateRes :: SourceGrammar -> Ident -> Ident -> Info -> SourceGrammar +updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where + upd (n,mod) + | n /= m = (n,mod) + | n == m = case mod of + ModMod r -> (m,ModMod $ updateModule r i info) + _ -> (n,mod) --- no error msg + +-- combine a list of definitions into a balanced binary search tree + +buildAnyTree :: [(Ident,Info)] -> Err (BinTree (Ident, Info)) +buildAnyTree ias = do + ias' <- combineAnyInfos ias + return $ buildTree ias' + + +-- unifying information for abstract, resource, and concrete + +combineAnyInfos :: [(Ident,Info)] -> Err [(Ident,Info)] +combineAnyInfos = combineInfos unifyAnyInfo + +unifyAnyInfo :: Ident -> Info -> Info -> Err Info +unifyAnyInfo c i j = errIn ("combining information for" +++ prt c) $ case (i,j) of + (AbsCat mc1 mf1, AbsCat mc2 mf2) -> + liftM2 AbsCat (unifPerhaps mc1 mc2) (unifPerhaps mf1 mf2) ---- adding constrs + (AbsFun mt1 md1, AbsFun mt2 md2) -> + liftM2 AbsFun (unifPerhaps mt1 mt2) (unifAbsDefs md1 md2) ---- adding defs + + (ResParam mt1, ResParam mt2) -> liftM ResParam $ unifPerhaps mt1 mt2 + (ResOper mt1 m1, ResOper mt2 m2) -> + liftM2 ResOper (unifPerhaps mt1 mt2) (unifPerhaps m1 m2) + + (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> + liftM3 CncCat (unifPerhaps mc1 mc2) (unifPerhaps mf1 mf2) (unifPerhaps mp1 mp2) + (CncFun m mt1 md1, CncFun _ mt2 md2) -> + liftM2 (CncFun m) (unifPerhaps mt1 mt2) (unifPerhaps md1 md2) ---- adding defs + + _ -> Bad $ "cannot unify information for" +++ show i + +--- these auxiliaries should be somewhere else since they don't use the info types + +groupInfos :: Eq a => [(a,b)] -> [[(a,b)]] +groupInfos = groupBy (\i j -> fst i == fst j) + +sortInfos :: Ord a => [(a,b)] -> [(a,b)] +sortInfos = sortBy (\i j -> compare (fst i) (fst j)) + +combineInfos :: Ord a => (a -> b -> b -> Err b) -> [(a,b)] -> Err [(a,b)] +combineInfos f ris = do + let riss = groupInfos $ sortInfos ris + mapM (unifyInfos f) riss + +unifyInfos :: (a -> b -> b -> Err b) -> [(a,b)] -> Err (a,b) +unifyInfos _ [] = Bad "empty info list" +unifyInfos unif ris = do + let c = fst $ head ris + let infos = map snd ris + let ([i],is) = splitAt 1 infos + info <- foldM (unif c) i is + return (c,info) + +tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) -> + BinTree (a,b) -> (a,b) -> Err (BinTree (a,b)) +tryInsert unif indir tree z@(x, info) = case tree of + NT -> return $ BT (x, indir info) NT NT + BT c@(a,info0) left right + | x < a -> do + left' <- tryInsert unif indir left z + return $ BT c left' right + | x > a -> do + right' <- tryInsert unif indir right z + return $ BT c left right' + | x == a -> do + info' <- unif info info0 + return $ BT (x,info') left right + +--- addToMaybeList m c = maybe (return c) (\old -> return (c ++ old)) m + +unifAbsDefs :: Perh Term -> Perh Term -> Err (Perh Term) +unifAbsDefs p1 p2 = case (p1,p2) of + (Nope, _) -> return p2 + (_, Nope) -> return p1 + (Yes (Eqs bs), Yes (Eqs ds)) -> return $ yes $ Eqs $ bs ++ ds --- order! + _ -> Bad "update conflict" diff --git a/src/GF/Data/ErrM.hs b/src/GF/Data/ErrM.hs new file mode 100644 index 000000000..eb2078718 --- /dev/null +++ b/src/GF/Data/ErrM.hs @@ -0,0 +1,7 @@ +module ErrM ( + module Operations +) where + +import Operations + +-- hack for BNFC generated files. AR 21/9/2003 diff --git a/src/GF/Data/Operations.hs b/src/GF/Data/Operations.hs new file mode 100644 index 000000000..7110a7ac0 --- /dev/null +++ b/src/GF/Data/Operations.hs @@ -0,0 +1,559 @@ +module Operations where + +import Char (isSpace, toUpper, isSpace, isDigit) +import List (nub, sortBy, sort, deleteBy, nubBy) +import Monad (liftM2) + +infixr 5 +++ +infixr 5 ++- +infixr 5 ++++ +infixr 5 +++++ +infixl 9 !? + +-- some auxiliary GF operations. AR 19/6/1998 -- 6/2/2001 +-- Copyright (c) Aarne Ranta 1998-2000, under GNU General Public License (see GPL) + +ifNull :: b -> ([a] -> b) -> [a] -> b +ifNull b f xs = if null xs then b else f xs + +-- the Error monad + +data Err a = Ok a | Bad String -- like Maybe type with error msgs + deriving (Read, Show, Eq) + +instance Monad Err where + return = Ok + Ok a >>= f = f a + Bad s >>= f = Bad s + +-- analogue of maybe +err :: (String -> b) -> (a -> b) -> Err a -> b +err d f e = case e of + Ok a -> f a + Bad s -> d s + +-- add msg s to Maybe failures +maybeErr :: String -> Maybe a -> Err a +maybeErr s = maybe (Bad s) Ok + +testErr :: Bool -> String -> Err () +testErr cond msg = if cond then return () else Bad msg + +errVal :: a -> Err a -> a +errVal a = err (const a) id + +errIn :: String -> Err a -> Err a +errIn msg = err (\s -> Bad (s ++++ "OCCURRED IN" ++++ msg)) return + +-- used for extra error reports when developing GF +derrIn :: String -> Err a -> Err a +derrIn m = errIn m -- id + +performOps :: [a -> Err a] -> a -> Err a +performOps ops a = case ops of + f:fs -> f a >>= performOps fs + [] -> return a + +repeatUntilErr :: (a -> Bool) -> (a -> Err a) -> a -> Err a +repeatUntilErr cond f a = if cond a then return a else f a >>= repeatUntilErr cond f + +repeatUntil :: (a -> Bool) -> (a -> a) -> a -> a +repeatUntil cond f a = if cond a then a else repeatUntil cond f (f a) + +okError :: Err a -> a +okError = err (error "no result Ok") id + +isNotError :: Err a -> Bool +isNotError = err (const False) (const True) + +showBad :: Show a => String -> a -> Err b +showBad s a = Bad (s +++ show a) + +lookupErr :: (Eq a,Show a) => a -> [(a,b)] -> Err b +lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs) + +lookupErrMsg :: (Eq a,Show a) => String -> a -> [(a,b)] -> Err b +lookupErrMsg m a abs = maybeErr (m +++ "gave unknown" +++ show a) (lookup a abs) + +lookupDefault :: Eq a => b -> a -> [(a,b)] -> b +lookupDefault d x l = maybe d id $ lookup x l + +updateLookupList :: Eq a => (a,b) -> [(a,b)] -> [(a,b)] +updateLookupList ab abs = insert ab [] abs where + insert c cc [] = cc ++ [c] + insert (a,b) cc ((a',b'):cc') = if a == a' + then cc ++ [(a,b)] ++ cc' + else insert (a,b) (cc ++ [(a',b')]) cc' + +mapPairListM :: Monad m => ((a,b) -> m c) -> [(a,b)] -> m [(a,c)] +mapPairListM f xys = + do yy' <- mapM f xys + return (zip (map fst xys) yy') + +mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] +mapPairsM f xys = + do let (xx,yy) = unzip xys + yy' <- mapM f yy + return (zip xx yy') + +pairM :: Monad a => (b -> a c) -> (b,b) -> a (c,c) +pairM op (t1,t2) = liftM2 (,) (op t1) (op t2) + +-- like mapM, but continue instead of halting with Err +mapErr :: (a -> Err b) -> [a] -> Err ([b], String) +mapErr f xs = Ok (ys, unlines ss) + where + (ys,ss) = ([y | Ok y <- fxs], [s | Bad s <- fxs]) + fxs = map f xs + +-- !! with the error monad +(!?) :: [a] -> Int -> Err a +xs !? i = foldr (const . return) (Bad "too few elements in list") $ drop i xs + +errList :: Err [a] -> [a] +errList = errVal [] + +singleton :: a -> [a] +singleton = (:[]) + +-- checking + +checkUnique :: (Show a, Eq a) => [a] -> [String] +checkUnique ss = ["overloaded" +++ show s | s <- nub overloads] where + overloads = filter overloaded ss + overloaded s = length (filter (==s) ss) > 1 + +titleIfNeeded :: a -> [a] -> [a] +titleIfNeeded a [] = [] +titleIfNeeded a as = a:as + +errMsg :: Err a -> [String] +errMsg (Bad m) = [m] +errMsg _ = [] + +errAndMsg :: Err a -> Err (a,[String]) +errAndMsg (Bad m) = Bad m +errAndMsg (Ok a) = return (a,[]) + +-- a three-valued maybe type to express indirections + +data Perhaps a b = Yes a | May b | Nope deriving (Show,Read,Eq,Ord) + +yes = Yes +may = May +nope = Nope + +mapP :: (a -> c) -> Perhaps a b -> Perhaps c b +mapP f p = case p of + Yes a -> Yes (f a) + May b -> May b + Nope -> Nope + +-- this is what happens when matching two values in the same module +unifPerhaps :: Perhaps a b -> Perhaps a b -> Err (Perhaps a b) +unifPerhaps p1 p2 = case (p1,p2) of + (Nope, _) -> return p2 + (_, Nope) -> return p1 + _ -> Bad "update conflict" + +-- this is what happens when updating a module extension +updatePerhaps :: b -> Perhaps a b -> Perhaps a b -> Err (Perhaps a b) +updatePerhaps old p1 p2 = case (p1,p2) of + (Yes a, Nope) -> return $ may old + (May older,Nope) -> return $ may older + (_, May a) -> Bad "strange indirection" + _ -> unifPerhaps p1 p2 + +-- binary search trees + +data BinTree a = NT | BT a (BinTree a) (BinTree a) deriving (Show,Read) + +isInBinTree :: (Ord a) => a -> BinTree a -> Bool +isInBinTree x tree = case tree of + NT -> False + BT a left right + | x < a -> isInBinTree x left + | x > a -> isInBinTree x right + | x == a -> True + +-- quick method to see if two trees have common elements +-- the complexity is O(log |old|, |new|) so the heuristic is that new is smaller + +commonsInTree :: (Ord a) => BinTree (a,b) -> BinTree (a,b) -> [(a,(b,b))] +commonsInTree old new = foldr inOld [] new' where + new' = tree2list new + inOld (x,v) xs = case justLookupTree x old of + Ok v' -> (x,(v',v)) : xs + _ -> xs + +justLookupTree :: (Ord a) => a -> BinTree (a,b) -> Err b +justLookupTree = lookupTree (const []) + +lookupTree :: (Ord a) => (a -> String) -> a -> BinTree (a,b) -> Err b +lookupTree pr x tree = case tree of + NT -> Bad ("no occurrence of element" +++ pr x) + BT (a,b) left right + | x < a -> lookupTree pr x left + | x > a -> lookupTree pr x right + | x == a -> return b + +lookupTreeEq :: (Ord a) => + (a -> String) -> (a -> a -> Bool) -> a -> BinTree (a,b) -> Err b +lookupTreeEq pr eq x tree = case tree of + NT -> Bad ("no occurrence of element equal to" +++ pr x) + BT (a,b) left right + | eq x a -> return b -- a weaker equality relation than == + | x < a -> lookupTreeEq pr eq x left + | x > a -> lookupTreeEq pr eq x right + +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 + +-- destructive update + +updateTree :: (Ord a) => (a,b) -> BinTree (a,b) -> BinTree (a,b) +updateTree = updateTreeGen True + +-- destructive or not + +updateTreeGen :: (Ord a) => Bool -> (a,b) -> BinTree (a,b) -> BinTree (a,b) +updateTreeGen destr z@(x,y) tree = case tree of + NT -> BT z NT NT + BT c@(a,b) left right + | x < a -> let left' = updateTree z left in BT c left' right + | x > a -> let right' = updateTree z right in BT c left right' + | otherwise -> if destr + then BT z left right -- removing the old value of a + else tree -- retaining the old value if one exists + +updateTreeEq :: + (Ord a) => (a -> a -> Bool) -> (a,b) -> BinTree (a,b) -> BinTree (a,b) +updateTreeEq eq z@(x,y) tree = case tree of + NT -> BT z NT NT + BT c@(a,b) left right + | eq x a -> BT (a,y) left right -- removing the old value of a + | x < a -> let left' = updateTree z left in BT c left' right + | x > a -> let right' = updateTree z right in BT c left right' + +updatesTree :: (Ord a) => [(a,b)] -> BinTree (a,b) -> BinTree (a,b) +updatesTree (z:zs) tr = updateTree z t where t = updatesTree zs tr +updatesTree [] tr = tr + +updatesTreeNondestr :: (Ord a) => [(a,b)] -> BinTree (a,b) -> BinTree (a,b) +updatesTreeNondestr xs tr = case xs of + (z:zs) -> updateTreeGen False z t where t = updatesTreeNondestr zs tr + _ -> tr + +buildTree :: (Ord a) => [(a,b)] -> BinTree (a,b) +buildTree = sorted2tree . sortBy fs where + fs (x,_) (y,_) + | x < y = LT + | x > y = GT + | True = EQ +-- buildTree zz = updatesTree zz NT + +sorted2tree :: [(a,b)] -> BinTree (a,b) +sorted2tree [] = NT +sorted2tree xs = BT x (sorted2tree t1) (sorted2tree t2) where + (t1,(x:t2)) = splitAt (length xs `div` 2) xs + +mapTree :: (a -> b) -> BinTree a -> BinTree b +mapTree f NT = NT +mapTree f (BT a left right) = BT (f a) (mapTree f left) (mapTree f right) + +mapMTree :: Monad m => (a -> m b) -> BinTree a -> m (BinTree b) +mapMTree f NT = return NT +mapMTree f (BT a left right) = do + a' <- f a + left' <- mapMTree f left + right' <- mapMTree f right + return $ BT a' left' right' + +tree2list :: BinTree a -> [a] -- inorder +tree2list NT = [] +tree2list (BT z left right) = tree2list left ++ [z] ++ tree2list right + +depthTree :: BinTree a -> Int +depthTree NT = 0 +depthTree (BT _ left right) = 1 + max (depthTree left) (depthTree right) + +mergeTrees :: Ord a => BinTree (a,b) -> BinTree (a,b) -> BinTree (a,[b]) +mergeTrees old new = foldr upd new' (tree2list old) where + upd xy@(x,y) tree = case tree of + NT -> BT (x,[y]) NT NT + BT (a,bs) left right + | x < a -> let left' = upd xy left in BT (a,bs) left' right + | x > a -> let right' = upd xy right in BT (a,bs) left right' + | otherwise -> BT (a, y:bs) left right -- adding the new value + new' = mapTree (\ (i,d) -> (i,[d])) new + + +-- parsing + +type WParser a b = [a] -> [(b,[a])] -- old Wadler style parser + +wParseResults :: WParser a b -> [a] -> [b] +wParseResults p aa = [b | (b,[]) <- p aa] + +-- printing + +indent :: Int -> String -> String +indent i s = replicate i ' ' ++ s + +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 n s = concat (replicate n s) + +prTList t ss = case ss of + [] -> "" + [s] -> s + s:ss -> s ++ t ++ prTList t ss + +prQuotedString x = "\"" ++ restoreEscapes x ++ "\"" + +prParenth s = if s == "" then "" else "(" ++ s ++ ")" + +prCurly s = "{" ++ s ++ "}" +prBracket s = "[" ++ s ++ "]" + +prArgList xx = prParenth (prTList "," xx) + +prSemicList = prTList " ; " + +prCurlyList = prCurly . prSemicList + +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 +--- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id +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!! + +-- LaTeX code producing functions + +dollar s = '$' : s ++ "$" +mbox s = "\\mbox{" ++ s ++ "}" +ital s = "{\\em" +++ s ++ "}" +boldf s = "{\\bf" +++ s ++ "}" +verbat s = "\\verbat!" ++ s ++ "!" + +mkLatexFile s = begindocument +++++ s +++++ enddocument + +begindocument = + "\\documentclass[a4paper,11pt]{article}" ++++ -- M.F. 25/01-02 + "\\setlength{\\parskip}{2mm}" ++++ + "\\setlength{\\parindent}{0mm}" ++++ + "\\setlength{\\oddsidemargin}{0mm}" ++++ + "\\setlength{\\evensidemargin}{-2mm}" ++++ + "\\setlength{\\topmargin}{-8mm}" ++++ + "\\setlength{\\textheight}{240mm}" ++++ + "\\setlength{\\textwidth}{158mm}" ++++ + "\\begin{document}\n" + +enddocument = + "\n\\end{document}\n" + +sortByLongest :: [[a]] -> [[a]] +sortByLongest = sortBy longer where + longer x y + | x' > y' = LT + | x' < y' = GT + | True = EQ + where + x' = length x + y' = length y + +combinations :: [[a]] -> [[a]] +combinations t = case t of + [] -> [[]] + aa:uu -> [a:u | a <- aa, u <- combinations uu] + +mkTextFile :: String -> IO () +mkTextFile name = do + s <- readFile name + let s' = prelude name ++ "\n\n" ++ heading name ++ "\n" ++ object s + writeFile (name ++ ".hs") s' + where + prelude name = "module " ++ name ++ " where" + heading name = "txt" ++ name ++ " =" + object s = mk s ++ " \"\"" + mk s = unlines [" \"" ++ escs line ++ "\" ++ \"\\n\" ++" | line <- lines s] + escs s = case s of + c:cs | elem c "\"\\" -> '\\' : c : escs cs + c:cs -> c : escs cs + _ -> s + +initFilePath :: FilePath -> FilePath +initFilePath f = reverse (dropWhile (/='/') (reverse f)) + +-- topological sorting with test of cyclicity + +topoTest :: Eq a => [(a,[a])] -> Either [a] [[a]] +topoTest g = if length g' == length g then Left g' else Right (cyclesIn g ++[[]]) + where + g' = topoSort g + +cyclesIn :: Eq a => [(a,[a])] -> [[a]] +cyclesIn deps = nubb $ clean $ filt $ iterFix findDep immediate where + immediate = [[y,x] | (x,xs) <- deps, y <- xs] + findDep chains = [y:x:chain | + x:chain <- chains, (x',xs) <- deps, x' == x, y <- xs, + notElem y (init chain)] + + clean = map remdup + nubb = nubBy (\x y -> y == reverse x) + filt = filter (\xs -> last xs == head xs) + remdup (x:xs) = x : remdup xs' where xs' = dropWhile (==x) xs + remdup [] = [] + + + +topoSort :: Eq a => [(a,[a])] -> [a] +topoSort g = reverse $ tsort 0 [ffs | ffs@(f,_) <- g, inDeg f == 0] [] where + tsort _ [] r = r + tsort k (ffs@(f,fs) : cs) r + | elem f r = tsort k cs r + | k > lx = r + | otherwise = tsort (k+1) cs (f : tsort (k+1) (info fs) r) + info hs = [(f,fs) | (f,fs) <- g, elem f hs] + inDeg f = length [t | (h,hs) <- g, t <- hs, t == f] + lx = length g + +-- the generic fix point iterator + +iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a] +iterFix more start = iter start start + where + iter old new = if (null new') + then old + else iter (new' ++ old) new' + where + new' = filter (`notElem` old) (more new) + +-- association lists + +updateAssoc :: Eq a => (a,b) -> [(a,b)] -> [(a,b)] +updateAssoc ab@(a,b) as = case as of + (x,y): xs | x == a -> (a,b):xs + xy : xs -> xy : updateAssoc ab xs + [] -> [ab] + +removeAssoc :: Eq a => a -> [(a,b)] -> [(a,b)] +removeAssoc a = filter ((/=a) . fst) + +-- chop into separator-separated parts + +chunks :: String -> [String] -> [[String]] +chunks sep ws = case span (/= sep) ws of + (a,_:b) -> a : bs where bs = chunks sep b + (a, []) -> if null a then [] else [a] + +readIntArg :: String -> Int +readIntArg n = if (not (null n) && all isDigit n) then read n else 0 + + +-- state monad with error; from Agda 6/11/2001 + +newtype STM s a = STM (s -> Err (a,s)) + +appSTM :: STM s a -> s -> Err (a,s) +appSTM (STM f) s = f s + +stm :: (s -> Err (a,s)) -> STM s a +stm = STM + +stmr :: (s -> (a,s)) -> STM s a +stmr f = stm (\s -> return (f s)) + +instance Monad (STM s) where + return a = STM (\s -> return (a,s)) + STM c >>= f = STM (\s -> do + (x,s') <- c s + let STM f' = f x + f' s') + +readSTM :: STM s s +readSTM = stmr (\s -> (s,s)) + +updateSTM :: (s -> s) -> STM s () +updateSTM f = stmr (\s -> ((),f s)) + +writeSTM :: s -> STM s () +writeSTM s = stmr (const ((),s)) + +done :: Monad m => m () +done = return () + +class Monad m => ErrorMonad m where + raise :: String -> m a + handle :: m a -> (String -> m a) -> m a + handle_ :: m a -> m a -> m a + handle_ a b = a `handle` (\_ -> b) + +instance ErrorMonad Err where + raise = Bad + handle a@(Ok _) _ = a + handle (Bad i) f = f i + +instance ErrorMonad (STM s) where + raise msg = STM (\s -> raise msg) + handle (STM f) g = STM (\s -> (f s) + `handle` (\e -> let STM g' = (g e) in + g' s)) +-- if the first check fails try another one +checkAgain :: ErrorMonad m => m a -> m a -> m a +checkAgain c1 c2 = handle_ c1 c2 + +checks :: ErrorMonad m => [m a] -> m a +checks [] = raise "no chance to pass" +checks cs = foldr1 checkAgain cs + +allChecks :: ErrorMonad m => [m a] -> m [a] +allChecks ms = case ms of + (m: ms) -> let rs = allChecks ms in handle_ (liftM2 (:) m rs) rs + _ -> return [] + diff --git a/src/GF/Data/OrdMap2.hs b/src/GF/Data/OrdMap2.hs new file mode 100644 index 000000000..f41d33139 --- /dev/null +++ b/src/GF/Data/OrdMap2.hs @@ -0,0 +1,118 @@ + + +-------------------------------------------------- +-- The class of ordered finite maps +-- as described in section 2.2.2 + +-- and an example implementation, +-- derived from the implementation in appendix A.2 + + +module OrdMap2 (OrdMap(..), Map) where + +import List (intersperse) + + +-------------------------------------------------- +-- the class of ordered finite maps + +class OrdMap m where + emptyMap :: Ord s => m s a + (|->) :: Ord s => s -> a -> m s a + isEmptyMap :: Ord s => m s a -> Bool + (?) :: Ord s => m s a -> s -> Maybe a + lookupWith :: Ord s => a -> m s a -> s -> a + mergeWith :: Ord s => (a -> a -> a) -> m s a -> m s a -> m s a + unionMapWith :: Ord s => (a -> a -> a) -> [m s a] -> m s a + makeMapWith :: Ord s => (a -> a -> a) -> [(s,a)] -> m s a + assocs :: Ord s => m s a -> [(s,a)] + ordMap :: Ord s => [(s,a)] -> m s a + mapMap :: Ord s => (a -> b) -> m s a -> m s b + + lookupWith z m s = case m ? s of + Just a -> a + Nothing -> z + + unionMapWith join = union + where union [] = emptyMap + union [xs] = xs + union xyss = mergeWith join (union xss) (union yss) + where (xss, yss) = split xyss + split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys) + split xs = (xs, []) + + +-------------------------------------------------- +-- finite maps as ordered associaiton lists, +-- paired with binary search trees + +data Map s a = Map [(s,a)] (TreeMap s a) + +instance (Eq s, Eq a) => Eq (Map s a) where + Map xs _ == Map ys _ = xs == ys + +instance (Show s, Show a) => Show (Map s a) where + show (Map ass _) = "{" ++ concat (intersperse "," (map show' ass)) ++ "}" + where show' (s,a) = show s ++ "|->" ++ show a + +instance OrdMap Map where + emptyMap = Map [] (makeTree []) + s |-> a = Map [(s,a)] (makeTree [(s,a)]) + + isEmptyMap (Map ass _) = null ass + + Map _ tree ? s = lookupTree s tree + + mergeWith join (Map xss _) (Map yss _) = Map xyss (makeTree xyss) + where xyss = merge xss yss + merge [] yss = yss + merge xss [] = xss + merge xss@(x@(s,x'):xss') yss@(y@(t,y'):yss') + = case compare s t of + LT -> x : merge xss' yss + GT -> y : merge xss yss' + EQ -> (s, join x' y') : merge xss' yss' + + makeMapWith join [] = emptyMap + makeMapWith join [(s,a)] = s |-> a + makeMapWith join xyss = mergeWith join (makeMapWith join xss) (makeMapWith join yss) + where (xss, yss) = split xyss + split (x:y:xys) = let (xs, ys) = split xys in (x:xs, y:ys) + split xs = (xs, []) + + assocs (Map xss _) = xss + ordMap xss = Map xss (makeTree xss) + + mapMap f (Map ass atree) = Map [ (s,f a) | (s,a) <- ass ] (mapTree f atree) + + +-------------------------------------------------- +-- binary search trees +-- for logarithmic lookup time + +data TreeMap s a = Nil | Node (TreeMap s a) s a (TreeMap s a) + +makeTree ass = tree + where + (tree,[]) = sl2bst (length ass) ass + sl2bst 0 ass = (Nil, ass) + sl2bst 1 ((s,a):ass) = (Node Nil s a Nil, ass) + sl2bst n ass = (Node ltree s a rtree, css) + where llen = (n-1) `div` 2 + rlen = n - 1 - llen + (ltree, (s,a):bss) = sl2bst llen ass + (rtree, css) = sl2bst rlen bss + +lookupTree s Nil = Nothing +lookupTree s (Node left s' a right) + = case compare s s' of + LT -> lookupTree s left + GT -> lookupTree s right + EQ -> Just a + +mapTree f Nil = Nil +mapTree f (Node left s a right) = Node (mapTree f left) s (f a) (mapTree f right) + + + + diff --git a/src/GF/Data/OrdSet.hs b/src/GF/Data/OrdSet.hs new file mode 100644 index 000000000..84169a699 --- /dev/null +++ b/src/GF/Data/OrdSet.hs @@ -0,0 +1,111 @@ + + +-------------------------------------------------- +-- The class of ordered sets +-- as described in section 2.2.1 + +-- and an example implementation, +-- derived from the implementation in appendix A.1 + + +module OrdSet (OrdSet(..), Set) where + +import List (intersperse) + + +-------------------------------------------------- +-- the class of ordered sets + +class OrdSet m where + emptySet :: Ord a => m a + unitSet :: Ord a => a -> m a + isEmpty :: Ord a => m a -> Bool + elemSet :: Ord a => a -> m a -> Bool + (<++>) :: Ord a => m a -> m a -> m a + (<\\>) :: Ord a => m a -> m a -> m a + plusMinus :: Ord a => m a -> m a -> (m a, m a) + union :: Ord a => [m a] -> m a + makeSet :: Ord a => [a] -> m a + elems :: Ord a => m a -> [a] + ordSet :: Ord a => [a] -> m a + limit :: Ord a => (a -> m a) -> m a -> m a + + xs <++> ys = fst (plusMinus xs ys) + xs <\\> ys = snd (plusMinus xs ys) + plusMinus xs ys = (xs <++> ys, xs <\\> ys) + + union [] = emptySet + union [xs] = xs + union xyss = union xss <++> union yss + where (xss, yss) = split xyss + split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys) + split xs = (xs, []) + + makeSet xs = union (map unitSet xs) + + limit more start = limit' (start, start) + where limit' (old, new) + | isEmpty new' = old + | otherwise = limit' (plusMinus new' old) + where new' = union (map more (elems new)) + + +-------------------------------------------------- +-- sets as ordered lists, +-- paired with a binary tree + +data Set a = Set [a] (TreeSet a) + +instance Eq a => Eq (Set a) where + Set xs _ == Set ys _ = xs == ys + +instance Ord a => Ord (Set a) where + compare (Set xs _) (Set ys _) = compare xs ys + +instance Show a => Show (Set a) where + show (Set xs _) = "{" ++ concat (intersperse "," (map show xs)) ++ "}" + +instance OrdSet Set where + emptySet = Set [] (makeTree []) + unitSet a = Set [a] (makeTree [a]) + + isEmpty (Set xs _) = null xs + elemSet a (Set _ xt) = elemTree a xt + + plusMinus (Set xs _) (Set ys _) = (Set ps (makeTree ps), Set ms (makeTree ms)) + where (ps, ms) = plm xs ys + plm [] ys = (ys, []) + plm xs [] = (xs, xs) + plm xs@(x:xs') ys@(y:ys') = case compare x y of + LT -> let (ps, ms) = plm xs' ys in (x:ps, x:ms) + GT -> let (ps, ms) = plm xs ys' in (y:ps, ms) + EQ -> let (ps, ms) = plm xs' ys' in (x:ps, ms) + + elems (Set xs _) = xs + ordSet xs = Set xs (makeTree xs) + + +-------------------------------------------------- +-- binary search trees +-- for logarithmic lookup time + +data TreeSet a = Nil | Node (TreeSet a) a (TreeSet a) + +makeTree xs = tree + where (tree,[]) = sl2bst (length xs) xs + sl2bst 0 xs = (Nil, xs) + sl2bst 1 (a:xs) = (Node Nil a Nil, xs) + sl2bst n xs = (Node ltree a rtree, zs) + where llen = (n-1) `div` 2 + rlen = n - 1 - llen + (ltree, a:ys) = sl2bst llen xs + (rtree, zs) = sl2bst rlen ys + +elemTree a Nil = False +elemTree a (Node ltree x rtree) + = case compare a x of + LT -> elemTree a ltree + GT -> elemTree a rtree + EQ -> True + + diff --git a/src/GF/Data/Parsers.hs b/src/GF/Data/Parsers.hs new file mode 100644 index 000000000..165d0f4e7 --- /dev/null +++ b/src/GF/Data/Parsers.hs @@ -0,0 +1,143 @@ +module Parsers where + +import Operations +import Char + + +infixr 2 |||, +|| +infixr 3 *** +infixr 5 .>. +infixr 5 ... +infixr 5 .... +infixr 5 +.. +infixr 5 ..+ +infixr 6 |> +infixr 3 <<< + +-- some parser combinators a` la Wadler and Hutton +-- no longer used in many places in GF + +type Parser a b = [a] -> [(b,[a])] + +parseResults :: Parser a b -> [a] -> [b] +parseResults p s = [x | (x,r) <- p s, null r] + +parseResultErr :: Parser a b -> [a] -> Err b +parseResultErr p s = case parseResults p s of + [x] -> return x + [] -> Bad "no parse" + _ -> Bad "ambiguous" + +(...) :: Parser a b -> Parser a c -> Parser a (b,c) +(p ... q) s = [((x,y),r) | (x,t) <- p s, (y,r) <- q t] + +(.>.) :: Parser a b -> (b -> Parser a c) -> Parser a c +(p .>. f) s = [(c,r) | (x,t) <- p s, (c,r) <- f x t] + +(|||) :: Parser a b -> Parser a b -> Parser a b +(p ||| q) s = p s ++ q s + +(+||) :: Parser a b -> Parser a b -> Parser a b +p1 +|| p2 = take 1 . (p1 ||| p2) + +literal :: (Eq a) => a -> Parser a a +literal x (c:cs) = [(x,cs) | x == c] +literal _ _ = [] + +(***) :: Parser a b -> (b -> c) -> Parser a c +(p *** f) s = [(f x,r) | (x,r) <- p s] + +succeed :: b -> Parser a b +succeed v s = [(v,s)] + +fails :: Parser a b +fails s = [] + +(+..) :: Parser a b -> Parser a c -> Parser a c +p1 +.. p2 = p1 ... p2 *** snd + +(..+) :: Parser a b -> Parser a c -> Parser a b +p1 ..+ p2 = p1 ... p2 *** fst + +(<<<) :: Parser a b -> c -> Parser a c -- return +p <<< v = p *** (\x -> v) + +(|>) :: Parser a b -> (b -> Bool) -> Parser a b +p |> b = p .>. (\x -> if b x then succeed x else fails) + +many :: Parser a b -> Parser a [b] +many p = (p ... many p *** uncurry (:)) +|| succeed [] + +some :: Parser a b -> Parser a [b] +some p = (p ... many p) *** uncurry (:) + +longestOfMany :: Parser a b -> Parser a [b] +longestOfMany p = p .>. (\x -> longestOfMany p *** (x:)) +|| succeed [] + +closure :: (b -> Parser a b) -> (b -> Parser a b) +closure p v = p v .>. closure p ||| succeed v + +pJunk :: Parser Char String +pJunk = longestOfMany (satisfy (\x -> elem x "\n\t ")) + +pJ :: Parser Char a -> Parser Char a +pJ p = pJunk +.. p ..+ pJunk + +pTList :: String -> Parser Char a -> Parser Char [a] +pTList t p = p .... many (jL t +.. p) *** (\ (x,y) -> x:y) -- mod. AR 5/1/1999 + +pTJList :: String -> String -> Parser Char a -> Parser Char [a] +pTJList t1 t2 p = p .... many (literals t1 +.. jL t2 +.. p) *** (uncurry (:)) + +pElem :: [String] -> Parser Char String +pElem l = foldr (+||) fails (map literals l) + +(....) :: Parser Char b -> Parser Char c -> Parser Char (b,c) +p1 .... p2 = p1 ... pJunk +.. p2 + +item :: Parser a a +item (c:cs) = [(c,cs)] +item [] = [] + +satisfy :: (a -> Bool) -> Parser a a +satisfy b = item |> b + +literals :: (Eq a,Show a) => [a] -> Parser a [a] +literals l = case l of + [] -> succeed [] + a:l -> literal a ... literals l *** (\ (x,y) -> x:y) + +lits :: (Eq a,Show a) => [a] -> Parser a [a] +lits ts = literals ts + +jL :: String -> Parser Char String +jL = pJ . lits + +pParenth p = literal '(' +.. pJunk +.. p ..+ pJunk ..+ literal ')' +pCommaList p = pTList "," (pJ p) -- p,...,p +pOptCommaList p = pCommaList p ||| succeed [] -- the same or nothing +pArgList p = pParenth (pCommaList p) ||| succeed [] -- (p,...,p), poss. empty +pArgList2 p = pParenth (p ... jL "," +.. pCommaList p) *** uncurry (:) -- min.2 args + +longestOfSome p = (p ... longestOfMany p) *** (\ (x,y) -> x:y) + +pIdent = pLetter ... longestOfMany pAlphaPlusChar *** uncurry (:) + where alphaPlusChar c = isAlphaNum c || c=='_' || c=='\'' + +pLetter = satisfy (`elem` (['A'..'Z'] ++ ['a'..'z'] ++ + ['À' .. 'Û'] ++ ['à' .. 'û'])) -- no such in Char +pDigit = satisfy isDigit +pLetters = longestOfSome pLetter +pAlphanum = pDigit ||| pLetter +pAlphaPlusChar = pAlphanum ||| satisfy (`elem` "_'") + +pQuotedString = literal '"' +.. pEndQuoted where + pEndQuoted = + literal '"' *** (const []) + +|| (literal '\\' +.. item .>. \ c -> pEndQuoted *** (c:)) + +|| item .>. \ c -> pEndQuoted *** (c:) + +pIntc :: Parser Char Int +pIntc = some (satisfy numb) *** read + where numb x = elem x ['0'..'9'] + diff --git a/src/GF/Data/Str.hs b/src/GF/Data/Str.hs new file mode 100644 index 000000000..743bd71b8 --- /dev/null +++ b/src/GF/Data/Str.hs @@ -0,0 +1,106 @@ +module Str ( + Str (..), Tok (..), --- constructors needed in PrGrammar + str2strings, str2allStrings, str, sstr, sstrV, + isZeroTok, prStr, plusStr, glueStr, + strTok, + allItems +) where + +import Operations +import 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) + +data Tok = + TK String + | TN Ss [(Ss, [String])] -- variants depending on next string + deriving (Eq, Ord, Show, Read) + +-- 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 + +-- 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 t)) as] ++ [s]) + +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 + [] -> [] + +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 = 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/Zipper.hs b/src/GF/Data/Zipper.hs new file mode 100644 index 000000000..d498c5a56 --- /dev/null +++ b/src/GF/Data/Zipper.hs @@ -0,0 +1,172 @@ +module Zipper where + +import Operations + +-- Gérard Huet's zipper (JFP 7 (1997)). AR 10/8/2001 + +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,[]) + +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 (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 t = Loc (t,Top) + +goRoot = tree2loc . loc2tree + +goLast :: Loc a -> Err (Loc a) +goLast = rep goAhead where + rep f s = err (const (return s)) (rep f) (f s) + +-- 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) diff --git a/src/GF/Fudgets/ArchEdit.hs b/src/GF/Fudgets/ArchEdit.hs new file mode 100644 index 000000000..82653595d --- /dev/null +++ b/src/GF/Fudgets/ArchEdit.hs @@ -0,0 +1,16 @@ +module ArchEdit ( + fudlogueEdit, fudlogueWrite, fudlogueWriteUni + ) where + +import CommandF +import UnicodeF + +-- architecture/compiler dependent definitions for unix/ghc, if Fudgets works. +-- If not, use the modules in for-ghci + +fudlogueEdit font = fudlogueEditF ---- +fudlogueWrite = fudlogueWriteU +fudlogueWriteUni _ _ = do + putStrLn "sorry no unicode available in ghc" + + diff --git a/src/GF/Fudgets/CommandF.hs b/src/GF/Fudgets/CommandF.hs new file mode 100644 index 000000000..8bf791a61 --- /dev/null +++ b/src/GF/Fudgets/CommandF.hs @@ -0,0 +1,120 @@ +module CommandF where + +import Operations + +import Session +import Commands + +import Fudgets +import FudgetOps + +import EventF + +-- a graphical shell for any kind of GF with Zipper editing. AR 20/8/2001 + +fudlogueEditF :: CEnv -> IO () +fudlogueEditF env = + fudlogue $ gfSizeP $ shellF ("GF 1.1 Fudget Editor") (gfF env) + +gfF env = nameLayoutF gfLayout $ (gfOutputF env >==< gfCommandF env) >+< quitButF + +( quitN : menusN : newN : transformN : filterN : displayN : + navigateN : viewN : outputN : saveN : _) = map show [1..] + +gfLayout = placeNL verticalP [generics,output,navigate,menus,transform] + where + generics = placeNL horizontalP (map leafNL + [newN,saveN,viewN,displayN,filterN,quitN]) + output = leafNL outputN + navigate = leafNL navigateN + menus = leafNL menusN + transform = leafNL transformN + +gfSizeP = spacerF (sizeS (Point 720 640)) + +gfOutputF env = + ((nameF outputN $ (writeFileF >+< textWindowF)) + >==< + (absF (saveSP "EMPTY") + >==< + (nameF saveN (popupStringInputF "Save" "foo.tmp" "Save to file:") + >+< + mapF (displayJustStateIn env)))) + >==< + mapF Right + +gfCommandF :: CEnv -> F () SState +gfCommandF env = loopCommandsF env >==< getCommandsF env >==< mapF (\_ -> Click) + +loopCommandsF :: CEnv -> F Command SState +loopCommandsF env = loopThroughRightF (mapGfStateF env) (mkMenusF env) + +mapGfStateF :: CEnv -> F (Either Command Command) (Either SState SState) +mapGfStateF env = mapstateF execFC (initSState) where + execFC e0 (Left c) = (e,[Right e,Left e]) where e = execECommand env c e0 + execFC e0 (Right c) = (e,[Left e,Right e]) where e = execECommand env c e0 + +mkMenusF :: CEnv -> F SState Command +mkMenusF env = + nameF menusN $ + labAboveF "Select Action on Subterm" + (mapF fst >==< smallPickListF snd >==< mapF (mkRefineMenu env)) + +getCommandsF env = + newF env >*< + viewF >*< + menuDisplayF env >*< + filterF >*< + navigateF >*< + transformF + +key2command ((key,_),_) = case key of + "Up" -> CBack 1 + "Down" -> CAhead 1 + "Left" -> CPrevMeta + "Right" -> CNextMeta + "space" -> CTop + + "d" -> CDelete + "u" -> CUndo + "v" -> CView + + _ -> CVoid + +transformF = + nameF transformN $ + mapF (either key2command id) >==< (keyboardF $ + placerF horizontalP $ + cPopupStringInputF CRefineParse "Parse" "" "Parse in concrete syntax" >*< + --- to enable Unicode: ("Refine by parsing" `labLeftOfF` writeInputF) + cPopupStringInputF CRefineWithTree "Term" "" "Parse term" >*< + cMenuF "Modify" termCommandMenu >*< + cPopupStringInputF CAlphaConvert "Alpha" "x_0 x" "Alpha convert" >*< + cButtonF CRefineRandom "Random" >*< + cButtonF CUndo "Undo" + ) + +quitButF = nameF quitN $ quitF >==< buttonF "Quit" + +newF env = nameF newN $ cMenuF "New" (newCatMenu env) +menuDisplayF env = nameF displayN $ cMenuF "Menus" $ displayCommandMenu env +filterF = nameF filterN $ cMenuF "Filter" stringCommandMenu + +viewF = nameF viewN $ cButtonF CView "View" + +navigateF = + nameF navigateN $ + placerF horizontalP $ + cButtonF CPrevMeta "?<" >*< + cButtonF (CBack 1) "<" >*< + cButtonF CTop "Top" >*< + cButtonF CLast "Last" >*< + cButtonF (CAhead 1) ">" >*< + cButtonF CNextMeta ">?" + +cButtonF c s = mapF (const c) >==< buttonF s +cMenuF s css = menuF s css >==< mapF (\_ -> CVoid) + +cPopupStringInputF comm lab def msg = + mapF comm >==< popupStringInputF lab def msg >==< mapF (const []) + diff --git a/src/GF/Fudgets/EventF.hs b/src/GF/Fudgets/EventF.hs new file mode 100644 index 000000000..cfcf3e401 --- /dev/null +++ b/src/GF/Fudgets/EventF.hs @@ -0,0 +1,36 @@ +module EventF where +import AllFudgets + +-- The first string is the name of the key (e.g., "Down" for the down arrow key) +-- The modifiers list shift, control and alt keys that were active while the +-- key was pressed. +-- The last string is the text produced by the key (for keys that produce +-- printable characters, empty for control keys). + +type KeyPress = ((String,[Modifiers]),String) + +keyboardF :: F i o -> F i (Either KeyPress o) +keyboardF fud = idRightSP (concatMapSP post) >^^=< oeventF mask fud + where + post (KeyEvent {type'=Pressed,keySym=sym,state=mods,keyLookup=s}) = + [((sym,mods),s)] + post _ = [] + + mask = [KeyPressMask, + EnterWindowMask, LeaveWindowMask -- because of CTT implementation + ] + +-- Output events: +oeventF em fud = eventF em (idLeftF fud) + +-- Feed events to argument fudget: +eventF eventmask = serCompLeftToRightF . groupF startcmds eventK + where + startcmds = [XCmd $ ChangeWindowAttributes [CWEventMask eventmask], + XCmd $ ConfigureWindow [CWBorderWidth 0]] + eventK = K $ mapFilterSP route + where route = message low high + low (XEvt event) = Just (High (Left event)) + low _ = Nothing + high h = Just (High (Right h)) + diff --git a/src/GF/Fudgets/FudgetOps.hs b/src/GF/Fudgets/FudgetOps.hs new file mode 100644 index 000000000..6c4e1a8b2 --- /dev/null +++ b/src/GF/Fudgets/FudgetOps.hs @@ -0,0 +1,47 @@ +module FudgetOps where + +import Fudgets + +-- auxiliary Fudgets for GF syntax editor + +-- save and display + +showAndSaveF fud = (writeFileF >+< textWindowF) >==< saveF fud + +saveF :: F a String -> F (Either String a) (Either (String,String) String) +saveF fud = + absF (saveSP "EMPTY") + >==< + (popupStringInputF "Save" "foo.tmp" "Save to file:" >+< fud) + +saveSP :: String -> SP (Either String String) (Either (String,String) String) +saveSP contents = getSP $ \msg -> case msg of + Left file -> putSP (Left (file,contents)) (saveSP contents) + Right string -> putSP (Right string) (saveSP string) + +textWindowF = writeOutputF + +-- to replace stringInputF by a pop-up slot behind a button +popupStringInputF :: String -> String -> String -> F String String +popupStringInputF label deflt msg = + mapF snd + >==< + (popupSizeP $ stringPopupF deflt) + >==< + mapF (\_ -> (Just msg,Nothing)) + >==< + decentButtonF label + >==< + mapF (\_ -> Click) + +decentButtonF = spacerF (sizeS (Point 80 20)) . buttonF + +popupSizeP = spacerF (sizeS (Point 240 100)) + +--- the Unicode stuff should be inserted here + +writeOutputF = moreF >==< mapF lines + +writeInputF = stringInputF + + diff --git a/src/GF/Fudgets/UnicodeF.hs b/src/GF/Fudgets/UnicodeF.hs new file mode 100644 index 000000000..22a250658 --- /dev/null +++ b/src/GF/Fudgets/UnicodeF.hs @@ -0,0 +1,23 @@ +module UnicodeF where +import Fudgets + +import Operations +import Unicode + +-- AR 12/4/2000, 18/9/2001 (added font parameter) + +fudlogueWriteU :: String -> (String -> String) -> IO () +fudlogueWriteU fn trans = + fudlogue $ + shellF "GF Unicode Output" (writeF fn trans >+< quitButtonF) + +writeF fn trans = writeOutputF fn >==< mapF trans >==< writeInputF fn + +displaySizeP = placerF (spacerP (sizeS (Point 440 500)) verticalP) + +writeOutputF fn = moreF' (setFont fn) >==< justWriteOutputF + +justWriteOutputF = mapF (map (wrapLines 0) . filter (/=[]) . map mkUnicode . lines) + +writeInputF fn = stringInputF' (setShowString mkUnicode . setFont fn) + diff --git a/src/GF/Grammar/AbsCompute.hs b/src/GF/Grammar/AbsCompute.hs new file mode 100644 index 000000000..52a2ca678 --- /dev/null +++ b/src/GF/Grammar/AbsCompute.hs @@ -0,0 +1,64 @@ +module AbsCompute where + +import Operations + +import Abstract +import PrGrammar +import LookAbs +import PatternMatch +import Compute + +import Monad (liftM, liftM2) + +-- computation in abstract syntax w.r.t. explicit definitions. +--- old GF computation; to be updated + +compute :: GFCGrammar -> Exp -> Err Exp +compute = computeAbsTerm + +computeAbsTerm :: GFCGrammar -> Exp -> Err Exp +computeAbsTerm gr = computeAbsTermIn gr [] + +computeAbsTermIn :: GFCGrammar -> [Ident] -> Exp -> Err Exp +computeAbsTermIn gr = compt where + compt vv t = case t of + Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b) + Abs x b -> liftM (Abs x) (compt (x:vv) b) + _ -> do + let t' = beta vv t + (yy,f,aa) <- termForm t' + let vv' = yy ++ vv + aa' <- mapM (compt vv') aa + case look f of + Just (Eqs eqs) -> case findMatch eqs aa' of + Ok (d,g) -> do + let (xs,ts) = unzip g + ts' <- alphaFreshAll vv' ts --- + let g' = zip xs ts' + d' <- compt vv' $ substTerm vv' g' d + return $ mkAbs yy $ d' + _ -> do + return $ mkAbs yy $ mkApp f aa' + Just d -> do + d' <- compt vv' d + da <- ifNull (return d') (compt vv' . mkApp d') aa' + return $ mkAbs yy $ da + _ -> do + return $ mkAbs yy $ mkApp f aa' + + look (Q m f) = case lookupAbsDef gr m f of + Ok (Just (Eqs [])) -> Nothing -- canonical + Ok md -> md + _ -> Nothing + look _ = Nothing + +beta :: [Ident] -> Exp -> Exp +beta vv c = case c of + App (Abs x b) a -> beta vv $ substTerm vv [xvv] (beta (x:vv) b) + where xvv = (x,beta vv a) + App f a -> let (a',f') = (beta vv a, beta vv f) in + (if a'==a && f'==f then id else beta vv) $ App f' a' + Prod x a b -> Prod x (beta vv a) (beta (x:vv) b) + Abs x b -> Abs x (beta (x:vv) b) + _ -> c + diff --git a/src/GF/Grammar/Abstract.hs b/src/GF/Grammar/Abstract.hs new file mode 100644 index 000000000..538fff90b --- /dev/null +++ b/src/GF/Grammar/Abstract.hs @@ -0,0 +1,24 @@ +module Abstract ( + +module Grammar, +module Values, +module Macros, +module Ident, +module MMacros, +module PrGrammar, + +Grammar + + ) where + +import Grammar +import Values +import Macros +import Ident +import MMacros +import PrGrammar + +type Grammar = SourceGrammar --- + + + diff --git a/src/GF/Grammar/AppPredefined.hs b/src/GF/Grammar/AppPredefined.hs new file mode 100644 index 000000000..f59c910b0 --- /dev/null +++ b/src/GF/Grammar/AppPredefined.hs @@ -0,0 +1,51 @@ +module AppPredefined where + +import Operations +import Grammar +import Ident +import PrGrammar (prt) +---- import PGrammar (pTrm) + +-- predefined function definitions. AR 12/3/2003. +-- Type checker looks at signatures in predefined.gf + +appPredefined :: Term -> Term +appPredefined t = case t of + + App f x -> case f of + + -- one-place functions + Q (IC "Predef") (IC f) -> case (f, appPredefined x) of + ("length", K s) -> EInt $ length s + _ -> t + + -- two-place functions + App (Q (IC "Predef") (IC f)) z -> case (f, appPredefined z, appPredefined x) of + ("drop", EInt i, K s) -> K (drop i s) + ("take", EInt i, K s) -> K (take i s) + ("tk", EInt i, K s) -> K (take (max 0 (length s - i)) s) + ("dp", EInt i, K s) -> K (drop (max 0 (length s - i)) s) + ("eqStr",K s, K t) -> if s == t then predefTrue else predefFalse + ("eqInt",EInt i, EInt j) -> if i==j then predefTrue else predefFalse + ("plus", EInt i, EInt j) -> EInt $ i+j + ("show", _, t) -> K $ prt t + ("read", _, K s) -> str2tag s --- because of K, only works for atomic tags + _ -> t + _ -> t + _ -> t + +-- read makes variables into constants + +str2tag :: String -> Term +str2tag s = case s of +---- '\'' : cs -> mkCn $ pTrm $ init cs + _ -> Cn $ IC s --- + where + mkCn t = case t of + Vr i -> Cn i + App c a -> App (mkCn c) (mkCn a) + _ -> t + + +predefTrue = Q (IC "Predef") (IC "PTrue") +predefFalse = Q (IC "Predef") (IC "PFalse") diff --git a/src/GF/Grammar/Compute.hs b/src/GF/Grammar/Compute.hs new file mode 100644 index 000000000..1f1eba28c --- /dev/null +++ b/src/GF/Grammar/Compute.hs @@ -0,0 +1,238 @@ +module Compute where + +import Operations +import Grammar +import Ident +import Str +import PrGrammar +import Modules +import Macros +import Lookup +import Refresh +import PatternMatch + +import AppPredefined + +import List (nub,intersperse) +import Monad (liftM2, liftM) + +-- computation of concrete syntax terms into normal form +-- used mainly for partial evaluation + +computeConcrete :: SourceGrammar -> Term -> Err Term +computeConcrete g t = {- refreshTerm t >>= -} computeTerm g [] t + +computeTerm :: SourceGrammar -> Substitution -> Term -> Err Term +computeTerm gr = comp where + + comp g t = --- errIn ("subterm" +++ prt t) $ --- for debugging + case t of + + Q (IC "Predef") _ -> return t + Q p c -> look p c + + -- if computed do nothing + Computed t' -> return $ unComputed t' + + Vr x -> do + t' <- maybe (prtBad ("no value 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' + + -- beta-convert + App f a -> do + f' <- comp g f + a' <- comp g a + case (f',a') of + (Abs x b,_) -> comp (ext x a' g) b + (FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . FV + (_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . FV + + (Alias _ _ d, _) -> comp g (App d a') + + (S (T i cs) e,_) -> prawitz g i (flip App a') cs e + + _ -> returnC $ appPredefined $ App f' a' + P t l -> do + t' <- comp g t + case t' of + FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . FV + R r -> maybe (prtBad "no value for label" l) (comp g . snd) $ lookup l r + + 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) + ExtR a (R b) -> + case comp g (P (R b) l) of + Ok v -> return v + _ -> comp g (P a l) + + Alias _ _ r -> comp g (P r l) + + S (T i cs) e -> prawitz g i (flip P l) cs e + + _ -> returnC $ P t' l + + 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 . FV + + T _ cc -> case v' of + FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . FV + _ -> case matchPattern cc v' of + Ok (c,g') -> comp (g' ++ g) c + _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t + _ -> return $ S t' v' -- if v' is not canonical + + Alias _ _ d -> comp g (S d v') + + S (T i cs) e -> prawitz g i (flip S v') cs e + + _ -> returnC $ S t' v' + + -- 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 + (_,K "") -> return x + (K "",_) -> return y + (K a, K b) -> return $ K (a ++ b) + (K a, Alts (d,vs)) -> do + let glx = Glue x + comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs]) + (Alts _, K a) -> do + x' <- strsFromTerm x + return $ variants [ + foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x'] + _ -> 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 + returnC $ case (a',b') of + (Empty,_) -> b' + (_,Empty) -> a' + _ -> C a' b' + + -- reduce free variation as much as you can + FV [t] -> comp g t + + -- 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) -> return $ R (rs ++ ss) + (RecType rs, RecType ss) -> return $ RecType (rs ++ ss) + _ -> return $ ExtR r' s' + + -- case-expand tables + T i cs -> do + pty0 <- getTableType i + ptyp <- comp g pty0 + case allParamValues gr ptyp of + Ok vs -> do + + cs' <- mapM (compBranchOpt g) cs + sts <- mapM (matchPattern cs') vs + ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts + ps <- mapM term2patt vs + let ps' = ps --- PT ptyp (head ps) : tail ps + return $ T (TComp ptyp) (zip ps' ts) + _ -> do + cs' <- mapM (compBranch g) cs + return $ T i cs' -- happens with variable types + + Alias c a d -> do + d' <- comp g d + return $ Alias c a d' -- alias only disappears in certain redexes + + -- otherwise go ahead + _ -> composOp (comp g) t >>= returnC + + where + + look = lookupResDef gr + + ext x a g = (x,a):g + + returnC = return --- . computed + + variants [t] = t + variants ts = FV ts + + isCan v = case v of + Con _ -> True + QC _ _ -> True + App f a -> isCan f && isCan a + R rs -> all (isCan . snd . snd) rs + _ -> False + + compBranch g (p,v) = do + let g' = contP p ++ g + v' <- comp g' v + return (p,v') + + compBranchOpt g c@(p,v) = case contP p of + [] -> return c + _ -> err (const (return c)) return $ compBranch g c + + contP p = case p of + PV x -> [(x,Vr x)] + PC _ ps -> concatMap contP ps + PP _ _ ps -> concatMap contP ps + PT _ p -> contP p + PR rs -> concatMap (contP . snd) rs + _ -> [] + + 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 -> Err Term +checkNoArgVars t = case t of + Vr (IA _) -> prtBad "cannot glue (+) term with run-time variable" t + Vr (IAV _) -> prtBad "cannot glue (+) term with run-time variable" t + _ -> composOp checkNoArgVars t diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs new file mode 100644 index 000000000..1ee5425c4 --- /dev/null +++ b/src/GF/Grammar/Grammar.hs @@ -0,0 +1,154 @@ +module Grammar where + +import Str +import Ident +import Option --- +import Modules + +import Operations + +-- AR 23/1/2000 -- 30/5/2001 -- 4/5/2003 + +-- grammar as presented to the compiler + +type SourceGrammar = MGrammar Ident Option Info + +type SourceModInfo = ModInfo Ident Option Info + +type SourceModule = (Ident, SourceModInfo) + +type SourceAbs = Module Ident Option Info +type SourceRes = Module Ident Option Info +type SourceCnc = Module Ident Option Info + +-- judgements in abstract syntax + +data Info = + AbsCat (Perh Context) (Perh [Fun]) -- constructors + | AbsFun (Perh Type) (Perh Term) -- Yes f = canonical + | AbsTrans Ident + +-- judgements in resource + | ResParam (Perh [Param]) + | ResValue (Perh Type) -- to mark parameter constructors for lookup + | ResOper (Perh Type) (Perh Term) + +-- judgements in concrete syntax + | CncCat (Perh Type) (Perh Term) MPr -- lindef ini'zed, + | CncFun (Maybe (Ident,(Context,Type))) (Perh Term) MPr -- type info added at TC + +-- indirection to module Ident; the Bool says if canonical + | AnyInd Bool Ident + deriving (Read, Show) + +type Perh a = Perhaps a Ident -- to express indirection to other module + +type MPr = Perhaps Term Ident -- printname + +type Type = Term +type Cat = QIdent +type Fun = QIdent + +type QIdent = (Ident,Ident) + +data Term = + Vr Ident -- variable + | Cn Ident -- constant + | Con Ident -- constructor + | Sort String -- basic type + | EInt Int -- integer literal + | K String -- string literal or token: "foo" + | Empty -- the empty string [] + + | App Term Term -- application: f a + | Abs Ident Term -- abstraction: \x -> b + | Meta MetaSymb -- metavariable: ?i (only parsable: ? = ?0) + | Prod Ident Term Term -- function type: (x : A) -> B + | Eqs [Equation] -- abstraction by cases: fn {x y -> b ; z u -> c} + -- only used in internal representation + | Typed Term Term -- type-annotated term + + | ECase Term [Branch] -- case expression in abstract syntax à la Alfa + +-- below this only for concrete syntax + | 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 ; ...} + | S Term Term -- selection: t ! p + + | Let LocalDef Term -- local definition: let {t : T = a} in b + + | Alias Ident Type Term -- constant and its definition, used in inlining + + | Q Ident Ident -- qualified constant from a package + | QC Ident Ident -- qualified constructor from a package + + | C Term Term -- concatenation: s ++ t + | Glue Term Term -- agglutination: s + t + + | 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 ; ...} + + --- these three are obsolete + | LiT Ident -- linearization type + | Ready Str -- result of compiling; not to be parsed ... + | Computed Term -- result of computing: not to be reopened nor parsed + + deriving (Read, Show, Eq, Ord) + +data Patt = + PC Ident [Patt] -- constructor pattern: C p1 ... pn C + | PP Ident Ident [Patt] -- package constructor pattern: P.C p1 ... pn P.C + | PV Ident -- variable pattern: x + | PW -- wild card pattern: _ + | PR [(Label,Patt)] -- record pattern: {r = p ; ...} -- only concrete + | PString String -- string literal pattern: "foo" -- only abstract + | PInt Int -- integer literal pattern: 12 -- only abstract + | PT Type Patt -- type-annotated pattern + deriving (Read, Show, Eq, Ord) + +-- to guide computation and type checking of tables +data TInfo = + TRaw -- received from parser; can be anything + | TTyped Type -- type annontated, but can be anything + | TComp Type -- expanded + | TWild Type -- just one wild card pattern, no need to expand + deriving (Read, Show, Eq, Ord) + +data Label = + LIdent String + | LVar Int + deriving (Read, Show, Eq, Ord) -- record label + +newtype MetaSymb = MetaSymb Int deriving (Read, Show, Eq, Ord) + +type Decl = (Ident,Term) -- (x:A) (_:A) A +type Context = [Decl] -- (x:A)(y:B) (x,y:A) (_,_:A) +type Equation = ([Patt],Term) + +type Labelling = (Label, Term) +type Assign = (Label, (Maybe Type, Term)) +type Case = (Patt, Term) +type LocalDef = (Ident, (Maybe Type, Term)) + +type Param = (Ident, Context) +type Altern = (Term, [(Term, Term)]) + +type Substitution = [(Ident, Term)] + +-- branches à la Alfa +newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read) +type Con = Ident --- + +varLabel = LVar + +wildPatt :: Patt +wildPatt = PV wildIdent + +type Trm = Term diff --git a/src/GF/Grammar/LookAbs.hs b/src/GF/Grammar/LookAbs.hs new file mode 100644 index 000000000..5e0994d46 --- /dev/null +++ b/src/GF/Grammar/LookAbs.hs @@ -0,0 +1,125 @@ +module LookAbs where + +import Operations +import qualified GFC as C +import Abstract +import Ident + +import Modules + +import List (nub) +import Monad + +type GFCGrammar = C.CanonGrammar + +lookupAbsDef :: GFCGrammar -> Ident -> Ident -> Err (Maybe Term) +lookupAbsDef gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + C.AbsFun _ t -> return $ return t + C.AnyInd _ n -> lookupAbsDef gr n c + _ -> return Nothing + _ -> Bad $ prt m +++ "is not an abstract module" + +lookupFunType :: GFCGrammar -> Ident -> Ident -> Err Type +lookupFunType gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + C.AbsFun t _ -> return t + C.AnyInd _ n -> lookupFunType gr n c + _ -> prtBad "cannot find type of" c + _ -> Bad $ prt m +++ "is not an abstract module" + +lookupCatContext :: GFCGrammar -> Ident -> Ident -> Err Context +lookupCatContext gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + C.AbsCat co _ -> return co + C.AnyInd _ n -> lookupCatContext gr n c + _ -> prtBad "unknown category" c + _ -> Bad $ prt m +++ "is not an abstract module" + +---- should be revised (20/9/2003) +isPrimitiveFun :: GFCGrammar -> Fun -> Bool +isPrimitiveFun gr (m,c) = case lookupAbsDef gr m c of + Ok (Just (Eqs [])) -> True -- is canonical + Ok (Just _) -> False -- has defining clauses + _ -> True -- has no definition + + +-- looking up refinement terms + +lookupRef :: GFCGrammar -> Binds -> Term -> Err Val +lookupRef gr binds at = case at of + Q m f -> lookupFunType gr m f >>= return . vClos + Vr i -> maybeErr ("unknown variable" +++ prt at) $ lookup i binds + _ -> prtBad "cannot refine with complex term" at --- + +refsForType :: (Val -> Type -> Bool) -> GFCGrammar -> Binds -> Val -> [(Term,Val)] +refsForType compat gr binds val = + [(vr i, t) | (i,t) <- binds, Ok ty <- [val2exp t], compat val ty] ++ + [(qq f, vClos t) | (f,t) <- funsForType compat gr val] + + +funRulesOf :: GFCGrammar -> [(Fun,Type)] +funRulesOf gr = +---- funRulesForLiterals ++ + [((i,f),typ) | (i, ModMod m) <- modules gr, + mtype m == MTAbstract, + (f, C.AbsFun typ _) <- tree2list (jments m)] + +allCatsOf :: GFCGrammar -> [(Cat,Context)] +allCatsOf gr = + [((i,c),cont) | (i, ModMod m) <- modules gr, + isModAbs m, + (c, C.AbsCat cont _) <- tree2list (jments m)] + +funsForType :: (Val -> Type -> Bool) -> GFCGrammar -> Val -> [(Fun,Type)] +funsForType compat gr val = [(fun,typ) | (fun,typ) <- funRulesOf gr, + compat val typ] + +funsOnType :: (Val -> Type -> Bool) -> GFCGrammar -> Val -> [((Fun,Int),Type)] +funsOnType compat gr = funsOnTypeFs compat (funRulesOf gr) + +funsOnTypeFs :: (Val -> Type -> Bool) -> [(Fun,Type)] -> Val -> [((Fun,Int),Type)] +funsOnTypeFs compat fs val = [((fun,i),typ) | + (fun,typ) <- fs, + Ok (args,_,_) <- [typeForm typ], + (i,arg) <- zip [0..] (map snd args), + compat val arg] + + +-- this is needed at compile time + +lookupFunTypeSrc :: Grammar -> Ident -> Ident -> Err Type +lookupFunTypeSrc gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + AbsFun (Yes t) _ -> return t + AnyInd _ n -> lookupFunTypeSrc gr n c + _ -> prtBad "cannot find type of" c + _ -> Bad $ prt m +++ "is not an abstract module" + +lookupCatContextSrc :: Grammar -> Ident -> Ident -> Err Context +lookupCatContextSrc gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + AbsCat (Yes co) _ -> return co + AnyInd _ n -> lookupCatContextSrc gr n c + _ -> prtBad "unknown category" c + _ -> Bad $ prt m +++ "is not an abstract module" diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs new file mode 100644 index 000000000..b8afbc21e --- /dev/null +++ b/src/GF/Grammar/Lookup.hs @@ -0,0 +1,393 @@ +module Lookup where + +import Operations +import Abstract +import Modules + +import List (nub) +import Monad + +-- lookup in resource and concrete in compiling; for abstract, use Look + +lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term +lookupResDef gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + ResOper _ (Yes t) -> return $ qualifAnnot m t + AnyInd _ n -> lookupResDef gr n c + ResParam _ -> return $ QC m c + ResValue _ -> return $ QC m c + _ -> Bad $ prt c +++ "is not defined in resource" +++ prt m + _ -> Bad $ prt m +++ "is not a resource" + +lookupResType :: SourceGrammar -> Ident -> Ident -> Err Type +lookupResType gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + ResOper (Yes t) _ -> return $ qualifAnnot m t + AnyInd _ n -> lookupResType gr n c + ResParam _ -> return $ typePType + ResValue (Yes t) -> return $ qualifAnnotPar m t + _ -> Bad $ prt c +++ "has no type defined in resource" +++ prt m + _ -> Bad $ prt m +++ "is not a resource" + +lookupParams :: SourceGrammar -> Ident -> Ident -> Err [Param] +lookupParams gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + ResParam (Yes ps) -> return ps + AnyInd _ n -> lookupParams gr n c + _ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m + _ -> Bad $ prt m +++ "is not a resource" + +lookupParamValues :: SourceGrammar -> Ident -> Ident -> Err [Term] +lookupParamValues gr m c = do + ps <- lookupParams gr m c + liftM concat $ mapM mkPar ps + where + mkPar (f,co) = do + vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gr ty) co + return $ map (mkApp (QC m f)) vs + +lookupFirstTag :: SourceGrammar -> Ident -> Ident -> Err Term +lookupFirstTag gr m c = do + vs <- lookupParamValues gr m c + case vs of + v:_ -> return v + _ -> prtBad "no parameter values given to type" c + +allParamValues :: SourceGrammar -> Type -> Err [Term] +allParamValues cnc ptyp = case ptyp of + QC p c -> lookupParamValues cnc p c + RecType r -> do + let (ls,tys) = unzip r + tss <- mapM allPV tys + return [R (zipAssign ls ts) | ts <- combinations tss] + _ -> prtBad "cannot find parameter values for" ptyp + where + allPV = allParamValues cnc + +qualifAnnot :: Ident -> Term -> Term +qualifAnnot _ = id +-- Using this we wouldn't have to annotate constants defined in a module itself. +-- But things are simpler if we do (cf. Zinc). +-- Change Rename.self2status to change this behaviour. + +-- we need this for lookup in ResVal +qualifAnnotPar m t = case t of + Cn c -> Q m c + Con c -> QC m c + _ -> composSafeOp (qualifAnnotPar m) t + + +lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type +lookupLincat gr m c = do + mi <- lookupModule gr m + case mi of + ModMod mo -> do + info <- lookupInfo mo c + case info of + CncCat (Yes t) _ _ -> return t + AnyInd _ n -> lookupLincat gr n c + _ -> Bad $ prt c +++ "has no linearization type in" +++ prt m + _ -> Bad $ prt m +++ "is not concrete" + + + +{- +-- the type of oper may have to be inferred at TC, so it may be junk before it + +lookupResIdent :: Ident -> [(Ident, SourceRes)] -> Err (Term,Type) +lookupResIdent c ms = case lookupWhich ms c of + Ok (i,info) -> case info of + ResOper (Yes t) _ -> return (Q i c, t) + ResOper _ _ -> return (Q i c, undefined) ---- + ResParam _ -> return (Q i c, typePType) + ResValue (Yes t) -> return (QC i c, t) + _ -> Bad $ "not found in resource" +++ prt c + +-- NB we only have to look up cnc in canonical! + +-- you may want to strip the qualification if the module is the current one + +stripMod :: Ident -> Term -> Term +stripMod m t = case t of + Q n c | n==m -> Cn c + QC n c | n==m -> Con c + _ -> t + +-- what you want may be a pattern and not a term. Then use Macros.term2patt + + + + +-- an auxiliary for making ordered search through a list of modules + +lookups :: Ord i => (i -> m -> Err (Perhaps a m)) -> i -> [m] -> Err (Perhaps a m) +lookups look c [] = Bad "not found in any module" +lookups look c (m:ms) = case look c m of + Ok (Yes v) -> return $ Yes v + Ok (May m') -> look c m' + _ -> lookups look c ms + + +lookupAbstract :: AbstractST -> Ident -> Err AbsInfo +lookupAbstract g i = errIn ("not found in abstract" +++ prt i) $ lookupTree prt i g + +lookupFunsToCat :: AbstractST -> Ident -> Err [Fun] +lookupFunsToCat g c = errIn ("looking up functions to category" +++ prt c) $ do + info <- lookupAbstract g c + case info of + AbsCat _ _ fs _ -> return fs + _ -> prtBad "not category" c + +allFunsWithValCat ab = [(f,c) | (c, AbsCat _ _ fs _) <- abstr2list ab, f <- fs] + +allDefs ab = [(f,d) | (f,AbsFun _ (Just d)) <- abstr2list ab] + +lookupCatContext :: AbstractST -> Ident -> Err Context +lookupCatContext g c = errIn "context of category" $ do + info <- lookupAbstract g c + case info of + AbsCat c _ _ _ -> return c + _ -> prtBad "not category" c + +lookupFunType :: AbstractST -> Ident -> Err Term +lookupFunType g c = errIn "looking up type of function" $ case c of + IL s -> lookupLiteral s >>= return . fst + _ -> do + info <- lookupAbstract g c + case info of + AbsFun t _ -> return t + AbsType t -> return typeType + _ -> prtBad "not function" c + +lookupFunArity :: AbstractST -> Ident -> Err Int +lookupFunArity g c = do + typ <- lookupFunType g c + ctx <- contextOfType typ + return $ length ctx + +lookupAbsDef :: AbstractST -> Ident -> Err (Maybe Term) +lookupAbsDef g c = errIn "looking up definition in abstract syntax" $ do + info <- lookupAbstract g c + case info of + AbsFun _ t -> return t + AbsType t -> return $ Just t + _ -> return $ Nothing -- constant found and accepted as primitive + + +allCats :: AbstractST -> [Ident] +allCats abstr = [c | (c, AbsCat _ _ _ _) <- abstr2list abstr] + +allIndepCats :: AbstractST -> [Ident] +allIndepCats abstr = [c | (c, AbsCat [] _ _ _) <- abstr2list abstr] + +lookupConcrete :: ConcreteST -> Ident -> Err CncInfo +lookupConcrete g i = errIn ("not found in concrete" +++ prt i) $ lookupTree prt i g + +lookupPackage :: ConcreteST -> Ident -> Err ([Ident], ConcreteST) +lookupPackage g p = do + info <- lookupConcrete g p + case info of + CncPackage ps ins -> return (ps,ins) + _ -> prtBad "not package" p + +lookupInPackage :: ConcreteST -> (Ident,Ident) -> Err CncInfo +lookupInPackage = lookupLift (flip (lookupTree prt)) + +lookupInAll :: [BinTree (Ident,b)] -> Ident -> Err b +lookupInAll = lookInAll (flip (lookupTree prt)) + +lookInAll :: (BinTree (Ident,c) -> Ident -> Err b) -> + [BinTree (Ident,c)] -> Ident -> Err b +lookInAll look ts c = case ts of + t : ts' -> err (const $ lookInAll look ts' c) return $ look t c + [] -> prtBad "not found in any package" c + +lookupLift :: (ConcreteST -> Ident -> Err b) -> + ConcreteST -> (Ident,Ident) -> Err b +lookupLift look g (p,f) = do + (ps,ins) <- lookupPackage g p + ps' <- mapM (lookupPackage g) ps + lookInAll look (ins : reverse (map snd ps')) f + +termFromPackage :: ConcreteST -> Ident -> Term -> Err Term +termFromPackage g p = termFP where + termFP t = case t of + Cn c -> return $ if isInPack c + then Q p c + else Cn c + T (TTyped t) cs -> do + t' <- termFP t + liftM (T (TTyped t')) $ mapM branchInPack cs + T i cs -> liftM (T i) $ mapM branchInPack cs + _ -> composOp termFP t + isInPack c = case lookupInPackage g (p,c) of + Ok _ -> True + _ -> False + branchInPack (q,t) = do + p' <- pattInPack q + t' <- termFP t + return (p',t') + pattInPack q = case q of + PC c ps -> do + let pc = if isInPack c + then PP p c + else PC c + ps' <- mapM pattInPack ps + return $ pc ps' + _ -> return q + +lookupCncDef :: ConcreteST -> Ident -> Err Term +lookupCncDef g t@(IL _) = return $ cn t +lookupCncDef g c = errIn "looking up defining term" $ do + info <- lookupConcrete g c + case info of + CncOper _ t _ -> return t -- the definition + CncCat t _ _ _ -> return t -- the linearization type + _ -> return $ Cn c -- constant found and accepted + +lookupOperDef :: ConcreteST -> Ident -> Err Term +lookupOperDef g c = errIn "looking up defining term of oper" $ do + info <- lookupConcrete g c + case info of + CncOper _ t _ -> return t + _ -> prtBad "not oper" c + +lookupLincat :: ConcreteST -> Ident -> Err Term +lookupLincat g c = return $ errVal defaultLinType $ do + info <- lookupConcrete g c + case info of + CncCat t _ _ _ -> return t + _ -> prtBad "not category" c + +lookupLindef :: ConcreteST -> Ident -> Err Term +lookupLindef g c = return $ errVal linDefStr $ do + info <- lookupConcrete g c + case info of + CncCat _ (Just t) _ _ -> return t + CncCat _ _ _ _ -> return $ linDefStr --- wrong: this is only sof {s:Str} + _ -> prtBad "not category" c + +lookupLinType :: ConcreteST -> Ident -> Err Type +lookupLinType g c = errIn "looking up type in concrete syntax" $ do + info <- lookupConcrete g c + case info of + CncParType _ _ _ -> return typeType + CncParam ty _ -> return ty + CncOper (Just ty) _ _ -> return ty + _ -> prtBad "no type found for" c + +lookupLin :: ConcreteST -> Ident -> Err Term +lookupLin g c = errIn "looking up linearization rule" $ do + info <- lookupConcrete g c + case info of + CncFun t _ -> return t + _ -> prtBad "not category" c + +lookupFirstTag :: ConcreteST -> Ident -> Err Term +lookupFirstTag g c = do + vs <- lookupParamValues g c + case vs of + v:_ -> return v + _ -> prtBad "empty parameter type" c + +lookupPrintname :: ConcreteST -> Ident -> Err String +lookupPrintname g c = case lookupConcrete g c of + Ok info -> case info of + CncCat _ _ _ m -> mpr m + CncFun _ m -> mpr m + CncParType _ _ m -> mpr m + CncOper _ _ m -> mpr m + _ -> Bad "no possible printname" + Bad s -> Bad s + where + mpr = maybe (Bad "no printname") (return . stringFromTerm) + +-- this variant succeeds even if there's only abstr syntax +lookupPrintname' g c = case lookupConcrete g c of + Bad _ -> return $ prt c + Ok info -> case info of + CncCat _ _ _ m -> mpr m + CncFun _ m -> mpr m + CncParType _ _ m -> mpr m + CncOper _ _ m -> mpr m + _ -> return $ prt c + where + mpr = return . maybe (prt c) stringFromTerm + +allOperDefs :: ConcreteST -> [(Ident,CncInfo)] +allOperDefs cnc = [d | d@(_, CncOper _ _ _) <- concr2list cnc] + +allPackageDefs :: ConcreteST -> [(Ident,CncInfo)] +allPackageDefs cnc = [d | d@(_, CncPackage _ _) <- concr2list cnc] + +allOperDependencies :: ConcreteST -> [(Ident,[Ident])] +allOperDependencies cnc = + [(f, filter (/= f) $ -- package name may occur in the package itself + nub (concatMap (opersInCncInfo cnc f . snd) (tree2list ds))) | + (f, CncPackage _ ds) <- allPackageDefs cnc] ++ + [(f, nub (opersInTerm cnc t)) | + (f, CncOper _ t _) <- allOperDefs cnc] + +opersInTerm :: ConcreteST -> Term -> [Ident] +opersInTerm cnc t = case t of + Cn c -> [c | isOper c] + Q p c -> [p] + _ -> collectOp ops t + where + isOper (IL _) = False + isOper c = errVal False $ lookupOperDef cnc c >>= return . const True + ops = opersInTerm cnc + +-- this is used inside packages, to find references to outside the package +opersInCncInfo :: ConcreteST -> Ident -> CncInfo -> [Ident] +opersInCncInfo cnc p i = case i of + CncOper _ t _-> filter (not . internal) $ opersInTerm cnc t + _ -> [] + where + internal c = case lookupInPackage cnc (p,c) of + Ok _ -> True + _ -> False + +opersUsedInLins :: ConcreteST -> [(Ident,[Ident])] -> [Ident] +opersUsedInLins cnc deps = do + let ops0 = concat [opersInTerm cnc t | (_, CncFun t _) <- concr2list cnc] + nub $ closure ops0 + where + closure ops = case [g | (f,fs) <- deps, elem f ops, g <- fs, notElem g ops] of + [] -> ops + ops' -> ops ++ closure ops' + -- presupposes deps are not circular: check this first! + + + + +-- create refinement and wrapping lists + + +varOrConst :: AbstractST -> Ident -> Err Term +varOrConst abstr c = case lookupFunType abstr c of + Ok _ -> return $ Cn c --- bindings cannot overshadow constants + _ -> case c of + IL _ -> return $ Cn c + _ -> return $ Vr c + +-- a rename operation for parsing term input; for abstract syntax and parameters +renameTrm :: (Ident -> Err a) -> Term -> Term +renameTrm look = ren [] where + ren vars t = case t of + Vr x | notElem x vars && isNotError (look x) -> Cn x + Abs x b -> Abs x $ ren (x:vars) b + _ -> composSafeOp (ren vars) t +-} diff --git a/src/GF/Grammar/MMacros.hs b/src/GF/Grammar/MMacros.hs new file mode 100644 index 000000000..4078221dc --- /dev/null +++ b/src/GF/Grammar/MMacros.hs @@ -0,0 +1,261 @@ +module MMacros where + +import Operations +import Zipper + +import Grammar +import PrGrammar +import Ident +import Refresh +import Values +----import GrammarST +import Macros + +import Monad + +-- some more abstractions on grammars, esp. for Edit + +nodeTree (Tr (n,_)) = n +argsTree (Tr (_,ts)) = ts + +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 = atomNode . nodeTree +valTree = valNode . nodeTree + +mkNode binds atom vtyp cs = N (binds,atom,vtyp,cs,False) + +type Var = Ident +type Meta = MetaSymb + +metasTree :: Tree -> [Meta] +metasTree = concatMap metasNode . scanTree where + metasNode n = [m | AtM m <- [atomNode n]] ++ map fst (metaSubstsNode n) + +varsTree :: Tree -> [(Var,Val)] +varsTree t = [(x,v) | N (_,AtV x,v,_,_) <- scanTree t] + +constrsTree :: Tree -> Constraints +constrsTree = constrsNode . nodeTree + +allConstrsTree :: Tree -> Constraints +allConstrsTree = concatMap constrsNode . scanTree + +changeConstrs :: (Constraints -> Constraints) -> TrNode -> TrNode +changeConstrs f (N (b,a,v,(c,m),x)) = N (b,a,v,(f c, m),x) + +changeMetaSubst :: (MetaSubst -> MetaSubst) -> TrNode -> TrNode +changeMetaSubst f (N (b,a,v,(c,m),x)) = N (b,a,v,(c, f m),x) + +changeAtom :: (Atom -> Atom) -> TrNode -> TrNode +changeAtom f (N (b,a,v,(c,m),x)) = N (b,f a,v,(c, m),x) + +------ on the way to Edit + +uTree :: Tree +uTree = Tr (uNode, []) -- unknown tree + +uNode :: TrNode +uNode = mkNode [] uAtom uVal ([],[]) + + +uAtom :: Atom +uAtom = AtM meta0 + +mAtom :: Atom +mAtom = AtM meta0 + +uVal :: Val +uVal = vClos uExp + +vClos :: Exp -> Val +vClos = VClos [] + +uExp :: Exp +uExp = Meta meta0 + +mExp :: Exp +mExp = Meta meta0 + +mExp0 = mExp + +meta2exp :: MetaSymb -> Exp +meta2exp = Meta + +atomC = AtC + +funAtom :: Atom -> Err Fun +funAtom a = case a of + AtC f -> return f + _ -> prtBad "not function head" a + +uBoundVar :: Ident +uBoundVar = zIdent "#h" -- used for suppressed bindings + +atomIsMeta :: Atom -> Bool +atomIsMeta atom = case atom of + AtM _ -> True + _ -> False + +getMetaAtom a = case a of + AtM m -> return m + _ -> Bad "the active node is not meta" + +cat2val :: Context -> Cat -> Val +cat2val cont cat = vClos $ mkApp (qq cat) [mkMeta i | i <- [1..length cont]] + +val2cat :: Val -> Err Cat +val2cat v = val2exp v >>= valCat + +substTerm :: [Ident] -> Substitution -> Term -> Term +substTerm ss g c = case c of + Vr x -> maybe c id $ lookup x g + App f a -> App (substTerm ss g f) (substTerm ss g a) + Abs x b -> let y = mkFreshVarX ss x in + Abs y (substTerm (y:ss) ((x, Vr y):g) b) + Prod x a b -> let y = mkFreshVarX ss x in + Prod y (substTerm ss g a) (substTerm (y:ss) ((x,Vr y):g) b) + _ -> c + +metaSubstExp :: MetaSubst -> [(Meta,Exp)] +metaSubstExp msubst = [(m, errVal (meta2exp m) (val2expSafe v)) | (m,v) <- msubst] + +-- belong here rather than to computation + +substitute :: [Var] -> Substitution -> Exp -> Err Exp +substitute v s = return . substTerm v s + +alphaConv :: [Var] -> (Var,Var) -> Exp -> Err Exp --- +alphaConv oldvars (x,x') = substitute (x:x':oldvars) [(x,Vr x')] + +alphaFresh :: [Var] -> Exp -> Err Exp +alphaFresh vs = refreshTermN $ maxVarIndex vs + +alphaFreshAll :: [Var] -> [Exp] -> Err [Exp] +alphaFreshAll vs = mapM $ alphaFresh vs -- done in a state monad + + +val2exp = val2expP False -- for display +val2expSafe = val2expP True -- for type checking + +val2expP :: Bool -> Val -> Err Exp +val2expP safe v = case v of + + VClos g@(_:_) e@(Meta _) -> if safe + then prtBad "unsafe value substitution" v + else substVal g e + VClos g e -> substVal g e + VApp f c -> liftM2 App (val2expP safe f) (val2expP safe c) + VCn c -> return $ qq c + VGen i x -> if safe + then prtBad "unsafe val2exp" v + else return $ vr $ x --- in editing, no alpha conversions presentv + where + substVal g e = mapPairsM (val2expP safe) g >>= return . (\s -> substTerm [] s e) + +isConstVal :: Val -> Bool +isConstVal v = case v of + VApp f c -> isConstVal f && isConstVal c + VCn _ -> True + VClos [] e -> null $ freeVarsExp e + _ -> False --- could be more liberal + +mkProdVal :: Binds -> Val -> Err Val --- +mkProdVal bs v = do + bs' <- mapPairsM val2exp bs + v' <- val2exp v + return $ vClos $ foldr (uncurry Prod) v' bs' + +freeVarsExp :: Exp -> [Ident] +freeVarsExp e = case e of + Vr x -> [x] + App f c -> freeVarsExp f ++ freeVarsExp c + Abs x b -> filter (/=x) (freeVarsExp b) + Prod x a b -> freeVarsExp a ++ filter (/=x) (freeVarsExp b) + _ -> [] --- thus applies to abstract syntax only + +ident2string = prIdent + +tree :: (TrNode,[Tree]) -> Tree +tree = Tr + +eqCat :: Cat -> Cat -> Bool +eqCat = (==) + +addBinds :: Binds -> Tree -> Tree +addBinds b (Tr (N (b0,at,t,c,x),ts)) = Tr (N (b ++ b0,at,t,c,x),ts) + +bodyTree :: Tree -> Tree +bodyTree (Tr (N (_,a,t,c,x),ts)) = Tr (N ([],a,t,c,x),ts) + +refreshMetas :: [Meta] -> Exp -> Exp +refreshMetas metas = fst . rms minMeta where + rms meta trm = case trm of + Meta m -> (Meta meta, nextMeta meta) + App f a -> let (f',msf) = rms meta f + (a',msa) = rms msf a + in (App f' a', msa) + Prod x a b -> + let (a',msa) = rms meta a + (b',msb) = rms msa b + in (Prod x a' b', msb) + Abs x b -> let (b',msb) = rms meta b in (Abs x b', msb) + _ -> (trm,meta) + minMeta = int2meta $ + if null metas then 0 else (maximum (map metaSymbInt metas) + 1) + +ref2exp :: [Var] -> Type -> Ref -> Err Exp +ref2exp bounds typ ref = do + cont <- contextOfType typ + xx0 <- mapM (typeSkeleton . snd) cont + let (xxs,cs) = unzip [(length hs, c) | (hs,c) <- xx0] + args = [mkAbs xs mExp | i <- xxs, let xs = mkFreshVars i bounds] + return $ mkApp ref args + -- no refreshment of metas + +type Ref = Exp -- invariant: only Con or Var + +fun2wrap :: [Var] -> ((Fun,Int),Type) -> Exp -> Err Exp +fun2wrap oldvars ((fun,i),typ) exp = do + cont <- contextOfType typ + args <- mapM mkArg (zip [0..] (map snd cont)) + return $ mkApp (qq fun) args + where + mkArg (n,c) = do + cont <- contextOfType c + let vars = mkFreshVars (length cont) oldvars + return $ mkAbs vars $ if n==i then exp else mExp + +--- + +mkJustProd cont typ = mkProd (cont,typ,[]) + +int2var :: Int -> Ident +int2var = zIdent . ('$':) . show + +meta0 :: Meta +meta0 = int2meta 0 + +termMeta0 :: Term +termMeta0 = Meta meta0 + +identVar (Vr x) = return x +identVar _ = Bad "not a variable" + + +-- light-weight rename for user interaction + +qualifTerm :: Ident -> Term -> Term +qualifTerm m = qualif [] where + qualif xs t = case t of + Abs x b -> Abs x $ qualif (x:xs) b + Prod x a b -> Prod x (qualif xs a) $ qualif (x:xs) b + Vr x | notElem x xs -> Q m x + Cn c -> Q m c + Con c -> QC m c + _ -> composSafeOp (qualif xs) t diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs new file mode 100644 index 000000000..e6906f985 --- /dev/null +++ b/src/GF/Grammar/Macros.hs @@ -0,0 +1,634 @@ +module Macros where + +import Operations +import Str +import Grammar +import Ident +import PrGrammar + +import Monad (liftM) +import Char (isDigit) + +-- AR 7/12/1999 - 9/5/2000 -- 4/6/2001 + +-- operations on terms and types not involving lookup in or reference to grammars + +firstTypeForm :: Type -> Err (Context, Type) +firstTypeForm t = case t of + Prod x a b -> do + (x', val) <- firstTypeForm b + return ((x,a):x',val) + _ -> return ([],t) + +qTypeForm :: Type -> Err (Context, Cat, [Term]) +qTypeForm t = case t of + Prod x a b -> do + (x', cat, args) <- qTypeForm b + return ((x,a):x', cat, args) + App c a -> do + (_,cat, args) <- qTypeForm c + return ([],cat,args ++ [a]) + Q m c -> + return ([],(m,c),[]) + QC m c -> + return ([],(m,c),[]) + _ -> + prtBad "no normal form of type" t + +qq :: QIdent -> Term +qq (m,c) = Q m c + +typeForm = qTypeForm ---- no need to dist any more + +typeFormCnc :: Type -> Err (Context, Type) +typeFormCnc t = case t of + Prod x a b -> do + (x', v) <- typeFormCnc b + return ((x,a):x',v) + _ -> return ([],t) + +valCat :: Type -> Err Cat +valCat typ = + do (_,cat,_) <- typeForm typ + return cat + +valType :: Type -> Err Type +valType typ = + do (_,cat,xx) <- typeForm typ --- not optimal to do in this way + return $ mkApp (qq cat) xx + +valTypeCnc :: Type -> Err Type +valTypeCnc typ = + do (_,ty) <- typeFormCnc typ + return ty + +typeRawSkeleton :: Type -> Err ([(Int,Type)],Type) +typeRawSkeleton typ = + do (cont,typ) <- typeFormCnc typ + args <- mapM (typeRawSkeleton . snd) cont + return ([(length c, v) | (c,v) <- args], typ) + +type MCat = (Ident,Ident) + +sortMCat :: String -> MCat +sortMCat s = (zIdent "_", zIdent s) + +getMCat :: Term -> Err MCat +getMCat t = case t of + Q m c -> return (m,c) + QC m c -> return (m,c) + Sort s -> return $ sortMCat s + App f _ -> getMCat f + _ -> prtBad "no qualified constant" t + +typeSkeleton :: Type -> Err ([(Int,MCat)],MCat) +typeSkeleton typ = do + (cont,val) <- typeRawSkeleton typ + cont' <- mapPairsM getMCat cont + val' <- getMCat val + return (cont',val') + +catSkeleton :: Type -> Err ([MCat],MCat) +catSkeleton typ = + do (args,val) <- typeSkeleton typ + return (map snd args, val) + +funsToAndFrom :: Type -> (MCat, [(MCat,[Int])]) +funsToAndFrom t = errVal undefined $ do --- + (cs,v) <- catSkeleton t + let cis = zip cs [0..] + return $ (v, [(c,[i | (c',i) <- cis, c' == c]) | c <- cs]) + +typeFormConcrete :: Type -> Err (Context, Type) +typeFormConcrete t = case t of + Prod x a b -> do + (x', typ) <- typeFormConcrete b + return ((x,a):x', typ) + _ -> return ([],t) + +isRecursiveType :: Type -> Bool +isRecursiveType t = errVal False $ do + (cc,c) <- catSkeleton t -- thus recursivity on Cat level + return $ any (== c) cc + + +contextOfType :: Type -> Err Context +contextOfType typ = case typ of + Prod x a b -> liftM ((x,a):) $ contextOfType b + _ -> return [] + +unComputed :: Term -> Term +unComputed t = case t of + Computed v -> unComputed v + _ -> t --- composSafeOp unComputed t + +computed = Computed + +termForm :: Term -> Err ([(Ident)], Term, [Term]) +termForm t = case t of + Abs x b -> + do (x', fun, args) <- termForm b + return (x:x', fun, args) + App c a -> + do (_,fun, args) <- termForm c + return ([],fun,args ++ [a]) + _ -> + return ([],t,[]) + +appForm :: Term -> (Term, [Term]) +appForm t = case t of + App c a -> (fun, args ++ [a]) where (fun, args) = appForm c + _ -> (t,[]) + +varsOfType :: Type -> [Ident] +varsOfType t = case t of + Prod x _ b -> x : varsOfType b + _ -> [] + +mkProdSimple :: Context -> Term -> Term +mkProdSimple c t = mkProd (c,t,[]) + +mkProd :: (Context, Term, [Term]) -> Term +mkProd ([],typ,args) = mkApp typ args +mkProd ((x,a):dd, typ, args) = Prod x a (mkProd (dd, typ, args)) + +mkTerm :: ([(Ident)], Term, [Term]) -> Term +mkTerm (xx,t,aa) = mkAbs xx (mkApp t aa) + +mkApp :: Term -> [Term] -> Term +mkApp = foldl App + +mkAbs :: [Ident] -> Term -> Term +mkAbs xx t = foldr Abs t xx + +appCons :: Ident -> [Term] -> Term +appCons = mkApp . Cn + +appc :: String -> [Term] -> Term +appc = appCons . zIdent + +mkLet :: [LocalDef] -> Term -> Term +mkLet defs t = foldr Let t defs + +isVariable (Vr _ ) = True +isVariable _ = False + +eqIdent :: Ident -> Ident -> Bool +eqIdent = (==) + +zIdent :: String -> Ident +zIdent s = identC s + +uType :: Type +uType = Cn (zIdent "UndefinedType") + +assign :: Label -> Term -> Assign +assign l t = (l,(Nothing,t)) + +assignT :: Label -> Type -> Term -> Assign +assignT l a t = (l,(Just a,t)) + +unzipR :: [Assign] -> ([Label],[Term]) +unzipR r = (ls, map snd ts) where (ls,ts) = unzip r + +mkAssign :: [(Label,Term)] -> [Assign] +mkAssign lts = [assign l t | (l,t) <- lts] + +zipAssign :: [Label] -> [Term] -> [Assign] +zipAssign ls ts = [assign l t | (l,t) <- zip ls ts] + +ident2label :: Ident -> Label +ident2label c = LIdent (prIdent c) + +label2ident :: Label -> Ident +label2ident = identC . prLabel + +prLabel :: Label -> String +prLabel = prt + +mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))] +mapAssignM f ltvs = do + let (ls,tvs) = unzip ltvs + (ts, vs) = unzip tvs + ts' <- mapM (\t -> case t of + Nothing -> return Nothing + Just y -> f y >>= return . Just) ts + vs' <- mapM f vs + return (zip ls (zip ts' vs')) + +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 + +typeType = srt "Type" +typePType = srt "PType" +typeStr = srt "Str" +typeTok = srt "Tok" +typeStrs = srt "Strs" + +typeString = constPredefRes "String" +typeInt = constPredefRes "Int" + +constPredefRes s = Q (IC "Predef") (zIdent s) + +isPredefConstant t = case t of + Q (IC "Predef") _ -> True + _ -> False + +mkSelects :: Term -> [Term] -> Term +mkSelects t tt = foldl S t tt + +mkTable :: [Term] -> Term -> Term +mkTable tt t = foldr Table t tt + +mkCTable :: [Ident] -> Term -> Term +mkCTable ids v = foldr ccase v ids where + ccase x t = T TRaw [(PV x,t)] + +mkDecl :: Term -> Decl +mkDecl typ = (wildIdent, typ) + +eqStrIdent :: Ident -> Ident -> Bool +eqStrIdent = (==) + +tupleLabel i = LIdent $ "p" ++ show i +linLabel i = LIdent $ "s" ++ show i + +tuple2record :: [Term] -> [Assign] +tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts] + +tuple2recordType :: [Term] -> [Labelling] +tuple2recordType ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts] + +tuple2recordPatt :: [Patt] -> [(Label,Patt)] +tuple2recordPatt ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts] + +mkCases :: Ident -> Term -> Term +mkCases x t = T TRaw [(PV x, t)] + +mkWildCases :: Term -> Term +mkWildCases = mkCases wildIdent + +mkFunType :: [Type] -> Type -> Type +mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt], t, []) -- nondep prod + +plusRecType :: Type -> Type -> Err Type +plusRecType t1 t2 = case (unComputed t1, unComputed t2) of + (RecType r1, RecType r2) -> return (RecType (r1 ++ r2)) + _ -> Bad ("cannot add record types" +++ prt t1 +++ "and" +++ prt t2) + +plusRecord :: Term -> Term -> Err Term +plusRecord t1 t2 = + case (t1,t2) of + (R r1, R r2 ) -> return (R (r1 ++ r2)) + (_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV + (FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV + _ -> Bad ("cannot add records" +++ prt t1 +++ "and" +++ prt t2) + +-- default linearization type + +defLinType = RecType [(LIdent "s", typeStr)] + +-- refreshing variables + +varX :: Int -> Ident +varX i = identV (i,"x") + +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 = ccK + +ccK = K +ccC = C + +-- create a terminal from identifier +ident2terminal :: Ident -> Term +ident2terminal = ccK . prIdent + +-- create a constant +string2CnTrm :: String -> Term +string2CnTrm = Cn . zIdent + +symbolOfIdent :: Ident -> String +symbolOfIdent = prIdent + +symid = symbolOfIdent + +vr = Vr +cn = Cn +srt = Sort +meta = Meta +cnIC = cn . IC + +justIdentOf (Vr x) = Just x +justIdentOf (Cn x) = Just x +justIdentOf _ = Nothing + +isMeta (Meta _) = True +isMeta _ = False +mkMeta = Meta . MetaSymb + +nextMeta :: MetaSymb -> MetaSymb +nextMeta = int2meta . succ . metaSymbInt + +int2meta = MetaSymb + +metaSymbInt :: MetaSymb -> Int +metaSymbInt (MetaSymb k) = k + +freshMeta :: [MetaSymb] -> MetaSymb +freshMeta ms = MetaSymb (minimum [n | n <- [0..length ms], + notElem n (map metaSymbInt ms)]) + +mkFreshMetasInTrm :: [MetaSymb] -> Trm -> Trm +mkFreshMetasInTrm metas = fst . rms minMeta where + rms meta trm = case trm of + Meta m -> (Meta (MetaSymb meta), meta + 1) + App f a -> let (f',msf) = rms meta f + (a',msa) = rms msf a + in (App f' a', msa) + Prod x a b -> + let (a',msa) = rms meta a + (b',msb) = rms msa b + in (Prod x a' b', msb) + Abs x b -> let (b',msb) = rms meta b in (Abs x b', msb) + _ -> (trm,meta) + minMeta = if null metas then 0 else (maximum (map metaSymbInt metas) + 1) + +-- decides that a term has no metavariables +isCompleteTerm :: Term -> Bool +isCompleteTerm t = case t of + Meta _ -> False + Abs _ b -> isCompleteTerm b + App f a -> isCompleteTerm f && isCompleteTerm a + _ -> True + +linTypeStr :: Type +linTypeStr = mkRecType linLabel [typeStr] -- default lintype {s :: Str} + +linAsStr :: String -> Term +linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s} + +linDefStr :: Term +linDefStr = Abs s (R [assign (linLabel 0) (Vr s)]) where s = zIdent "s" + +term2patt :: Term -> Err Patt +term2patt trm = case termForm trm of + Ok ([], Vr x, []) -> return (PV x) + Ok ([], 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 ([], R r, []) -> do + let (ll,aa) = unzipR r + aa' <- mapM term2patt aa + return (PR (zip ll aa')) + Ok ([],EInt i,[]) -> return $ PInt i + Ok ([],K s, []) -> return $ PString s + _ -> prtBad "no pattern corresponds to term" trm + +patt2term :: Patt -> Term +patt2term pt = case pt of + PV x -> Vr x + PW -> Vr wildIdent --- not parsable, should not occur + 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 + PString s -> K s + +-- to gather s-fields; assumes term in normal form, preserves label +allLinFields :: Term -> Err [[(Label,Term)]] +allLinFields trm = case unComputed trm of +---- R rs -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good + R rs -> return [[(l,t) | (l,(_,t)) <- rs, isLinLabel l]] ---- bad + FV ts -> do + lts <- mapM allLinFields ts + return $ concat lts + _ -> prtBad "fields can only be sought in a record not in" trm + +---- deprecated +isLinLabel l = case l of + LIdent ('s':cs) | all isDigit cs -> True + _ -> False + +-- to gather ultimate cases in a table; preserves pattern list +allCaseValues :: Term -> [([Patt],Term)] +allCaseValues trm = case unComputed trm of + T _ cs -> [(p:ps, t) | (p,t0) <- cs, (ps,t) <- allCaseValues t0] + _ -> [([],trm)] + +-- to gather all linearizations; assumes normal form, preserves label and args +allLinValues :: Term -> Err [[(Label,[([Patt],Term)])]] +allLinValues trm = do + lts <- allLinFields trm + mapM (mapPairsM (return . allCaseValues)) lts + +-- to mark str parts of fields in a record f by a function f +markLinFields :: (Term -> Term) -> Term -> Term +markLinFields f t = case t of + R r -> R $ map mkField r + _ -> t + where + mkField (l,(_,t)) = if (isLinLabel l) then (assign l (mkTbl t)) else (assign l t) + mkTbl t = case t of + T i cs -> T i [(p, mkTbl v) | (p,v) <- cs] + _ -> f t + +-- to get a string from a term that represents a sequence of terminals +strsFromTerm :: Term -> Err [Str] +strsFromTerm t = case unComputed t of + K s -> return [str s] + C s t -> do + s' <- strsFromTerm s + t' <- strsFromTerm t + return [plusStr x y | x <- s', y <- t'] + Glue s t -> do + s' <- strsFromTerm s + t' <- strsFromTerm t + return [glueStr x y | x <- s', y <- t'] + Alts (d,vs) -> do + d0 <- strsFromTerm d + v0 <- mapM (strsFromTerm . fst) vs + c0 <- mapM (strsFromTerm . snd) vs + let vs' = zip v0 c0 + return [strTok (str2strings def) vars | + def <- d0, + vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | + vv <- combinations v0] + ] + FV ts -> mapM strsFromTerm ts >>= return . concat + Strs ts -> mapM strsFromTerm ts >>= return . concat + Ready ss -> return [ss] + Alias _ _ d -> strsFromTerm d --- should not be needed... + _ -> prtBad "cannot get Str from term" t + +-- to print an Str-denoting term as a string; if the term is of wrong type, the error msg +stringFromTerm :: Term -> String +stringFromTerm = err id (ifNull "" (sstr . head)) . strsFromTerm + + +-- to define compositional term functions + +composSafeOp :: (Term -> Term) -> Term -> Term +composSafeOp op trm = case composOp (mkMonadic op) trm of + Ok t -> t + _ -> error "the operation is safe isn't it ?" + where + mkMonadic f = return . f + +composOp :: Monad m => (Term -> m Term) -> Term -> m Term +composOp co trm = + case trm of + App c a -> + do c' <- co c + a' <- co a + return (App c' a') + Abs x b -> + do b' <- co b + return (Abs x b') + Prod x a b -> + do a' <- co a + b' <- co b + return (Prod x a' b') + S c a -> + do c' <- co c + a' <- co a + return (S c' a') + Table a c -> + do a' <- co a + c' <- co c + return (Table a' c') + R r -> + do r' <- mapAssignM co r + return (R r') + RecType r -> + do r' <- mapPairListM (co . snd) r + return (RecType r') + P t i -> + do t' <- co t + return (P t' i) + 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') + Let (x,(mt,a)) b -> + do a' <- co a + mt' <- case mt of + Just t -> co t >>= (return . Just) + _ -> return mt + b' <- co b + return (Let (x,(mt',a')) b') + Alias c ty d -> + do v <- co d + ty' <- co ty + return $ Alias c ty' v + C s1 s2 -> + do v1 <- co s1 + v2 <- co s2 + return (C v1 v2) + Glue s1 s2 -> + do v1 <- co s1 + v2 <- co s2 + return (Glue v1 v2) + Alts (t,aa) -> + do t' <- co t + aa' <- mapM (pairM co) aa + return (Alts (t',aa')) + FV ts -> mapM co ts >>= return . FV + Strs tt -> mapM co tt >>= return . Strs + _ -> return trm -- covers K, Vr, Cn, Sort + +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 + Let (x,(mt,a)) b -> maybe [] co mt ++ co a ++ co b + C s1 s2 -> co s1 ++ co s2 + Glue s1 s2 -> co s1 ++ co s2 + Alts (t,aa) -> let (x,y) = unzip aa in co t ++ concatMap co (x ++ y) + FV ts -> concatMap co ts + Strs tt -> concatMap co tt + _ -> [] -- covers K, Vr, Cn, Sort, Ready + +-- to find the word items in a term + +wordsInTerm :: Term -> [String] +wordsInTerm trm = filter (not . null) $ case trm of + K s -> [s] + S c _ -> wo c + Alts (t,aa) -> wo t ++ concatMap (wo . fst) aa + Ready s -> allItems s + _ -> collectOp wo trm + where wo = wordsInTerm + +noExist = FV [] + +defaultLinType :: Type +defaultLinType = mkRecType linLabel [typeStr] + +metaTerms :: [Term] +metaTerms = map (Meta . MetaSymb) [0..] + +-- from GF1, 20/9/2003 + +isInOneType :: Type -> Bool +isInOneType t = case t of + Prod _ a b -> a == b + _ -> False + diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs new file mode 100644 index 000000000..2ca8b21de --- /dev/null +++ b/src/GF/Grammar/PatternMatch.hs @@ -0,0 +1,98 @@ +module PatternMatch where + +import Operations +import Grammar +import Ident +import Macros +import PrGrammar + +import List +import Monad + +-- pattern matching for both concrete and abstract syntax. AR -- 16/6/2003 + + +matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution) +matchPattern pts term = + errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $ + findMatch [([p],t) | (p,t) <- pts] [term] + +testOvershadow :: [Patt] -> [Term] -> Err [Patt] +testOvershadow pts vs = do + let numpts = zip pts [0..] + let cases = [(p,EInt i) | (p,i) <- numpts] + ts <- mapM (liftM fst . matchPattern cases) vs + return $ [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ] + +findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution) +findMatch cases terms = case cases of + [] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms)) + (patts,_):_ | length patts /= length terms -> + Bad ("wrong number of args for patterns :" +++ + unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms)) + (patts,val):cc -> case mapM tryMatch (zip patts terms) of + Ok substs -> return (val, concat substs) + _ -> findMatch cc terms + +tryMatch :: (Patt, Term) -> Err [(Ident, Term)] +tryMatch (p,t) = do + t' <- termForm t + trym p t' + where + trym p t' = + case (p,t') of + (PV IW, _) | isInConstantForm t -> return [] -- optimization with wildcard + (PV x, _) | isInConstantForm t -> return [(x,t)] + (PString s, ([],K i,[])) | s==i -> return [] + (PInt s, ([],EInt i,[])) | s==i -> return [] + (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 && p `eqStrIdent` f && length pp == length tt -> + do matches <- mapM tryMatch (zip pp tt) + return (concat matches) + ---- hack for AppPredef bug + (PP q p pp, ([], Q r f, tt)) | + q `eqStrIdent` r && p `eqStrIdent` f && length pp == length tt -> + do matches <- mapM tryMatch (zip pp tt) + return (concat matches) + + (PR r, ([],R r',[])) | + all (`elem` map fst r') (map fst r) -> + do matches <- mapM tryMatch + [(p,snd a) | (l,p) <- r, let Just a = lookup l r'] + return (concat matches) + (PT _ p',_) -> trym p' t' + (_, ([],Alias _ _ d,[])) -> tryMatch (p,d) + _ -> prtBad "no match in case expr for" t + +isInConstantForm :: Term -> Bool +isInConstantForm trm = case trm of + Cn _ -> True + Con _ -> True + Q _ _ -> True + QC _ _ -> True + Abs _ _ -> True + App c a -> isInConstantForm c && isInConstantForm a + R r -> all (isInConstantForm . snd . snd) r + Alias _ _ t -> isInConstantForm t + _ -> False ---- isInArgVarForm trm + +varsOfPatt :: Patt -> [Ident] +varsOfPatt p = case p of + PV x -> [x | not (isWildIdent x)] + PC _ ps -> concat $ map varsOfPatt ps + PP _ _ ps -> concat $ map varsOfPatt ps + PR r -> concat $ map (varsOfPatt . snd) r + PT _ q -> varsOfPatt q + _ -> [] + +-- to search matching parameter combinations in tables +isMatchingForms :: [Patt] -> [Term] -> Bool +isMatchingForms ps ts = all match (zip ps ts') where + match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds + match _ = True + ts' = map appForm ts + diff --git a/src/GF/Grammar/PrGrammar.hs b/src/GF/Grammar/PrGrammar.hs new file mode 100644 index 000000000..03197ea02 --- /dev/null +++ b/src/GF/Grammar/PrGrammar.hs @@ -0,0 +1,189 @@ +module PrGrammar where + +import Operations +import Zipper +import Grammar +import Modules +import qualified PrintGF as P +import qualified PrintGFC as C +import qualified AbsGFC as A +import Values +import GrammarToSource +import Ident +import Str + +import List (intersperse) + +-- AR 7/12/1999 - 1/4/2000 - 10/5/2003 + +-- printing and prettyprinting class + +class Print a where + prt :: a -> String + prt2 :: a -> String -- printing with parentheses, if needed + prpr :: a -> [String] -- pretty printing + prt_ :: a -> String -- printing without ident qualifications + prt2 = prt + prt_ = prt + prpr = return . prt + +-- to show terms etc in error messages +prtBad :: Print a => String -> a -> Err b +prtBad s a = Bad (s +++ prt a) + +prGrammar = P.printTree . trGrammar +prModule = P.printTree . trModule + +instance Print Term where + prt = P.printTree . trt + prt_ = prExp + +instance Print Ident where + prt = P.printTree . tri + +instance Print Patt where + prt = P.printTree . trp + +instance Print Label where + prt = P.printTree . trLabel + +instance Print MetaSymb where + prt (MetaSymb i) = "?" ++ show i + +prParam :: Param -> String +prParam (c,co) = prt c +++ prContext co + +prContext :: Context -> String +prContext co = unwords $ map prParenth [prt x +++ ":" +++ prt t | (x,t) <- co] + +-- some GFC notions + +instance Print A.Exp where prt = C.printTree +instance Print A.Term where prt = C.printTree +instance Print A.Patt where prt = C.printTree +instance Print A.Case where prt = C.printTree +instance Print A.Atom where prt = C.printTree +instance Print A.CIdent where prt = C.printTree +instance Print A.CType where prt = C.printTree +instance Print A.Label where prt = C.printTree +instance Print A.Module where prt = C.printTree +instance Print A.Sort where prt = C.printTree + + +-- printing values and trees in editing + +instance Print a => Print (Tr a) where + prt (Tr (n, trees)) = prt n +++ unwords (map prt2 trees) + prt2 t@(Tr (_,args)) = if null args then prt t else prParenth (prt t) + +-- we cannot define the method prt_ in this way +prt_Tree :: Tree -> String +prt_Tree = prt_ . tree2exp + +instance Print TrNode where + prt (N (bi,at,vt,(cs,ms),_)) = + prBinds bi ++ + prt at +++ ":" +++ prt vt + +++ prConstraints cs +++ prMetaSubst ms + +prMarkedTree :: Tr (TrNode,Bool) -> [String] +prMarkedTree = prf 1 where + prf ind t@(Tr (node, trees)) = + prNode ind node : concatMap (prf (ind + 2)) trees + prNode ind node = case node of + (n, False) -> indent ind (prt n) + (n, _) -> '*' : indent (ind - 1) (prt n) + +prTree :: Tree -> [String] +prTree = prMarkedTree . mapTr (\n -> (n,False)) + +--- to get rig of brackets +prRefinement :: Term -> String +prRefinement t = case t of + Q m c -> prQIdent (m,c) + QC m c -> prQIdent (m,c) + _ -> prt t + +-- a pretty-printer for parsable output +tree2string = unlines . prprTree + +prprTree :: Tree -> [String] +prprTree = prf False where + prf par t@(Tr (node, trees)) = + parIf par (prn node : concat [prf (ifPar t) t | t <- trees]) + prn (N (bi,at,_,_,_)) = prb bi ++ prt at + prb [] = "" + prb bi = "\\" ++ concat (intersperse "," (map (prt . fst) bi)) ++ " -> " + parIf par (s:ss) = map (indent 2) $ + if par + then ('(':s) : ss ++ [")"] + else s:ss + ifPar (Tr (N ([],_,_,_,_), [])) = False + ifPar _ = True + + +-- auxiliaries + +prConstraints :: Constraints -> String +prConstraints = concat . prConstrs + +prMetaSubst :: MetaSubst -> String +prMetaSubst = concat . prMSubst + +prEnv :: Env -> String +---- prEnv [] = prCurly "" ---- for debugging +prEnv e = concatMap (\ (x,t) -> prCurly (prt x ++ ":=" ++ prt t)) e + +prConstrs :: Constraints -> [String] +prConstrs = map (\ (v,w) -> prCurly (prt v ++ "<>" ++ prt w)) + +prMSubst :: MetaSubst -> [String] +prMSubst = map (\ (m,e) -> prCurly ("?" ++ show m ++ "=" ++ prt e)) + +prBinds bi = if null bi + then [] + else "\\" ++ concat (intersperse "," (map prValDecl bi)) +++ "-> " + where + prValDecl (x,t) = prParenth (prt x +++ ":" +++ prt t) + +instance Print Val where + prt (VGen i x) = prt x ---- ++ "-$" ++ show i ---- latter part for debugging + prt (VApp u v) = prt u +++ prv1 v + prt (VCn mc) = prQIdent mc + prt (VClos env e) = case e of + Meta _ -> prt e ++ prEnv env + _ -> prt e ---- ++ prEnv env ---- for debugging + +prv1 v = case v of + VApp _ _ -> prParenth $ prt v + VClos _ _ -> prParenth $ prt v + _ -> prt v + +instance Print Atom where + prt (AtC f) = prQIdent f + prt (AtM i) = prt i + prt (AtV i) = prt i + prt (AtL s) = s + prt (AtI i) = show i + +prQIdent :: QIdent -> String +prQIdent (m,f) = prt m ++ "." ++ prt f + +-- print terms without qualifications + +prExp :: Term -> String +prExp e = case e of + App f a -> pr1 f +++ pr2 a + Abs x b -> "\\" ++ prt x +++ "->" +++ prExp b + Prod x a b -> "(\\" ++ prt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b + Q _ c -> prt c + QC _ c -> prt c + _ -> prt e + where + pr1 e = case e of + Abs _ _ -> prParenth $ prExp e + Prod _ _ _ -> prParenth $ prExp e + _ -> prExp e + pr2 e = case e of + App _ _ -> prParenth $ prExp e + _ -> pr1 e diff --git a/src/GF/Grammar/Refresh.hs b/src/GF/Grammar/Refresh.hs new file mode 100644 index 000000000..8b33444d0 --- /dev/null +++ b/src/GF/Grammar/Refresh.hs @@ -0,0 +1,105 @@ +module Refresh where + +import Operations +import Grammar +import Ident +import Modules +import Macros +import Monad + +refreshTerm :: Term -> Err Term +refreshTerm = refreshTermN 0 + +refreshTermN :: Int -> Term -> Err Term +refreshTermN i e = liftM snd $ refreshTermKN i e + +refreshTermKN :: Int -> Term -> Err (Int,Term) +refreshTermKN i e = liftM (\ (t,(_,i)) -> (i,t)) $ + appSTM (refresh e) (initIdStateN i) + +refresh :: Term -> STM IdState Term +refresh e = case e of + + Vr x -> liftM Vr (lookVar x) + Abs x b -> liftM2 Abs (refVarPlus x) (refresh b) + + Prod x a b -> do + a' <- refresh a + x' <- refVar x + b' <- refresh b + return $ Prod x' a' b' + + Let (x,(mt,a)) b -> do + a' <- refresh a + mt' <- case mt of + Just t -> refresh t >>= (return . Just) + _ -> return mt + x' <- refVar x + b' <- refresh b + return (Let (x',(mt',a')) b') + + R r -> liftM R $ refreshRecord r + + ExtR r s -> liftM2 ExtR (refresh r) (refresh s) + + T i cc -> liftM2 T (refreshTInfo i) (mapM refreshCase cc) + + _ -> composOp refresh e + +refreshCase :: (Patt,Term) -> STM IdState (Patt,Term) +refreshCase (p,t) = liftM2 (,) (refreshPatt p) (refresh t) + +refreshPatt p = case p of + PV x -> liftM PV (refVar x) + PC c ps -> liftM (PC c) (mapM refreshPatt ps) + PP q c ps -> liftM (PP q c) (mapM refreshPatt ps) + PR r -> liftM PR (mapPairsM refreshPatt r) + PT t p' -> liftM2 PT (refresh t) (refreshPatt p') + _ -> return p + +refreshRecord r = case r of + [] -> return r + (x,(mt,a)):b -> do + a' <- refresh a + mt' <- case mt of + Just t -> refresh t >>= (return . Just) + _ -> return mt + b' <- refreshRecord b + return $ (x,(mt',a')) : b' + +refreshTInfo i = case i of + TTyped t -> liftM TTyped $ refresh t + TComp t -> liftM TComp $ refresh t + TWild t -> liftM TWild $ refresh t + _ -> return i + +-- for abstract syntax + +refreshEquation :: Equation -> Err ([Patt],Term) +refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) where + refr (ps,t) = liftM2 (,) (mapM refreshPatt ps) (refresh t) + +-- for concrete and resource in grammar, before optimizing + +refreshGrammar :: SourceGrammar -> Err SourceGrammar +refreshGrammar = liftM (MGrammar . snd) . foldM refreshModule (0,[]) . modules + +refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule]) +refreshModule (k,ms) mi@(i,m) = case m of + ModMod mo@(Module mt fs me ops js) | (isModCnc mo || mt == MTResource) -> do + (k',js') <- foldM refreshRes (k,[]) $ tree2list js + return (k', (i, ModMod(Module mt fs me ops (buildTree js'))) : ms) + _ -> return (k, mi:ms) + where + refreshRes (k,cs) ci@(c,info) = case info of + ResOper ptyp (Yes trm) -> do ---- refresh ptyp + (k',trm') <- refreshTermKN k trm + return $ (k', (c, ResOper ptyp (Yes trm')):cs) + CncCat mt (Yes trm) pn -> do ---- refresh mt, pn + (k',trm') <- refreshTermKN k trm + return $ (k', (c, CncCat mt (Yes trm') pn):cs) + CncFun mt (Yes trm) pn -> do ---- refresh pn + (k',trm') <- refreshTermKN k trm + return $ (k', (c, CncFun mt (Yes trm') pn):cs) + _ -> return (k, ci:cs) + diff --git a/src/GF/Grammar/ReservedWords.hs b/src/GF/Grammar/ReservedWords.hs new file mode 100644 index 000000000..43738989f --- /dev/null +++ b/src/GF/Grammar/ReservedWords.hs @@ -0,0 +1,32 @@ +module ReservedWords (isResWord, isResWordGFC) where + +import List + +-- reserved words of GF. (c) Aarne Ranta 19/3/2002 under Gnu GPL +-- modified by Markus Forsberg 9/4. +-- modified by AR 12/6/2003 for GF2 and GFC + + +isResWord :: String -> Bool +isResWord s = isInTree s resWordTree + +resWordTree :: BTree +resWordTree = +-- mapTree fst $ sorted2tree $ flip zip (repeat ()) $ sort allReservedWords + B "let" (B "concrete" (B "Tok" (B "Str" (B "PType" (B "Lin" N N) N) (B "Strs" N N)) (B "case" (B "abstract" (B "Type" N N) N) (B "cat" N N))) (B "fun" (B "flags" (B "def" (B "data" N N) N) (B "fn" N N)) (B "in" (B "grammar" N N) (B "include" N N)))) (B "pattern" (B "of" (B "lindef" (B "lincat" (B "lin" N N) N) (B "lintype" N N)) (B "out" (B "oper" (B "open" N N) N) (B "param" N N))) (B "strs" (B "resource" (B "printname" (B "pre" N N) N) (B "reuse" N N)) (B "transfer" (B "table" N N) (B "variants" N N)))) + + +isResWordGFC :: String -> Bool +isResWordGFC s = isInTree s $ + B "of" (B "fun" (B "concrete" (B "cat" (B "abstract" N N) N) (B "flags" N N)) (B "lin" (B "in" N N) (B "lincat" N N))) (B "resource" (B "param" (B "oper" (B "open" N N) N) (B "pre" N N)) (B "table" (B "strs" N N) (B "variants" N N))) + +data BTree = N | B String BTree BTree deriving (Show) + +isInTree :: String -> BTree -> Bool +isInTree x tree = case tree of + N -> False + B a left right + | x < a -> isInTree x left + | x > a -> isInTree x right + | x == a -> True + diff --git a/src/GF/Grammar/TC.hs b/src/GF/Grammar/TC.hs new file mode 100644 index 000000000..ce9da979d --- /dev/null +++ b/src/GF/Grammar/TC.hs @@ -0,0 +1,210 @@ +module TC where + +import Operations +import Abstract +import AbsCompute + +import Monad + +-- Thierry Coquand's type checking algorithm that creates a trace + +data AExp = + AVr Ident Val + | ACn QIdent Val + | AType + | AInt Int + | AStr String + | AMeta MetaSymb Val + | AApp AExp AExp Val + | AAbs Ident Val AExp + | AProd Ident AExp AExp + | AEqs [([Exp],AExp)] --- + deriving (Eq,Show) + +type Theory = QIdent -> Err Val + +lookupConst :: Theory -> QIdent -> Err Val +lookupConst th f = th f + +lookupVar :: Env -> Ident -> Err Val +lookupVar g x = maybe (prtBad "unknown variable" x) return $ lookup x ((IW,uVal):g) +-- wild card IW: no error produced, ?0 instead. + +type TCEnv = (Int,Env,Env) + +emptyTCEnv :: TCEnv +emptyTCEnv = (0,[],[]) + +whnf :: Val -> Err Val +whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug + case v of + VApp u w -> do + u' <- whnf u + w' <- whnf w + app u' w' + VClos env e -> eval env e + _ -> return v + +app :: Val -> Val -> Err Val +app u v = case u of + VClos env (Abs x e) -> eval ((x,v):env) e + _ -> return $ VApp u v + +eval :: Env -> Exp -> Err Val +eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ + case e of + Vr x -> lookupVar env x + Q m c -> return $ VCn (m,c) + Sort c -> return $ VType --- the only sort is Type + App f a -> join $ liftM2 app (eval env f) (eval env a) + _ -> return $ VClos env e + +eqVal :: Int -> Val -> Val -> Err [(Val,Val)] +eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $ + do + w1 <- whnf u1 + w2 <- whnf u2 + let v = VGen k + case (w1,w2) of + (VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2) + (VClos env1 (Abs x1 e1), VClos env2 (Abs x2 e2)) -> + eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2) + (VClos env1 (Prod x1 a1 e1), VClos env2 (Prod x2 a2 e2)) -> + liftM2 (++) + (eqVal k (VClos env1 a1) (VClos env2 a2)) + (eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)) + (VGen i _, VGen j _) -> return [(w1,w2) | i /= j] + _ -> 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) + _ -> prtBad ("function type expected for" +++ prt e +++ "instead of") typ + + Eqs es -> do + bcs <- mapM (\b -> checkBranch th tenv b typ) es + let (bs,css) = unzip bcs + return (AEqs bs, concat css) + + Prod x a b -> do + testErr (typ == vType) "expected Type" + (a',csa) <- checkType th tenv a + (b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b + return (AProd x a' b', csa ++ csb) + + _ -> checkInferExp th tenv e typ + +checkInferExp :: Theory -> TCEnv -> Exp -> Val -> Err (AExp, [(Val,Val)]) +checkInferExp th tenv@(k,_,_) e typ = do + (e',w,cs1) <- inferExp th tenv e + cs2 <- eqVal k w typ + return (e',cs1 ++ cs2) + +inferExp :: Theory -> TCEnv -> Exp -> Err (AExp, Val, [(Val,Val)]) +inferExp th tenv@(k,rho,gamma) e = case e of + Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x + Q m c -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) + Sort _ -> return (AType, vType, []) + App f t -> do + (f',w,csf) <- inferExp th tenv f + typ <- whnf w + case typ of + VClos env (Prod x a b) -> do + (a',csa) <- checkExp th tenv t (VClos env a) + b' <- whnf $ VClos ((x,VClos rho t):env) b + return $ (AApp f' a' b', b', csf ++ csa) + _ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ + _ -> prtBad "cannot infer type of expression" e + +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,_) = ps2ts k ps + tenv' = (k,rho2++rho, gamma) + (k,rho,gamma) = tenv + + chB tenv@(k,rho,gamma) ps ty = case ps of + p:ps2 -> do + typ <- whnf ty + case typ of + VClos env (Prod y a b) -> do + a' <- whnf $ VClos env a + (p', sigma, binds, cs1) <- checkP tenv p y a' + let tenv' = (length binds, sigma ++ rho, binds ++ gamma) + ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b) + return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt + _ -> prtBad ("Product expected for definiens" +++prt t +++ "instead of") typ + [] -> do + (e,cs) <- checkExp th tenv t ty + return (([],e),cs) + checkP env@(k,rho,gamma) t x a = do + (delta,cs) <- checkPatt th env t a + let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]] + return (VClos sigma t, sigma, delta, cs) + + ps2ts k = foldr p2t ([],0,[],k) + p2t p (ps,i,g,k) = case p of + PV IW -> (meta (MetaSymb i) : ps, i+1,g,k) + PV x -> (vr x : ps, i, upd x k g,k+1) +---- PL s -> (cn s : ps, i, g, k) + PP m c xs -> (mkApp (qq (m,c)) xss : ps, j, g',k') + where (xss,j,g',k') = foldr p2t ([],i,g,k) xs + _ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch" + + upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables + +checkPatt :: Theory -> TCEnv -> Exp -> Val -> Err (Binds,[(Val,Val)]) +checkPatt th tenv exp val = do + (aexp,_,cs) <- checkExpP tenv exp val + let binds = extrBinds aexp + return (binds,cs) + where + extrBinds aexp = case aexp of + AVr i v -> [(i,v)] + AApp f a _ -> extrBinds f ++ extrBinds a + _ -> [] -- no other cases are possible + +--- ad hoc, to find types of variables + checkExpP tenv@(k,rho,gamma) exp val = case exp of + Meta m -> return $ (AMeta m val, val, []) + Vr x -> return $ (AVr x val, val, []) + Q m c -> do + typ <- lookupConst th (m,c) + return $ (ACn (m,c) typ, typ, []) + App f t -> do + (f',w,csf) <- checkExpP tenv f val + typ <- whnf w + case typ of + VClos env (Prod x a b) -> do + (a',_,csa) <- checkExpP tenv t (VClos env a) + b' <- whnf $ VClos ((x,VClos rho t):env) b + return $ (AApp f' a' b', b', csf ++ csa) + _ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ + _ -> prtBad "cannot typecheck pattern" exp + +-- auxiliaries + +noConstr :: Err Val -> Err (Val,[(Val,Val)]) +noConstr er = er >>= (\v -> return (v,[])) + +mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)]) +mkAnnot a ti = do + (v,cs) <- ti + return (a v, v, cs) + diff --git a/src/GF/Grammar/TypeCheck.hs b/src/GF/Grammar/TypeCheck.hs new file mode 100644 index 000000000..c97bdd362 --- /dev/null +++ b/src/GF/Grammar/TypeCheck.hs @@ -0,0 +1,231 @@ +module TypeCheck where + +import Operations +import Zipper + +import Abstract +import AbsCompute +import Refresh +import LookAbs + +import TC + +import Unify --- + +import Monad (foldM, liftM, liftM2) + +-- top-level type checking functions; TC should not be called directly. + +annotate :: GFCGrammar -> Exp -> Err Tree +annotate gr exp = annotateIn gr [] exp Nothing + +-- type check in empty context, return a list of constraints +justTypeCheck :: GFCGrammar -> Exp -> Val -> Err Constraints +justTypeCheck gr e v = do + (_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v + constrs1 <- reduceConstraints gr 0 constrs0 + return $ fst $ splitConstraints constrs1 + +-- type check in empty context, return the expression itself if valid +checkIfValidExp :: GFCGrammar -> Exp -> Err Exp +checkIfValidExp gr e = do + (_,_,constrs0) <- inferExp (grammar2theory gr) (initTCEnv []) e + constrs1 <- reduceConstraints gr 0 constrs0 + ifNull (return e) (Bad . unwords . prConstrs) constrs1 + +annotateIn :: GFCGrammar -> Binds -> Exp -> Maybe Val -> Err Tree +annotateIn gr gamma exp = maybe (infer exp) (check exp) where + infer e = do + (a,_,cs) <- inferExp theory env e + aexp2treeC (a,cs) + check e v = do + (a,cs) <- checkExp theory env e v + aexp2treeC (a,cs) + env = initTCEnv gamma + theory = grammar2theory gr + aexp2treeC (a,c) = do + c' <- reduceConstraints gr (length gamma) c + aexp2tree (a,c') + +-- invariant way of creating TCEnv from context +initTCEnv gamma = + (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) + +-- process constraints after eqVal by computing by defs +reduceConstraints :: GFCGrammar -> Int -> Constraints -> Err Constraints +reduceConstraints gr i = liftM concat . mapM redOne where + redOne (u,v) = do + u' <- computeVal gr u + v' <- computeVal gr v + eqVal i u' v' + +computeVal :: GFCGrammar -> Val -> Err Val +computeVal gr v = case v of + VClos g@(_:_) e -> do + e' <- compt (map fst g) e --- bindings of g in e? + whnf $ VClos g e' + VApp f c -> liftM2 VApp (compv f) (compv c) >>= whnf + _ -> whnf v + where + compt = computeAbsTermIn gr + compv = computeVal gr + +-- take apart constraints that have the form (? <> t), usable as solutions +splitConstraints :: Constraints -> (Constraints,MetaSubst) +splitConstraints cs = csmsu where + + csmsu = unif (csf,msf) -- alternative: filter first + (csf,msf) = foldr mkOne ([],[]) cs + + csmsf = foldr mkOne ([],msu) csu + (csu,msu) = unif (cs,[]) -- alternative: unify first + + mkOne (u,v) = case (u,v) of + (VClos g (Meta m), v) | null g -> sub m v + (v, VClos g (Meta m)) | null g -> sub m v + -- do nothing if meta has nonempty closure; null g || isConstVal v WAS WRONG + c -> con c + con c (cs,ms) = (c:cs,ms) + sub m v (cs,ms) = (cs,(m,v):ms) + + unifo = id -- alternative: don't use unification + + unif cm@(cs,ms) = errVal cm $ do --- alternative: use unification + (cs',ms') <- unifyVal cs + return (cs', ms' ++ ms) + +performMetaSubstNode :: MetaSubst -> TrNode -> TrNode +performMetaSubstNode subst n@(N (b,a,v,(c,m),s)) = let + v' = metaSubstVal v + b' = [(x,metaSubstVal v) | (x,v) <- b] + c' = [(u',v') | (u,v) <- c, + let (u',v') = (metaSubstVal u, metaSubstVal v), u' /= v'] + in N (b',a,v',(c',m),s) + where + metaSubstVal u = errVal u $ whnf $ case u of + VApp f a -> VApp (metaSubstVal f) (metaSubstVal a) + VClos g e -> VClos [(x,metaSubstVal v) | (x,v) <- g] (metaSubstExp e) + _ -> u + metaSubstExp e = case e of + Meta m -> errVal e $ maybe (return e) val2expSafe $ lookup m subst + _ -> composSafeOp metaSubstExp e + +-- weak heuristic to narrow down menus; not used for TC. 15/11/2001 +-- the age-old method from GF 0.9 +possibleConstraints :: GFCGrammar -> Constraints -> Bool +possibleConstraints gr = and . map (possibleConstraint gr) + +possibleConstraint :: GFCGrammar -> (Val,Val) -> Bool +possibleConstraint gr (u,v) = errVal True $ do + u' <- val2exp u >>= compute gr + v' <- val2exp v >>= compute gr + return $ cts u' v' + where + cts t u = case (t,u) of + (Q m c, Q n d) -> c == d || notCan (m,c) || notCan (n,d) + (App f a, App g b) -> cts f g && cts a b + (Abs x b, Abs y c) -> cts b c + (Prod x a f, Prod y b g) -> cts a b && cts f g + (_ , _) -> isUnknown t || isUnknown u + + isUnknown t = case t of + Vr _ -> True + Meta _ -> True + _ -> False + + notCan = not . isPrimitiveFun gr + +-- interface to TC type checker + +type2val :: Type -> Val +type2val = VClos [] + +aexp2tree :: (AExp,[(Val,Val)]) -> Err Tree +aexp2tree (aexp,cs) = do + (bi,at,vt,ts) <- treeForm aexp + ts' <- mapM aexp2tree [(t,[]) | t <- ts] + return $ Tr (N (bi,at,vt,(cs,[]),False),ts') + where + treeForm a = case a of + AAbs x v b -> do + (bi, at, vt, args) <- treeForm b + v' <- whnf v ---- should not be needed... + return ((x,v') : bi, at, vt, args) + AApp c a v -> do + (_,at,_,args) <- treeForm c + v' <- whnf v ---- + return ([],at,v',args ++ [a]) + AVr x v -> do + v' <- whnf v ---- + return ([],AtV x,v',[]) + ACn c v -> do + v' <- whnf v ---- + return ([],AtC c,v',[]) + AMeta m v -> do + v' <- whnf v ---- + return ([],AtM m,v',[]) + _ -> Bad "illegal tree" -- AProd + +grammar2theory :: GFCGrammar -> Theory +grammar2theory gr (m,f) = case lookupFunType gr m f of + Ok t -> return $ type2val t + Bad s -> case lookupCatContext gr m f of + Ok cont -> return $ cont2val cont + _ -> Bad s + +cont2exp :: Context -> Exp +cont2exp c = mkProd (c, eType, []) -- to check a context + +cont2val :: Context -> Val +cont2val = type2val . cont2exp + +-- some top-level batch-mode checkers for the compiler + +justTypeCheckSrc :: Grammar -> Exp -> Val -> Err Constraints +justTypeCheckSrc gr e v = do + (_,constrs0) <- checkExp (grammar2theorySrc gr) (initTCEnv []) e v +----- constrs1 <- reduceConstraints gr 0 constrs0 + return $ fst $ splitConstraints constrs0 + +grammar2theorySrc :: Grammar -> Theory +grammar2theorySrc gr (m,f) = case lookupFunTypeSrc gr m f of + Ok t -> return $ type2val t + Bad s -> case lookupCatContextSrc gr m f of + Ok cont -> return $ cont2val cont + _ -> Bad s + +checkContext :: Grammar -> Context -> [String] +checkContext st = checkTyp st . cont2exp + +checkTyp :: Grammar -> Type -> [String] +checkTyp gr typ = err singleton prConstrs $ justTypeCheckSrc gr typ vType + +checkEquation :: Grammar -> Fun -> Trm -> [String] +checkEquation gr (m,fun) def = err singleton id $ do + typ <- lookupFunTypeSrc gr m fun + cs <- justTypeCheckSrc gr def (vClos typ) + let cs1 = cs ----- filter (not . possibleConstraint gr) cs ---- + return $ ifNull [] (singleton . prConstraints) cs1 + +checkConstrs :: Grammar -> Cat -> [Ident] -> [String] +checkConstrs gr cat _ = [] ---- check constructors! + + + + + + +{- ---- +err singleton concat . mapM checkOne where + checkOne con = do + typ <- lookupFunType gr con + typ' <- computeAbsTerm gr typ + vcat <- valCat typ' + return $ if (cat == vcat) then [] else ["wrong type in constructor" +++ prt con] +-} + +editAsTermCommand :: GFCGrammar -> (Loc TrNode -> Err (Loc TrNode)) -> Exp -> [Exp] +editAsTermCommand gr c e = err (const []) singleton $ do + t <- annotate gr $ refreshMetas [] e + t' <- c $ tree2loc t + return $ tree2exp $ loc2tree t' diff --git a/src/GF/Grammar/Unify.hs b/src/GF/Grammar/Unify.hs new file mode 100644 index 000000000..a39087c62 --- /dev/null +++ b/src/GF/Grammar/Unify.hs @@ -0,0 +1,84 @@ +module Unify where + +import Abstract + +import Operations + +import List (partition) + +-- (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 + +unifyVal :: Constraints -> Err (Constraints,MetaSubst) +unifyVal cs0 = do + let (cs1,cs2) = partition notSolvable cs0 + let (us,vs) = unzip cs1 + us' <- mapM val2exp us + vs' <- mapM val2exp vs + let (ms,cs) = unifyAll (zip us' vs') [] + return (cs1 ++ [(VClos [] t, VClos [] u) | (t,u) <- cs], + [(m, VClos [] t) | (m,t) <- ms]) + where + notSolvable (v,w) = case (v,w) of -- don't consider nonempty closures + (VClos (_:_) _,_) -> True + (_,VClos (_:_) _) -> True + _ -> False + +type Unifier = [(MetaSymb, Trm)] +type Constrs = [(Trm, Trm)] + +unifyAll :: Constrs -> Unifier -> (Unifier,Constrs) +unifyAll [] g = (g, []) +unifyAll ((a@(s, t)) : l) g = + let (g1, c) = unifyAll l g + in case unify s t g1 of + Ok g2 -> (g2, c) + _ -> (g1, a : c) + +unify :: Trm -> Trm -> Unifier -> Err Unifier +unify e1 e2 g = + case (e1, e2) of + (Meta s, t) -> do + tg <- subst_all g t + let sg = maybe e1 id (lookup s g) + if (sg == Meta s) then extend g s tg else unify sg tg g + (t, Meta s) -> unify e2 e1 g + (Q _ a, Q _ b) | (a == b) -> return g ---- qualif? + (QC _ a, QC _ b) | (a == b) -> return g ---- + (Vr x, Vr y) | (x == y) -> return g + (Abs x b, Abs y c) -> do let c' = substTerm [x] [(y,Vr x)] c + unify b c' g + (App c a, App d b) -> case unify c d g of + Ok g1 -> unify a b g1 + _ -> prtBad "fail unify" e1 + _ -> prtBad "fail unify" e1 + +extend :: Unifier -> MetaSymb -> Trm -> Err Unifier +extend g s t | (t == Meta s) = return g + | occCheck s t = prtBad "occurs check" t + | True = return ((s, t) : g) + +subst_all :: Unifier -> Trm -> Err Trm +subst_all s u = + case (s,u) of + ([], t) -> return t + (a : l, t) -> do + t' <- (subst_all l t) --- successive substs - why ? + return $ substMetas [a] t' + +substMetas :: [(MetaSymb,Trm)] -> Trm -> Trm +substMetas subst trm = case trm of + Meta x -> case lookup x subst of + Just t -> t + _ -> trm + _ -> composSafeOp (substMetas subst) trm + +occCheck :: MetaSymb -> Trm -> Bool +occCheck s u = case u of + Meta v -> s == v + App c a -> occCheck s c || occCheck s a + Abs x b -> occCheck s b + _ -> False + diff --git a/src/GF/Grammar/Values.hs b/src/GF/Grammar/Values.hs new file mode 100644 index 000000000..7b02d187a --- /dev/null +++ b/src/GF/Grammar/Values.hs @@ -0,0 +1,52 @@ +module Values where + +import Operations +import Zipper + +import Grammar +import Ident + +-- values used in TC type checking + +type Exp = Term + +data Val = VGen Int Ident | VApp Val Val | VCn QIdent | VType | VClos Env Exp + deriving (Eq,Show) + +type Env = [(Ident,Val)] + +-- annotated tree used in editing + +type Tree = Tr TrNode + +newtype TrNode = N (Binds,Atom,Val,(Constraints,MetaSubst),Bool) + deriving (Eq,Show) + +data Atom = AtC Fun | AtM MetaSymb | AtV Ident | AtL String | AtI Int + deriving (Eq,Show) + +type Binds = [(Ident,Val)] +type Constraints = [(Val,Val)] +type MetaSubst = [(MetaSymb,Val)] + +-- for TC + +vType :: Val +vType = VType + +cType :: Ident +cType = identC "Type" --- #0 + +eType :: Exp +eType = Sort "Type" + +tree2exp :: Tree -> Exp +tree2exp (Tr (N (bi,at,_,_,_),ts)) = foldr Abs (foldl App at' ts') bi' where + at' = case at of + AtC (m,c) -> Q m c + AtV i -> Vr i + AtM m -> Meta m + AtL s -> K s + AtI s -> EInt s + bi' = map fst bi + ts' = map tree2exp ts diff --git a/src/GF/Infra/CheckM.hs b/src/GF/Infra/CheckM.hs new file mode 100644 index 000000000..2ce1a4e95 --- /dev/null +++ b/src/GF/Infra/CheckM.hs @@ -0,0 +1,70 @@ +module CheckM where + +import Operations +import Grammar +import Ident +import PrGrammar + +-- the strings are non-fatal warnings +type Check a = STM (Context,[String]) a + +checkError :: String -> Check a +checkError = raise + +checkCond :: String -> Bool -> Check () +checkCond s b = if b then return () else checkError s + +-- warnings should be reversed in the end +checkWarn :: String -> Check () +checkWarn s = updateSTM (\ (cont,msg) -> (cont, s:msg)) + +checkUpdate :: Decl -> Check () +checkUpdate d = updateSTM (\ (cont,msg) -> (d:cont, msg)) + +checkInContext :: [Decl] -> Check r -> Check r +checkInContext g ch = do + i <- checkUpdates g + r <- ch + checkResets i + return r + +checkUpdates :: [Decl] -> Check Int +checkUpdates ds = mapM checkUpdate ds >> return (length ds) + +checkReset :: Check () +checkReset = checkResets 1 + +checkResets :: Int -> Check () +checkResets i = updateSTM (\ (cont,msg) -> (drop i cont, msg)) + +checkGetContext :: Check Context +checkGetContext = do + (co,_) <- readSTM + return co + +checkLookup :: Ident -> Check Type +checkLookup x = do + co <- checkGetContext + checkErr $ maybe (prtBad "unknown variable" x) return $ lookup x co + +checkStart :: Check a -> Err (a,(Context,[String])) +checkStart c = appSTM c ([],[]) + +checkErr :: Err a -> Check a +checkErr e = stm (\s -> do + v <- e + return (v,s) + ) + +checkVal :: a -> Check a +checkVal v = return v + +prtFail :: Print a => String -> a -> Check b +prtFail s t = checkErr $ prtBad s t + +checkIn :: String -> Check a -> Check a +checkIn msg c = stm $ \s@(g,ws) -> case appSTM c s of + Bad e -> Bad $ msg ++++ e + Ok (v,(g',ws')) -> Ok (v,(g',ws2)) where + new = take (length ws' - length ws) ws' + ws2 = [msg ++++ w | w <- new] ++ ws diff --git a/src/GF/Infra/Ident.hs b/src/GF/Infra/Ident.hs new file mode 100644 index 000000000..3e564460c --- /dev/null +++ b/src/GF/Infra/Ident.hs @@ -0,0 +1,117 @@ +module Ident where + +import Operations +-- import Monad + +data Ident = + IC String -- raw identifier after parsing, resolved in Rename + | IW -- wildcard + +-- below this line: internal representation never returned by the parser + | IV (Int,String) -- variable + | IA (String,Int) -- argument of cat at position + | IAV (String,Int,Int) -- argument of cat with bindings at position + + deriving (Eq, Ord, Show, Read) + +prIdent :: Ident -> String +prIdent i = case i of + IC s -> s + IV (n,s) -> s ++ "_" ++ show n + IA (s,j) -> s ++ "_" ++ show j + IAV (s,b,j) -> s ++ "_" ++ show b ++ "_" ++ show j + IW -> "_" + +(identC, identV, identA, identAV, identW) = + (IC, IV, IA, IAV, IW) + +-- normal identifier +-- ident s = IC s + +-- to mark argument variables +argIdent 0 (IC c) i = identA (c,i) +argIdent b (IC c) i = identAV (c,b,i) + +-- used in lin defaults +strVar = identA ("str",0) + +-- wild card +wildIdent = identW + +isWildIdent :: Ident -> Bool +isWildIdent = (== wildIdent) + +newIdent = identC "#h" + +mkIdent :: String -> Int -> Ident +mkIdent s i = identV (i,s) + +varIndex :: Ident -> Int +varIndex (IV (n,_)) = n +varIndex _ = -1 --- other than IV should not count + +-- refreshing identifiers + +type IdState = ([(Ident,Ident)],Int) + +initIdStateN :: Int -> IdState +initIdStateN i = ([],i) + +initIdState :: IdState +initIdState = initIdStateN 0 + +lookVar :: Ident -> STM IdState Ident +lookVar a@(IA _) = return a +lookVar x = do + (sys,_) <- readSTM + stm (\s -> maybe (Bad ("cannot find" +++ show x +++ prParenth (show sys))) + return $ + lookup x sys >>= (\y -> return (y,s))) + +refVar :: Ident -> STM IdState Ident +----refVar IW = return IW --- no update of wildcard +refVar x = do + (_,m) <- readSTM + let x' = IV (m, prIdent x) + updateSTM (\ (sys,mx) -> ((x, x'):sys, mx + 1)) + return x' + +refVarPlus :: Ident -> STM IdState Ident +----refVarPlus IW = refVar (identC "h") +refVarPlus x = refVar x + + +{- +------------------------------ +-- to test + +refreshExp :: Exp -> Err Exp +refreshExp e = err Bad (return . fst) (appSTM (refresh e) initState) + +refresh :: Exp -> STM State Exp +refresh e = case e of + Atom x -> lookVar x >>= return . Atom + App f a -> liftM2 App (refresh f) (refresh a) + Abs x b -> liftM2 Abs (refVar x) (refresh b) + Fun xs a b -> do + a' <- refresh a + xs' <- mapM refVar xs + b' <- refresh b + return $ Fun xs' a' b' + +data Exp = + Atom Ident + | App Exp Exp + | Abs Ident Exp + | Fun [Ident] Exp Exp + deriving Show + +exp1 = Abs (IC "y") (Atom (IC "y")) +exp2 = Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y"))) +exp3 = Abs (IC "y") (Abs (IC "z") (App (Atom (IC "y")) (Atom (IC "z")))) +exp4 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "z")))) +exp5 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y")))) +exp6 = Abs (IC "y") (Fun [IC "x", IC "y"] (Atom (IC "y")) (Atom (IC "y"))) +exp7 = Abs (IL "8") (Atom (IC "y")) + +-} diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs new file mode 100644 index 000000000..01b789f8f --- /dev/null +++ b/src/GF/Infra/Modules.hs @@ -0,0 +1,181 @@ +module Modules where + +import Ident +import Option +import Operations + +import List + + +-- AR 29/4/2003 + +-- The same structure will be used in both source code and canonical. +-- The parameters tell what kind of data is involved. +-- Invariant: modules are stored in dependency order + +data MGrammar i f a = MGrammar {modules :: [(i,ModInfo i f a)]} + deriving Show + +data ModInfo i f a = + ModMainGrammar (MainGrammar i) + | ModMod (Module i f a) + deriving Show + +data Module i f a = Module { + mtype :: ModuleType i , + flags :: [f] , + extends :: Maybe i , + opens :: [OpenSpec i] , + jments :: BinTree (i,a) + } + deriving Show + +-- destructive update + +--- dep order preserved since old cannot depend on new +updateMGrammar :: Ord i => MGrammar i f a -> MGrammar i f a -> MGrammar i f a +updateMGrammar old new = MGrammar $ + [(i,m) | (i,m) <- os, notElem i (map fst ns)] ++ ns + where + os = modules old + ns = modules new + +updateModule :: Ord i => Module i f t -> i -> t -> Module i f t +updateModule (Module mt fs me ops js) i t = + Module mt fs me ops (updateTree (i,t) js) + +data MainGrammar i = MainGrammar { + mainAbstract :: i , + mainConcretes :: [MainConcreteSpec i] + } + deriving Show + +data MainConcreteSpec i = MainConcreteSpec { + concretePrintname :: i , + concreteName :: i , + transferIn :: Maybe (OpenSpec i) , -- if there is an in-transfer + transferOut :: Maybe (OpenSpec i) -- if there is an out-transfer + } + deriving Show + +data OpenSpec i = OSimple i | OQualif i i + deriving (Eq,Show) + +openedModule :: OpenSpec i -> i +openedModule o = case o of + OSimple m -> m + OQualif _ m -> m + +-- initial dependency list +depPathModule :: Ord i => Module i f a -> [OpenSpec i] +depPathModule m = fors m ++ exts m ++ opens m where + fors m = case mtype m of + MTTransfer i j -> [i,j] + MTConcrete i -> [OSimple i] + _ -> [] + exts m = map OSimple $ maybe [] return $ extends m + +-- all modules that a module extends, directly or indirectly +allExtends :: (Show i,Ord i) => MGrammar i f a -> i -> [i] +allExtends gr i = case lookupModule gr i of + Ok (ModMod m) -> case extends m of + Just i1 -> i : allExtends gr i1 + _ -> [i] + _ -> [] + +-- initial search path: the nonqualified dependencies +searchPathModule :: Ord i => Module i f a -> [i] +searchPathModule m = [i | OSimple i <- depPathModule m] + +-- a new module can safely be added to the end, since nothing old can depend on it +addModule :: Ord i => + MGrammar i f a -> i -> ModInfo i f a -> MGrammar i f a +addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)]) + +emptyMGrammar :: MGrammar i f a +emptyMGrammar = MGrammar [] + + +-- we store the module type with the identifier + +data IdentM i = IdentM { + identM :: i , + typeM :: ModuleType i + } + deriving (Eq,Show) + +-- encoding the type of the module +data ModuleType i = + MTAbstract + | MTTransfer (OpenSpec i) (OpenSpec i) + | MTResource + | MTResourceInt + | MTResourceImpl i + | MTConcrete i + | MTConcreteInt i i + | MTConcreteImpl i i i + | MTReuse i + deriving (Eq,Show) + +typeOfModule mi = case mi of + ModMod m -> mtype m + +isResourceModule mi = case typeOfModule mi of + MTResource -> True + MTReuse _ -> True + MTResourceInt -> True + MTResourceImpl _ -> True + _ -> False + +abstractOfConcrete :: (Show i, Eq i) => MGrammar i f a -> i -> Err i +abstractOfConcrete gr c = do + m <- lookupModule gr c + case m of + ModMod n -> case mtype n of + MTConcrete a -> return a + _ -> Bad $ "expected concrete" +++ show c + _ -> Bad $ "expected concrete" +++ show c + +abstractModOfConcrete :: (Show i, Eq i) => + MGrammar i f a -> i -> Err (Module i f a) +abstractModOfConcrete gr c = do + a <- abstractOfConcrete gr c + m <- lookupModule gr a + case m of + ModMod n -> return n + _ -> Bad $ "expected abstract" +++ show c + + +-- the canonical file name + +--- canonFileName s = prt s ++ ".gfc" + +lookupModule :: (Show i,Eq i) => MGrammar i f a -> i -> Err (ModInfo i f a) +lookupModule gr m = case lookup m (modules gr) of + Just i -> return i + _ -> Bad $ "unknown module" +++ show m + +++ "among" +++ unwords (map (show . fst) (modules gr)) ---- debug + +lookupModuleType :: (Show i,Eq i) => MGrammar i f a -> i -> Err (ModuleType i) +lookupModuleType gr m = do + mi <- lookupModule gr m + return $ typeOfModule mi + +lookupInfo :: (Show i, Ord i) => Module i f a -> i -> Err a +lookupInfo mo i = lookupTree show i (jments mo) + +isModAbs m = case mtype m of + MTAbstract -> True + _ -> False + +isModRes m = case mtype m of + MTResource -> True + _ -> False + +isModCnc m = case mtype m of + MTConcrete _ -> True + _ -> False + +sameMType m n = case (m,n) of + (MTConcrete _, MTConcrete _) -> True + _ -> m == n diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs new file mode 100644 index 000000000..e81c9cd82 --- /dev/null +++ b/src/GF/Infra/Option.hs @@ -0,0 +1,204 @@ +module Option where + +import List (partition) +import Char (isDigit) + +-- all kinds of options, to be kept abstract + +newtype Option = Opt (String,[String]) deriving (Eq,Show,Read) +newtype Options = Opts [Option] deriving (Eq,Show,Read) + +noOptions :: Options +noOptions = Opts [] + +iOpt o = Opt (o,[]) -- simple option -o +aOpt o a = Opt (o,[a]) -- option with argument -o=a +iOpts = Opts + +oArg s = s -- value of option argument + +oElem :: Option -> Options -> Bool +oElem o (Opts os) = elem o os + +type OptFun = String -> Option + +getOptVal :: Options -> OptFun -> Maybe String +getOptVal (Opts os) fopt = + case [a | opt@(Opt (o,[a])) <- os, opt == fopt a] of + a:_ -> Just a + _ -> Nothing + +getOptInt :: Options -> OptFun -> Maybe Int +getOptInt opts f = do + s <- getOptVal opts f + if (not (null s) && all isDigit s) then return (read s) else Nothing + +optIntOrAll :: Options -> OptFun -> [a] -> [a] +optIntOrAll opts f = case getOptInt opts f of + Just i -> take i + _ -> id + +optIntOrN :: Options -> OptFun -> Int -> Int +optIntOrN opts f n = case getOptInt opts f of + Just i -> i + _ -> n + +optIntOrOne :: Options -> OptFun -> Int +optIntOrOne opts f = optIntOrN opts f 1 + +changeOptVal :: Options -> OptFun -> String -> Options +changeOptVal os f x = + addOption (f x) $ maybe os (\y -> removeOption (f y) os) $ getOptVal os f + +addOption :: Option -> Options -> Options +addOption o (Opts os) = iOpts (o:os) + +addOptions (Opts os) os0 = foldr addOption os0 os + +removeOption :: Option -> Options -> Options +removeOption o (Opts os) = iOpts (filter (/=o) os) + +removeOptions (Opts os) os0 = foldr removeOption os0 os + +options = foldr addOption noOptions + +unionOptions :: Options -> Options -> Options +unionOptions (Opts os) (Opts os') = Opts (os ++ os') + +-- parsing options, with prefix pre (e.g. "-") + +getOptions :: String -> [String] -> (Options, [String]) +getOptions pre inp = let + (os,rest) = span (isOption pre) inp -- options before args + in + (Opts (map (pOption pre) os), rest) + +pOption :: String -> String -> Option +pOption pre s = case span (/= '=') (drop (length pre) s) of + (f,_:a) -> aOpt f a + (o,[]) -> iOpt o + +isOption :: String -> String -> Bool +isOption pre = (==pre) . take (length pre) + +-- printing options, without prefix + +prOpt (Opt (s,[])) = s +prOpt (Opt (s,xs)) = s ++ "=" ++ concat xs +prOpts (Opts os) = unwords $ map prOpt os + +-- a suggestion for option names + +-- parsing +strictParse = iOpt "strict" +forgiveParse = iOpt "n" +ignoreParse = iOpt "ign" +literalParse = iOpt "lit" +rawParse = iOpt "raw" +firstParse = iOpt "1" +dontParse = iOpt "read" -- parse as term instead of string + +-- grammar formats +showAbstr = iOpt "abs" +showXML = iOpt "xml" +showOld = iOpt "old" +showLatex = iOpt "latex" +showFullForm = iOpt "fullform" +showEBNF = iOpt "ebnf" +showCF = iOpt "cf" +showWords = iOpt "ws" +showOpts = iOpt "opts" +-- showOptim = iOpt "opt" +isCompiled = iOpt "gfc" +isHaskell = iOpt "gfhs" +noCompOpers = iOpt "nocomp" +retainOpers = iOpt "retain" +defaultGrOpts = [] +newParser = iOpt "new" +noCF = iOpt "nocf" +checkCirc = iOpt "nocirc" +noCheckCirc = iOpt "nocheckcirc" + +-- linearization +allLin = iOpt "all" +firstLin = iOpt "one" +distinctLin = iOpt "nub" +dontLin = iOpt "show" +showRecord = iOpt "record" +showStruct = iOpt "structured" +xmlLin = showXML +latexLin = showLatex +tableLin = iOpt "table" +defaultLinOpts = [firstLin] +useUTF8 = iOpt "utf8" + +-- other +beVerbose = iOpt "v" +showInfo = iOpt "i" +beSilent = iOpt "s" +emitCode = iOpt "o" +makeMulti = iOpt "multi" +beShort = iOpt "short" +wholeGrammar = iOpt "w" +makeFudget = iOpt "f" +byLines = iOpt "lines" +byWords = iOpt "words" +analMorpho = iOpt "morpho" +doTrace = iOpt "tr" +noCPU = iOpt "nocpu" +doCompute = iOpt "c" +optimizeCanon = iOpt "opt" + +-- mainly for stand-alone +useUnicode = iOpt "unicode" +optCompute = iOpt "compute" +optCheck = iOpt "typecheck" +optParaphrase = iOpt "paraphrase" +forJava = iOpt "java" + +-- for edit session +allLangs = iOpt "All" +absView = iOpt "Abs" + +-- options that take arguments +useTokenizer = aOpt "lexer" +useUntokenizer = aOpt "unlexer" +useParser = aOpt "parser" +firstCat = aOpt "cat" -- used on command line +gStartCat = aOpt "startcat" -- used in grammar, to avoid clash w res word +useLanguage = aOpt "lang" +speechLanguage = aOpt "language" +useFont = aOpt "font" +grammarFormat = aOpt "format" +grammarPrinter = aOpt "printer" +filterString = aOpt "filter" +termCommand = aOpt "transform" +transferFun = aOpt "transfer" +forForms = aOpt "forms" +menuDisplay = aOpt "menu" +sizeDisplay = aOpt "size" +typeDisplay = aOpt "types" +noDepTypes = aOpt "nodeptypes" +extractGr = aOpt "extract" +pathList = aOpt "path" + +-- refinement order +nextRefine = aOpt "nextrefine" +firstRefine = oArg "first" +lastRefine = oArg "last" + +-- Boolean flags +flagYes = oArg "yes" +flagNo = oArg "no" + +-- integer flags +flagDepth = aOpt "depth" +flagLength = aOpt "length" +flagNumber = aOpt "number" + +caseYesNo :: Options -> OptFun -> Maybe Bool +caseYesNo opts f = do + v <- getOptVal opts f + if v == flagYes then return True + else if v == flagNo then return False + else Nothing diff --git a/src/GF/Infra/ReadFiles.hs b/src/GF/Infra/ReadFiles.hs new file mode 100644 index 000000000..f755397f2 --- /dev/null +++ b/src/GF/Infra/ReadFiles.hs @@ -0,0 +1,135 @@ +module ReadFiles where + +import Arch (selectLater, modifiedFiles, ModTime) + +import Operations +import UseIO +import System +import Char +import Monad + +-- make analysis for GF grammar modules. AR 11/6/2003 + +-- to find all files that have to be read, put them in dependency order, and +-- decide which files need recompilation. Name file.gf is returned for them, +-- and file.gfc or file.gfr otherwise. + +type ModName = String +type FileName = String +type InitPath = String +type FullPath = String + +getAllFiles :: [InitPath] -> [(FullPath,ModTime)] -> FileName -> + IOE [FullPath] +getAllFiles ps env file = do + ds <- getImports ps file + -- print ds ---- debug + ds1 <- ioeErr $ either + return + (\ms -> Bad $ "circular modules" +++ unwords (map show (head ms))) $ + topoTest $ map fst ds + let paths = [(f,p) | ((f,_),p) <- ds] + let pds1 = [(p,f) | f <- ds1, Just p <- [lookup f paths]] + ds2 <- ioeIO $ mapM selectFormat pds1 + -- print ds2 ---- debug + let ds3 = needCompile ds ds2 + ds4 <- ioeIO $ modifiedFiles env ds3 + return ds4 + +getImports :: [InitPath] -> FileName -> IOE [((ModName,[ModName]),InitPath)] +getImports ps = get [] where + get ds file = do + let name = fileBody file + (p,s) <- readFileIfPath ps $ file + let imps = importsOfFile s + case imps of + _ | elem name (map (fst . fst) ds) -> return ds --- file already read + [] -> return $ ((name,[]),p):ds + _ -> do + let files = map gfFile imps + foldM get (((name,imps),p):ds) files + +-- to decide whether to read gf or gfc; returns full file path + +selectFormat :: (InitPath,ModName) -> IO (ModName,(FullPath,Bool)) +selectFormat (p,f) = do + let pf = prefixPathName p f + f0 <- selectLater (gfFile pf) (gfcFile pf) + f1 <- selectLater (gfrFile pf) f0 + return $ (f, (f1, f1 == gfFile pf)) -- True if needs compile + +needCompile :: [((ModName,[ModName]),InitPath)] -> [(ModName,(FullPath,Bool))] -> + [FullPath] +needCompile deps sfiles = filt $ mark $ iter changed where + + -- start with the changed files themselves; returns [ModName] + changed = [f | (f,(_,True)) <- sfiles] + + -- add other files that depend on some changed file; returns [ModName] + iter np = let new = [f | ((f,fs),_) <- deps, + not (elem f np), any (flip elem np) fs] + in if null new then np else (iter (new ++ np)) + + -- for each module in the full list, choose source file if change is needed + -- returns [FullPath] + mark cs = [f' | (f,(file,_)) <- sfiles, + let f' = if (elem f cs) then gfFile (fileBody file) else file] + + -- if the top file is gfc, only gfc files need be read (could be even better)--- + filt ds = if isGFC (last ds) + then [gfcFile name | f <- ds, + let (name,suff) = nameAndSuffix f, elem suff ["gfc","gfr"]] + else ds + +isGFC = (== "gfc") . fileSuffix + +gfcFile = suffixFile "gfc" +gfrFile = suffixFile "gfr" +gfFile = suffixFile "gf" + +-- to get imports without parsing the file + +importsOfFile :: String -> [FilePath] +importsOfFile = + filter (not . spec) . -- ignore keywords and special symbols + unqual . -- take away qualifiers + takeWhile (not . term) . -- read until curly or semic + drop 2 . -- ignore keyword and module name + lexs . -- analyse into lexical tokens + unComm -- ignore comments before the headed line + where + term = flip elem ["{",";"] + spec = flip elem ["of", "open","in", "reuse", "=", "(", ")",",","**"] + unqual ws = case ws of + "(":q:ws' -> unqual ws' + w:ws' -> w:unqual ws' + _ -> ws + +unComm s = case s of + '-':'-':cs -> unComm $ dropWhile (/='\n') cs + '{':'-':cs -> dpComm cs + c:cs -> c : unComm cs + _ -> s + +dpComm s = case s of + '-':'}':cs -> unComm cs + c:cs -> dpComm cs + _ -> s + +lexs s = x:xs where + (x,y) = head $ lex s + xs = if null y then [] else lexs y + +-- old GF tolerated newlines in quotes. No more supported! +fixNewlines s = case s of + '"':cs -> '"':mk cs + c :cs -> c:fixNewlines cs + _ -> s + where + mk s = case s of + '\\':'"':cs -> '\\':'"': mk cs + '"' :cs -> '"' :fixNewlines cs + '\n' :cs -> '\\':'n': mk cs + c :cs -> c : mk cs + _ -> s + diff --git a/src/GF/Infra/UseIO.hs b/src/GF/Infra/UseIO.hs new file mode 100644 index 000000000..bd9d9e22a --- /dev/null +++ b/src/GF/Infra/UseIO.hs @@ -0,0 +1,245 @@ +module UseIO where + +import Operations +import Arch (prCPU) +import Option + +import IO +import System +import Monad + +putShow' :: Show a => (c -> a) -> c -> IO () +putShow' f = putStrLn . show . length . show . f + +putIfVerb opts msg = + if oElem beVerbose opts + then putStrLn msg + else return () + +putIfVerbW opts msg = + if oElem beVerbose opts + then putStr (' ' : msg) + else return () + +-- obsolete with IOE monad +errIO :: a -> Err a -> IO a +errIO = errOptIO noOptions + +errOptIO :: Options -> a -> Err a -> IO a +errOptIO os e m = case m of + Ok x -> return x + Bad k -> do + putIfVerb os k + return e + +prOptCPU opts = if (oElem noCPU opts) then (const (return 0)) else prCPU + +putCPU = do + prCPU 0 + return () + +putPoint :: Show a => Options -> String -> IO a -> IO a +putPoint = putPoint' id + +putPoint' :: Show a => (c -> a) -> Options -> String -> IO c -> IO c +putPoint' f opts msg act = do + let sil x = if oElem beSilent opts then return () else x + ve x = if oElem beVerbose opts then x else return () + ve $ putStrLn msg + a <- act + ve $ putShow' f a + ve $ putCPU + return a + +readFileIf :: String -> IO String +readFileIf f = catch (readFile f) (\_ -> reportOn f) where + reportOn f = do + putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string") + return "" + +getFilePath :: [FilePath] -> String -> IO (Maybe FilePath) +getFilePath paths file = get paths where + get [] = putStrLnFlush ("file" +++ file +++ "not found") >> return Nothing + get (p:ps) = let pfile = prefixPathName p file in + catch (readFile pfile >> return (Just pfile)) (\_ -> get ps) + +readFileIfPath :: [FilePath] -> String -> IOE (FilePath,String) +readFileIfPath paths file = do + mpfile <- ioeIO $ getFilePath paths file + case mpfile of + Just pfile -> do + s <- ioeIO $ readFile pfile + return (justInitPath pfile,s) + _ -> ioeErr $ Bad ("File " ++ file ++ " does not exist.") + +pFilePaths :: String -> [FilePath] +pFilePaths s = case span (/=':') s of + (f,_:cs) -> f : pFilePaths cs + (f,_) -> [f] + +prefixPathName :: String -> FilePath -> FilePath +prefixPathName "" f = f +prefixPathName p f = p ++ "/" ++ f + +justInitPath :: FilePath -> FilePath +justInitPath = reverse . drop 1 . dropWhile (/='/') . reverse + +nameAndSuffix :: FilePath -> (String,String) +nameAndSuffix file = case span (/='.') (reverse file) of + (_,[]) -> (file,[]) + (xet,deman) -> if elem '/' xet + then (file,[]) + else (reverse $ drop 1 deman,reverse xet) + +unsuffixFile, fileBody :: FilePath -> String +unsuffixFile = fst . nameAndSuffix +fileBody = unsuffixFile + +fileSuffix :: FilePath -> String +fileSuffix = snd . nameAndSuffix + +justFileName :: FilePath -> String +justFileName = reverse . takeWhile (/='/') . reverse + +suffixFile :: String -> FilePath -> FilePath +suffixFile suff file = file ++ "." ++ suff + +-- + +getLineWell :: IO String -> IO String +getLineWell ios = + catch getLine (\e -> if (isEOFError e) then ios else ioError e) + +putStrFlush :: String -> IO () +putStrFlush s = putStr s >> hFlush stdout + +putStrLnFlush :: String -> IO () +putStrLnFlush s = putStrLn s >> hFlush stdout + +-- a generic quiz session + +type QuestionsAndAnswers = [(String, String -> (Integer,String))] + +teachDialogue :: QuestionsAndAnswers -> String -> IO () +teachDialogue qas welc = do + putStrLn $ welc ++++ genericTeachWelcome + teach (0,0) qas + where + teach _ [] = do putStrLn "Sorry, ran out of problems" + teach (score,total) ((question,grade):quas) = do + putStr ("\n" ++ question ++ "\n> ") + answer <- getLine + if (answer == ".") then return () else do + let (result, feedback) = grade answer + score' = score + result + total' = total + 1 + putStr (feedback ++++ "Score" +++ show score' ++ "/" ++ show total') + if (total' > 9 && fromInteger score' / fromInteger total' >= 0.75) + then do putStrLn "\nCongratulations - you passed!" + else teach (score',total') quas + + genericTeachWelcome = + "The quiz is over when you have done at least 10 examples" ++++ + "with at least 75 % success." +++++ + "You can interrupt the quiz by entering a line consisting of a dot ('.').\n" + + +-- IO monad with error; adapted from state monad + +newtype IOE a = IOE (IO (Err a)) + +appIOE :: IOE a -> IO (Err a) +appIOE (IOE iea) = iea + +ioe :: IO (Err a) -> IOE a +ioe = IOE + +ioeIO :: IO a -> IOE a +ioeIO io = ioe (io >>= return . return) + +ioeErr :: Err a -> IOE a +ioeErr = ioe . return + +instance Monad IOE where + return a = ioe (return (return a)) + IOE c >>= f = IOE $ do + x <- c -- Err a + appIOE $ err ioeBad f x -- f :: a -> IOE a + +ioeBad :: String -> IOE a +ioeBad = ioe . return . Bad + +useIOE :: a -> IOE a -> IO a +useIOE a ioe = appIOE ioe >>= err (\s -> putStrLn s >> return a) return + +putStrLnE :: String -> IOE () +putStrLnE = ioeIO . putStrLnFlush + +putStrE :: String -> IOE () +putStrE = ioeIO . putStrFlush + +putPointE :: Options -> String -> IOE a -> IOE a +putPointE opts msg act = do + let ve x = if oElem beVerbose opts then x else return () + ve $ ioeIO $ putStrFlush msg + a <- act +--- ve $ ioeIO $ putShow' id a --- replace by a statistics command + ve $ ioeIO $ putStrFlush " " + ve $ ioeIO $ putCPU + return a +{- +putPointE :: Options -> String -> IOE a -> IOE a +putPointE opts msg act = do + let ve x = if oElem beVerbose opts then x else return () + ve $ putStrE msg + a <- act +--- ve $ ioeIO $ putShow' id a --- replace by a statistics command + ve $ ioeIO $ putCPU + return a +-} + +-- forces verbosity +putPointEVerb :: Options -> String -> IOE a -> IOE a +putPointEVerb opts = putPointE (addOption beVerbose opts) + +-- ((do {s <- readFile f; return (return s)}) ) +readFileIOE :: FilePath -> IOE (String) +readFileIOE f = ioe $ catch (readFile f >>= return . return) + (\_ -> return (Bad (reportOn f))) where + reportOn f = "File " ++ f ++ " not found." + +-- like readFileIOE but look also in the GF library if file not found +-- intended semantics: if file is not found, try $GF_LIB_PATH/file +-- (even if file is an absolute path, but this should always fail) +-- it returns not only contents of the file, but also the path used +readFileLibraryIOE :: String -> FilePath -> IOE (FilePath, String) +readFileLibraryIOE ini f = + ioe $ catch ((do {s <- readFile initPath; return (return (initPath,s))})) + (\_ -> tryLibrary ini f) where + tryLibrary :: String -> FilePath -> IO (Err (FilePath, String)) + tryLibrary ini f = + catch (do { + lp <- getLibPath; + s <- readFile (lp ++ f); + return (return (lp ++ f, s)) + }) (\_ -> return (Bad (reportOn f))) + initPath = addInitFilePath ini f + getLibPath :: IO String + getLibPath = do { + lp <- getEnv "GF_LIB_PATH"; + return (if last lp == '/' then lp else lp ++ ['/']); + } + reportOn f = "File " ++ f ++ " not found." + libPath ini f = f + addInitFilePath ini file = case file of + '/':_ -> file -- absolute path name + _ -> ini ++ file -- relative path name + + +-- example +koeIOE :: IO () +koeIOE = useIOE () $ do + s <- ioeIO $ getLine + s2 <- ioeErr $ mapM (!? 2) $ words s + ioeIO $ putStrLn s2 + diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs new file mode 100644 index 000000000..6e4afe88f --- /dev/null +++ b/src/GF/Shell.hs @@ -0,0 +1,292 @@ +module Shell where + +--- abstract away from these? +import Str +import qualified Grammar as G +import qualified Ident as I +import qualified Compute as Co +import qualified GFC +import Values +import GetTree + +import API +import IOGrammar +import Compile +---- import GFTex +-----import TeachYourself -- also a subshell + +import ShellState +import Option +import Information +import HelpFile +import PrOld +import PrGrammar + +import Monad (foldM) +import System (system) + +import Operations +import UseIO +import UTF8 (encodeUTF8) + + +---- import qualified GrammarToGramlet as Gr +---- import qualified GrammarToCanonXML2 as Canon + +-- AR 18/4/2000 - 7/11/2001 + +type SrcTerm = G.Term -- term as returned by the command parser + +data Command = + CImport FilePath + | CRemoveLanguage Language + | CEmptyState + | CTransformGrammar FilePath + | CConvertLatex FilePath + + | CLinearize [()] ---- parameters + | CParse + | CTranslate Language Language + | CGenerateRandom Int + | CPutTerm + | CWrapTerm Ident + | CMorphoAnalyse + | CTestTokenizer + | CComputeConcrete I.Ident String + + | CTranslationQuiz Language Language + | CTranslationList Language Language Int + | CMorphoQuiz + | CMorphoList Int + + | CReadFile FilePath + | CWriteFile FilePath + | CAppendFile FilePath + | CSpeakAloud + | CPutString + | CShowTerm + | CSystemCommand String + + | CSetFlag + | CSetLocalFlag Language + + | CPrintGrammar + | CPrintGlobalOptions + | CPrintLanguages + | CPrintInformation I.Ident + | CPrintMultiGrammar + | CPrintGramlet + | CPrintCanonXML + | CPrintCanonXMLStruct + | CPrintHistory + | CHelp + + | CImpure ImpureCommand + + | CVoid + +-- to isolate the commands that are executed on top level +data ImpureCommand = + ICQuit | ICExecuteHistory FilePath | ICEarlierCommand Int + | ICEditSession | ICTranslateSession + +type CommandLine = (CommandOpt, CommandArg, [CommandOpt]) + +type CommandOpt = (Command, Options) + +type HState = (ShellState,([String],Integer)) -- history & CPU + +type ShellIO = (HState, CommandArg) -> IO (HState, CommandArg) + +initHState :: ShellState -> HState +initHState st = (st,([],0)) + +cpuHState (_,(_,i)) = i +optsHState (st,_) = globalOptions st +putHStateCPU cpu (st,(h,_)) = (st,(h,cpu)) +updateHistory s (st,(h,cpu)) = (st,(s:h,cpu)) +earlierCommandH (_,(h,_)) = ((h ++ repeat "") !!) -- empty command if index over + +execLinesH :: String -> [CommandLine] -> HState -> IO HState +execLinesH s cs hst@(st, (h, _)) = do + (_,st') <- execLines True cs hst + cpu <- prOptCPU (optsHState st') (cpuHState hst) + return $ putHStateCPU cpu $ updateHistory s st' + +ifImpure :: [CommandLine] -> Maybe (ImpureCommand,Options) +ifImpure cls = foldr (const . Just) Nothing [(c,os) | ((CImpure c,os),_,_) <- cls] + +-- the main function: execution of commands. put :: Bool forces immediate output + +-- command line with consecutive (;) commands: no value transmitted +execLines :: Bool -> [CommandLine] -> HState -> IO ([String],HState) +execLines put cs st = foldM (flip (execLine put)) ([],st) cs + +-- command line with piped (|) commands: no value returned +execLine :: Bool -> CommandLine -> ([String],HState) -> IO ([String],HState) +execLine put (c@(co, os), arg, cs) (outps,st) = do + (st',val) <- execC c (st, arg) + let tr = oElem doTrace os || null cs -- option -tr leaves trace in pipe + utf = if (oElem useUTF8 os) then encodeUTF8 else id + outp = if tr then [utf (prCommandArg val)] else [] + if put then mapM_ putStrLnFlush outp else return () + execs cs val (if put then [] else outps ++ outp, st') + where + execs [] arg st = return st + execs (c:cs) arg st = execLine put (c, arg, cs) st + +-- individual commands possibly piped: value returned; this is not a state monad +execC :: CommandOpt -> ShellIO +execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of + + --- read old GF and write into files; no update of st yet + CImport file | oElem showOld opts -> useIOE sa $ batchCompileOld file >> return sa + + CImport file -> useIOE sa $ do + st <- shellStateFromFiles opts st file + ioeIO $ changeState (const st) sa --- \ ((_,h),a) -> ((st,h), a)) + CEmptyState -> changeState reinitShellState sa + +{- + CRemoveLanguage lan -> changeState (removeLanguage lan) sa + CTransformGrammar file -> do + s <- transformGrammarFile opts file + returnArg (AString s) sa + CConvertLatex file -> do + s <- readFileIf file + returnArg (AString (convertGFTex s)) sa +-} + CPrintHistory -> (returnArg $ AString $ unlines $ reverse h) sa + -- good to have here for piping; eh and ec must be done on outer level + + CLinearize [] -> changeArg (opTS2CommandArg (optLinearizeTreeVal opts gro) . s2t) sa +---- CLinearize m -> changeArg (opTS2CommandArg (optLinearizeArgForm opts gro m)) sa + + CParse -> case optParseArgErrMsg opts gro (prCommandArg a) of + Ok (ts,msg) -> putStrLnFlush msg >> changeArg (const $ ATrms ts) sa + Bad msg -> changeArg (const $ AError msg) sa + + CTranslate il ol -> do + let a' = opST2CommandArg (optParseArgErr opts (sgr il)) a + returnArg (opTS2CommandArg (optLinearizeTreeVal opts (sgr ol)) a') sa + CGenerateRandom n -> do + ts <- randomTreesIO opts gro (optIntOrN opts flagNumber n) + returnArg (ATrms ts) sa +----- CPutTerm -> changeArg (opTT2CommandArg (optTermCommand opts gro) . s2t) sa +----- CWrapTerm f -> changeArg (opTT2CommandArg (return . wrapByFun opts gro f)) sa + CMorphoAnalyse -> changeArg (AString . morphoAnalyse opts gro . prCommandArg) sa + CTestTokenizer -> changeArg (AString . optTokenizer opts gro . prCommandArg) sa + + CComputeConcrete m t -> + justOutput (putStrLn (err id prt ( + string2srcTerm src m t >>= Co.computeConcrete src))) sa + +{- ---- + CTranslationQuiz il ol -> justOutput (teachTranslation opts (sgr il) (sgr ol)) sa + CTranslationList il ol n -> do + qs <- transTrainList opts (sgr il) (sgr ol) (toInteger n) + returnArg (AString $ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa + + CMorphoQuiz -> justOutput (teachMorpho opts gro) sa + CMorphoList n -> do + qs <- useIOE [] $ morphoTrainList opts gro (toInteger n) + returnArg (AString $ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa +-} + CReadFile file -> returnArgIO (readFileIf file >>= return . AString) sa + CWriteFile file -> justOutputArg (writeFile file) sa + CAppendFile file -> justOutputArg (appendFile file) sa + CSpeakAloud -> justOutputArg (speechGenerate opts) sa + CSystemCommand s -> justOutput (system s >> return ()) sa +----- CPutString -> changeArg (opSS2CommandArg (optStringCommand opts gro)) sa +----- CShowTerm -> changeArg (opTS2CommandArg (optPrintTerm opts gro) . s2t) sa + + CSetFlag -> changeState (addGlobalOptions opts0) sa +---- deprec! CSetLocalFlag lang -> changeState (addLocalOptions lang opts0) sa + + CHelp -> returnArg (AString txtHelpFile) sa + + CPrintGrammar + | oElem showOld opts -> returnArg (AString $ printGrammarOld (canModules st)) sa + | otherwise -> returnArg (AString (optPrintGrammar opts gro)) sa + CPrintGlobalOptions -> justOutput (putStrLn $ prShellStateInfo st) sa + CPrintInformation c -> justOutput (useIOE () $ showInformation opts st c) sa + CPrintLanguages -> justOutput + (putStrLn $ unwords $ map prLanguage $ allLanguages st) sa +---- CPrintMultiGrammar -> returnArg (AString (prMultiGrammar opts st)) sa +---- CPrintGramlet -> returnArg (AString (Gr.prGramlet st)) sa +---- CPrintCanonXML -> returnArg (AString (Canon.prCanonXML st False)) sa +---- CPrintCanonXMLStruct -> returnArg (AString (Canon.prCanonXML st True)) sa + _ -> justOutput (putStrLn "command not understood") sa + + where + sgr = stateGrammarOfLang st + gro = grammarOfOptState opts st + opts = addOptions opts0 (globalOptions st) + src = srcModules st + + s2t a = case a of + ASTrm s -> err AError (ATrms . return) $ string2treeErr gro s + _ -> a + + +-- commands either change the state or process the argument, but not both +-- some commands just do output + +changeState :: ShellStateOper -> ShellIO +changeState f ((st,h),a) = return ((f st,h), a) + +changeArg :: (CommandArg -> CommandArg) -> ShellIO +changeArg f (st,a) = return (st, f a) + +changeArgMsg :: (CommandArg -> (CommandArg,String)) -> ShellIO +changeArgMsg f (st,a) = do + let (b,msg) = f a + putStrLnFlush msg + return (st, b) + +returnArg :: CommandArg -> ShellIO +returnArg = changeArg . const + +returnArgIO :: IO CommandArg -> ShellIO +returnArgIO io (st,_) = io >>= (\a -> return (st,a)) + +justOutputArg :: (String -> IO ()) -> ShellIO +justOutputArg f sa@(st,a) = f (prCommandArg a) >> return (st, AUnit) + +justOutput :: IO () -> ShellIO +justOutput = justOutputArg . const + +-- type system for command arguments; instead of plain strings... + +data CommandArg = + AError String + | ATrms [Tree] + | ASTrm String -- to receive from parser + | AStrs [Str] + | AString String + | AUnit + deriving (Eq, Show) + +prCommandArg :: CommandArg -> String +prCommandArg arg = case arg of + AError s -> s + AStrs ss -> sstrV ss + AString s -> s + ATrms [] -> "no tree found" + ATrms tt -> unlines $ map prt_Tree tt + ASTrm s -> s + AUnit -> "" + +opSS2CommandArg :: (String -> String) -> CommandArg -> CommandArg +opSS2CommandArg f = AString . f . prCommandArg + +opST2CommandArg :: (String -> Err [Tree]) -> CommandArg -> CommandArg +opST2CommandArg f = err AError ATrms . f . prCommandArg + +opTS2CommandArg :: (Tree -> String) -> CommandArg -> CommandArg +opTS2CommandArg f (ATrms ts) = AString $ unlines $ map f ts +opTS2CommandArg _ _ = AError ("expected term") + +opTT2CommandArg :: (Tree -> [Tree]) -> CommandArg -> CommandArg +opTT2CommandArg f (ATrms ts) = ATrms $ concat $ map f ts +opTT2CommandArg _ _ = AError ("expected term") diff --git a/src/GF/Shell/CommandL.hs b/src/GF/Shell/CommandL.hs new file mode 100644 index 000000000..463b3d4e4 --- /dev/null +++ b/src/GF/Shell/CommandL.hs @@ -0,0 +1,135 @@ +module CommandL where + +import Operations +import UseIO + +import CMacros + +import GetTree +import ShellState +import Option +import Session +import Commands + +import Char +import List (intersperse) + +import UTF8 + +-- a line-based shell + +initEditLoop :: CEnv -> IO () -> IO () +initEditLoop env resume = do + let env' = addGlobalOptions (options [sizeDisplay "short"]) env + putStrLnFlush $ initEditMsg env' + let state = initSStateEnv env' + putStrLnFlush $ showCurrentState env' state + editLoop env' state resume + +editLoop :: CEnv -> SState -> IO () -> IO () +editLoop env state resume = do + putStrFlush "edit> " + c <- getCommand + if (isQuit c) then resume else do + (env',state') <- execCommand env c state + let package = case c of + CCEnvEmptyAndImport _ -> initEditMsgEmpty env' + _ -> showCurrentState env' state' + putStrLnFlush package + + editLoop env' state' resume + +getCommand :: IO Command +getCommand = do + s <- getLine + return $ pCommand s + +getCommandUTF :: IO Command +getCommandUTF = do + s <- getLine + return $ pCommand s -- the GUI is doing this: $ decodeUTF8 s + +pCommand = pCommandWords . words where + pCommandWords s = case s of + "n" : cat : _ -> CNewCat (strings2Cat cat) + "t" : ws -> CNewTree $ unwords ws + "g" : ws -> CRefineWithTree $ unwords ws -- *g*ive + "p" : ws -> CRefineParse $ unwords ws + ">" : i : _ -> CAhead $ readIntArg i + ">" : [] -> CAhead 1 + "<" : i : _ -> CBack $ readIntArg i + "<" : [] -> CBack 1 + ">>" : _ -> CNextMeta + "<<" : _ -> CPrevMeta + "'" : _ -> CTop + "+" : _ -> CLast + "r" : f : _ -> CRefineWithAtom f + "w" : f:i : _ -> CWrapWithFun (strings2Fun f, readIntArg i) + "ch": f : _ -> CChangeHead (strings2Fun f) + "ph": _ -> CPeelHead + "x" : ws -> CAlphaConvert $ unwords ws + "s" : i : _ -> CSelectCand (readIntArg i) + "f" : "unstructured" : _ -> CRemoveOption showStruct --- hmmm + "f" : "structured" : _ -> CAddOption showStruct --- hmmm + "f" : s : _ -> CAddOption (filterString s) + "u" : _ -> CUndo + "d" : _ -> CDelete + "c" : s : _ -> CTermCommand s + "a" : _ -> CRefineRandom --- *a*leatoire + "m" : _ -> CMenu +---- "ml" : s : _ -> changeMenuLanguage s +---- "ms" : s : _ -> changeMenuSize s +---- "mt" : s : _ -> changeMenuTyped s + "v" : _ -> CView + "q" : _ -> CQuit + "h" : _ -> CHelp initEditMsg + + "i" : file: _ -> CCEnvImport file + "e" : [] -> CCEnvEmpty + "e" : file: _ -> CCEnvEmptyAndImport file + + "open" : f: _ -> CCEnvOpenTerm f + "openstring": f: _ -> CCEnvOpenString f + + "on" :lang: _ -> CCEnvOn lang + "off":lang: _ -> CCEnvOff lang + "pfile" :f:_ -> CCEnvRefineParse f + "tfile" :f:_ -> CCEnvRefineWithTree f + +-- openstring file +-- pfile file +-- tfile file +-- on lang +-- off lang + + "gf": comm -> CCEnvGFShell (unwords comm) + + [] -> CVoid + _ -> CError + +-- well, this lists the commands of the line-based editor +initEditMsg env = unlines $ + "State-dependent editing commands are given in the menu:" : + " n = new, r = refine, w = wrap, d = delete, s = select." : + "Commands changing the environment:" : + " i [file] = import, e = empty." : + "Other commands:" : + " a = random, v = change view, u = undo, h = help, q = quit," : + " ml [Lang] = change menu language," : + " ms (short | long) = change menu command size," : + " mt (typed | untyped) = change menu item typing," : + " p [string] = refine by parsing, g [term] = refine by term," : + " > = down, < = up, ' = top, >> = next meta, << = previous meta." : +---- (" c [" ++ unwords (intersperse "|" allTermCommands) ++ "] = modify term") : +---- (" f [" ++ unwords (intersperse "|" allStringCommands) ++ "] = modify output") : + [] + +initEditMsgEmpty env = initEditMsg env +++++ unlines ( + "Start editing by n Cat selecting category\n\n" : + "-------------\n" : + ["n" +++ cat | (_,cat) <- newCatMenu env] + ) + +showCurrentState env' state' = + unlines (tr ++ ["",""] ++ msg ++ ["",""] ++ map fst menu) + where (tr,msg,menu) = displaySStateIn env' state' diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs new file mode 100644 index 000000000..5c92c7bd6 --- /dev/null +++ b/src/GF/Shell/Commands.hs @@ -0,0 +1,443 @@ +module Commands where + +import Operations +import Zipper + +----import AccessGrammar (Term (Vr)) ---- +import qualified Grammar as G ---- Cat +import GFC +import qualified AbsGFC ---- Atom +import CMacros +import LookAbs + +import GetTree +import API +import ShellState + +import qualified Shell +import qualified Ident as I +import qualified PShell +import qualified Macros as M +import PrGrammar +import TypeCheck ---- tree2exp +import PGrammar +import IOGrammar +import UseIO +import Unicode + +import Option +import CF +----- import CFIdent (cat2CFCat, cfCat2Cat) +import Linear +import Randomized +import Editing +import Session +import Custom + +import Random (mkStdGen) +import Monad (liftM2) +import List (intersperse) +import Random (newStdGen) + +--- temporary hacks for GF 2.0 + +-- abstract command language for syntax editing. AR 22/8/2001 + +data Command = + CNewCat G.Cat + | CNewTree String + | CAhead Int + | CBack Int + | CNextMeta + | CPrevMeta + | CTop + | CLast + | CRefineWithTree String + | CRefineWithAtom String + | CRefineParse String + | CWrapWithFun (G.Fun,Int) + | CChangeHead G.Fun + | CPeelHead + | CAlphaConvert String + | CRefineRandom + | CSelectCand Int + | CTermCommand String + | CAddOption Option + | CRemoveOption Option + | CDelete + | CUndo + | CView + | CMenu + | CQuit + | CHelp (CEnv -> String) -- help message depends on grammar and interface + | CError -- syntax error in command + | CVoid -- empty command, e.g. just + +-- commands affecting CEnv + | CCEnvImport String + | CCEnvEmptyAndImport String + | CCEnvOpenTerm String + | CCEnvOpenString String + | CCEnvEmpty + + | CCEnvOn String + | CCEnvOff String + + | CCEnvGFShell String + +-- other commands using IO + | CCEnvRefineWithTree String + | CCEnvRefineParse String + +isQuit CQuit = True +isQuit _ = False + +-- an abstract environment type + +type CEnv = ShellState + +grammarCEnv = firstStateGrammar +canCEnv = canModules +concreteCEnv = cncId +abstractCEnv = absId + +stdGenCEnv env s = mkStdGen (length (displayJustStateIn env s) * 31 +11) --- + +initSStateEnv env = case getOptVal (stateOptions sgr) gStartCat of +---- Just cat -> action2commandNext (newCat gr (identC cat)) initSState + _ -> initSState + where + sgr = firstStateGrammar env + gr = stateGrammarST sgr + +-- the main function + +execCommand :: CEnv -> Command -> SState -> IO (CEnv,SState) +execCommand env c s = case c of +{- ---- +-- these commands do need IO + CCEnvImport file -> do + + gr <- optFile2grammar noOptions (maybeStateAbstract env) file + let lan = getLangNameOpt noOptions file + return (updateLanguage file (lan, getStateConcrete gr) + (initWithAbstract (stateAbstract gr) env), s) + + CCEnvEmptyAndImport file -> do + gr <- optFile2grammar noOptions Nothing file + let lan = getLangNameOpt noOptions file + return (updateLanguage file (lan, getStateConcrete gr) + (initWithAbstract (stateAbstract gr) emptyShellState), initSState) + + CCEnvEmpty -> do + return (emptyShellState, initSState) + + CCEnvGFShell command -> do + let cs = PShell.pCommandLines command + (msg,(env',_)) <- Shell.execLines False cs (Shell.initHState env) + return (env', changeMsg msg s) ---- + + CCEnvOpenTerm file -> do + c <- readFileIf file + let (fs,t) = envAndTerm file c + + env' <- shellStateFromFiles noOptions fs + return (env', (action2commandNext $ \x -> + (string2treeErr (grammarCEnv env') t x >>= + \t -> newTree t x)) s) + + CCEnvOpenString file -> do + c <- readFileIf file + let (fs,t) = envAndTerm file c + env' <- shellStateFromFiles noOptions fs + let gr = grammarCEnv env' + sgr = firstStateGrammar env' + agrs = allActiveGrammars env' + cat = firstCatOpts (stateOptions sgr) sgr + state0 <- err (const $ return (stateSState s)) return $ + newCat gr (cfCat2Cat cat) $ stateSState s + state1 <- return $ + refineByExps True gr (parseAny agrs cat t) $ changeState state0 s + return (env', state1) + + CCEnvOn name -> return (languageOn (language name) env,s) + CCEnvOff name -> return (languageOff (language name) env,s) +-} +-- this command is improved by the use of IO + CRefineRandom -> do + g <- newStdGen + return (env, action2commandNext (refineRandom g 41 cgr) s) + +-- these commands use IO + CCEnvRefineWithTree file -> do + str <- readFileIf file + execCommand env (CRefineWithTree str) s + CCEnvRefineParse file -> do + str <- readFileIf file + execCommand env (CRefineParse str) s + +-- other commands don't need IO; they are available in the fudget + c -> return (env, execECommand env c s) + + where + gr = grammarCEnv env + cgr = canCEnv env + opts = globalOptions env + + -- format for documents: import lines of form "-- file", then term + envAndTerm f s = + (map ((initFilePath f ++) . filter (/=' ') . drop 2) fs, unlines ss) where + (fs,ss) = span isImport (lines s) + isImport l = take 2 l == "--" + + +execECommand :: CEnv -> Command -> ECommand +execECommand env c = case c of + CNewCat cat -> action2commandNext $ \x -> do + s' <- newCat cgr cat x + uniqueRefinements cgr s' +{- ---- + CNewTree s -> action2commandNext $ \x -> do + t <- string2treeErr gr s + s' <- newTree t x + uniqueRefinements cgr s' +-} + CAhead n -> action2command (goAheadN n) + CBack n -> action2command (goBackN n) + CTop -> action2command $ return . goRoot + CLast -> action2command $ goLast + CNextMeta -> action2command goNextNewMeta + CPrevMeta -> action2command goPrevNewMeta + CRefineWithAtom s -> action2commandNext $ \x -> do + t <- string2ref gr s + s' <- refineWithAtom der cgr t x + uniqueRefinements cgr s' + CWrapWithFun fi -> action2commandNext $ wrapWithFun cgr fi + CChangeHead f -> action2commandNext $ changeFunHead cgr f + CPeelHead -> action2commandNext $ peelFunHead cgr +{- ---- + CAlphaConvert s -> action2commandNext $ \x -> + string2varPair s >>= \xy -> alphaConvert gr xy x + + CRefineWithTree s -> action2commandNext $ \x -> + (string2treeErr gr s x >>= \t -> refineWithTree der gr t x) + + CRefineParse str -> \s -> refineByExps der gr + (parseAny agrs (cat2CFCat (actCat (stateSState s))) str) s +-} + + CRefineRandom -> \s -> action2commandNext + (refineRandom (stdGenCEnv env s) 41 cgr) s + + CSelectCand i -> selectCand cgr i +{- ---- + CTermCommand c -> case c of + "paraphrase" -> \s -> + replaceByTermCommand gr c (actExp (stateSState s)) s + "transfer" -> action2commandNext $ + transferSubTree (stateTransferFun sgr) gr + _ -> replaceByEditCommand gr c +-} +---- CAddOption o -> changeStOptions (addOption o) +---- CRemoveOption o -> changeStOptions (removeOption o) + CDelete -> action2commandNext $ deleteSubTree cgr + CUndo -> undoCommand +---- CMenu -> \s -> changeMsg (menuState env s) s + CView -> changeView + CHelp h -> changeMsg [h env] + CVoid -> id + _ -> changeMsg ["command not yet implemented"] + where + sgr = firstStateGrammar env + agrs = [sgr] ---- allActiveGrammars env + cgr = canCEnv env + gr = grammarCEnv env + der = maybe True not $ caseYesNo (globalOptions env) noDepTypes + -- if there are dep types, then derived refs; deptypes is the default + +-- + + +{- ---- +string2varPair :: String -> Err (I.Ident,I.Ident) +string2varPair s = case words s of + x : y : [] -> liftM2 (,) (string2ident x) (string2ident y) + _ -> Bad "expected format 'x y'" + + +-- seen on display + +cMenuDisplay :: String -> Command +cMenuDisplay s = CAddOption (menuDisplay s) +-} +newCatMenu env = [(CNewCat c, prQIdent c) | ---- printname env initSState c) | + (c,[]) <- allCatsOf (canCEnv env)] + +mkRefineMenu :: CEnv -> SState -> [(Command,String)] +mkRefineMenu env sstate = [(c,s) | (c,(s,_)) <- mkRefineMenuAll env sstate] + +mkRefineMenuAll :: CEnv -> SState -> [(Command,(String,String))] +mkRefineMenuAll env sstate = + case (refinementsState cgr state, candsSState sstate, wrappingsState cgr state) of + ([],[],wraps) -> + [(CWrapWithFun fi, prWrap fit) | fit@(fi,_) <- wraps] ++ + [(CChangeHead f, prChangeHead f) | f <- headChangesState cgr state] ++ + [(CPeelHead, (ifShort "ph" "PeelHead", "ph")) | canPeelState cgr state] ++ + [(CDelete, (ifShort "d" "Delete", "d"))] + (refs,[],_) -> [(CRefineWithAtom (prRefinement f), prRef t) | t@(f,_) <- refs] + (_,cands,_) -> [(CSelectCand i, prCand (t,i)) | (t,i) <- zip cands [0..]] + + where + prRef (f,t) = + (ifShort "r" "Refine" +++ prOrLinExp f +++ ifTyped (":" +++ prt t), + "r" +++ prRefinement f) + prChangeHead f = + (ifShort "ch" "ChangeHead" +++ prOrLinFun f, + "ch" +++ prQIdent f) + prWrap ((f,i),t) = + (ifShort "w" "Wrap" +++ prOrLinFun f +++ ifTyped (":" +++ prt t) +++ + ifShort (show i) (prBracket (show i)), + "w" +++ prQIdent f +++ show i) + prCand (t,i) = + (ifShort ("s" +++ prOrLinExp t) ("Select" +++ prOrLinExp t),"s" +++ show i) + + gr = grammarCEnv env + cgr = canCEnv env + state = stateSState sstate + opts = addOptions (optsSState sstate) (globalOptions env) + ifOpt f v a b = case getOptVal opts f of + Just s | s == v -> a + _ -> b + ifShort = ifOpt sizeDisplay "short" + ifTyped t = ifOpt typeDisplay "typed" t "" + prOrLinExp t = prRefinement t --- maybe (prt t) prOrLinFun $ M.justIdentOf t + prOrLinTree t = case getOptVal opts menuDisplay of + Just "Abs" -> prt t + Just lang -> optLinearizeTreeVal (addOption firstLin opts) + (stateGrammarOfLang env (language lang)) t + _ -> prt t + prOrLinFun = printname env sstate + +-- there are three orthogonal parameters: Abs/[conc], short/long, typed/untyped +-- the default is Abs, long, untyped; the Menus menu changes the parameter + +emptyMenuItem = (CVoid,("","")) + + + +---- allStringCommands = snd $ customInfo customStringCommand +termCommandMenu, stringCommandMenu :: [(Command,String)] +termCommandMenu = [] +stringCommandMenu = [] + +displayCommandMenu :: CEnv -> [(Command,String)] +displayCommandMenu env = [] +{- ---- +---- allTermCommands = snd $ customInfo customEditCommand +termCommandMenu = [(CTermCommand s, s) | s <- allTermCommands] + +stringCommandMenu = + (CAddOption showStruct, "structured") : + (CRemoveOption showStruct, "unstructured") : + [(CAddOption (filterString s), s) | s <- allStringCommands] + +displayCommandMenu env = + [(CAddOption (menuDisplay s), s) | s <- "Abs" : langs] ++ + [(CAddOption (sizeDisplay s), s) | s <- ["short", "long"]] ++ + [(CAddOption (typeDisplay s), s) | s <- ["typed", "untyped"]] + where + langs = map prLanguage $ allLanguages env + +changeMenuLanguage, changeMenuSize, changeMenuTyped :: String -> Command +changeMenuLanguage s = CAddOption (menuDisplay s) +changeMenuSize s = CAddOption (sizeDisplay s) +changeMenuTyped s = CAddOption (typeDisplay s) +-} + +menuState env = map snd . mkRefineMenu env + +prState :: State -> [String] +prState s = prMarkedTree (loc2treeMarked s) + +displayJustStateIn env state = case displaySStateIn env state of + (t,msg,_) -> unlines (t ++ ["",""] ++ msg) --- ad hoc for CommandF + +displaySStateIn env state = (tree',msg,menu) where + (tree,msg,menu) = displaySState env state + grs = allStateGrammars env + lang = (viewSState state) `mod` (length grs + 3) + tree' = (tree : exp : linAll ++ separ (linAll ++ [tree])) !! lang + opts = addOptions (optsSState state) (globalOptions env) -- state opts override + lin g = linearizeState fudWrap opts g zipper + exp = return $ tree2string $ loc2tree zipper + zipper = stateSState state + linAll = map lin grs + separ = singleton . map unlines . intersperse [replicate 72 '*'] + +displaySStateJavaX env state = unlines $ tagXML "gfedit" $ concat [ + tagXML "linearizations" (concat + [tagAttrXML "lin" ("lang", prLanguage lang) ss | (lang,ss) <- lins]), + tagXML "tree" tree, + tagXML "message" msg, + tagXML "menu" (tagsXML "item" menu') + ] + where + (tree,msg,menu) = displaySState env state + menu' = [tagXML "show" [s] ++ tagXML "send" [c] | (s,c) <- menu] + (ls,grs) = unzip $ lgrs + lgrs = allStateGrammarsWithNames env --- allActiveStateGrammarsWithNames env + lins = (langAbstract, exp) : linAll + opts = addOptions (optsSState state) (globalOptions env) -- state opts override + lin (n,gr) = (n, map uni $ linearizeState noWrap opts gr zipper) where + uni = optEncodeUTF8 n gr . mkUnicode + exp = prprTree $ loc2tree zipper +--- xml = prExpXML gr $ tree2exp $ loc2tree zipper --- better: dir. from zipper + zipper = stateSState state + linAll = map lin lgrs + gr = firstStateGrammar env + +langAbstract = language "Abstract" +langXML = language "XML" + + +linearizeState :: (String -> [String]) -> Options -> GFGrammar -> State -> [String] +linearizeState wrap opts gr = + wrap . strop . unt . optLinearizeTreeVal opts gr . loc2tree + --- markedLinString br g + where + unt = id ---- customOrDefault (stateOptions g) useUntokenizer customUntokenizer g + strop = id ---- maybe id ($ g) $ customAsOptVal opts filterString customStringCommand + br = oElem showStruct opts + +noWrap, fudWrap :: String -> [String] +noWrap = lines +fudWrap = lines . wrapLines 0 --- + +displaySState :: CEnv -> SState -> ([String],[String],[(String,String)]) +displaySState env state = + (prState (stateSState state), msgSState state, menuSState env state) + +menuSState :: CEnv -> SState -> [(String,String)] +menuSState env state = [(s,c) | (_,(s,c)) <- mkRefineMenuAll env state] + +printname :: CEnv -> SState -> G.Fun -> String +printname env state f = case getOptVal opts menuDisplay of + Just "Abs" -> prQIdent f +---- Just lang -> printn lang f + _ -> prQIdent f + where + opts = addOptions (optsSState state) (globalOptions env) + printn lang = linearize gr ---- printOrLinearize (grammarOfLang env (language lang)) + gr = grammarCEnv env + + +--- XML printing; does not belong here! + +tagsXML t = concatMap (tagXML t) +tagAttrXML t av ss = mkTagAttrXML t av : map (indent 2) ss ++ [mkEndTagXML t] +tagXML t ss = mkTagXML t : map (indent 2) ss ++ [mkEndTagXML t] +mkTagXML t = '<':t ++ ">" +mkEndTagXML t = mkTagXML ('/':t) +mkTagAttrsXML t avs = '<':t +++ unwords [a++"="++v | (a,v) <- avs] ++">" +mkTagAttrXML t av = mkTagAttrsXML t [av] + diff --git a/src/GF/Shell/JGF.hs b/src/GF/Shell/JGF.hs new file mode 100644 index 000000000..215ad3e3e --- /dev/null +++ b/src/GF/Shell/JGF.hs @@ -0,0 +1,59 @@ +module JGF where + +import Operations +import UseIO + +import IOGrammar +import Option +import ShellState +import Session +import Commands +import CommandL + +import System +import UTF8 + + +-- GF editing session controlled by e.g. a Java program. AR 16/11/2001 + +sessionLineJ :: ShellState -> IO () +sessionLineJ env = do + putStrLnFlush $ initEditMsgJavaX env + let env' = addGlobalOptions (options [sizeDisplay "short"]) env + editLoopJ env' (initSState) + +editLoopJ :: CEnv -> SState -> IO () +editLoopJ = editLoopJnewX + +-- this is the real version, with XML + +editLoopJnewX :: CEnv -> SState -> IO () +editLoopJnewX env state = do + c <- getCommandUTF + case c of + CQuit -> return () + + c -> do + (env',state') <- execCommand env c state + let package = case c of + CCEnvImport _ -> initAndEditMsgJavaX env' state' + CCEnvEmptyAndImport _ -> initAndEditMsgJavaX env' state' + CCEnvOpenTerm _ -> initAndEditMsgJavaX env' state' + CCEnvOpenString _ -> initAndEditMsgJavaX env' state' + CCEnvEmpty -> initEditMsgJavaX env' + _ -> displaySStateJavaX env' state' + putStrLnFlush package + editLoopJnewX env' state' + +welcome = + "An experimental GF Editor for Java." ++ + "(c) Kristofer Johannisson, Janna Khegai, and Aarne Ranta 2002 under CNU GPL." + +initEditMsgJavaX env = encodeUTF8 $ unlines $ tagXML "gfinit" $ + tagsXML "newcat" [["n" +++ cat] | (_,cat) <- newCatMenu env] ++ + tagXML "language" [prLanguage langAbstract] ++ + concat [tagAttrXML "language" ("file",file) [prLanguage lang] | + (file,lang) <- zip (allGrammarFileNames env) (allLanguages env)] + +initAndEditMsgJavaX env state = + initEditMsgJavaX env ++++ displaySStateJavaX env state diff --git a/src/GF/Shell/PShell.hs b/src/GF/Shell/PShell.hs new file mode 100644 index 000000000..f28218f27 --- /dev/null +++ b/src/GF/Shell/PShell.hs @@ -0,0 +1,115 @@ +module PShell where + +import Operations +import UseIO +import ShellState +import Shell +import Option +import PGrammar (pzIdent, pTrm) --- (string2formsAndTerm) +import API +import Arch(fetchCommand) +import Char (isDigit) + +-- parsing GF shell commands. AR 11/11/2001 + +-- getting a sequence of command lines as input + +getCommandLines :: IO (String,[CommandLine]) +getCommandLines = do + s <- fetchCommand "> " + return (s,pCommandLines s) + +pCommandLines :: String -> [CommandLine] +pCommandLines = map pCommandLine . concatMap (chunks ";;" . words) . lines + +pCommandLine :: [String] -> CommandLine +pCommandLine s = pFirst (chks s) where + pFirst cos = case cos of + (c,os,[a]) : cs -> ((c,os), a, pCont cs) + _ -> ((CVoid,noOptions), AError "no parse", []) + pCont cos = case cos of + (c,os,_) : cs -> (c,os) : pCont cs + _ -> [] + chks = map pCommandOpt . chunks "|" + +pCommandOpt :: [String] -> (Command, Options, [CommandArg]) +pCommandOpt (w:ws) = let + (os, co) = getOptions "-" ws + (comm, args) = pCommand (w:co) + in + (comm, os, args) +pCommandOpt s = (CVoid, noOptions, [AError "no parse"]) + +pInputString :: String -> [CommandArg] +pInputString s = case s of + ('"':_:_) -> [AString (init (tail s))] + _ -> [AError "illegal string"] + +pCommand :: [String] -> (Command, [CommandArg]) +pCommand ws = case ws of + + "i" : f : [] -> aUnit (CImport f) + "rl" : l : [] -> aUnit (CRemoveLanguage (language l)) + "e" : [] -> aUnit CEmptyState + "tg" : f : [] -> aUnit (CTransformGrammar f) + "cl" : f : [] -> aUnit (CConvertLatex f) + + "ph" : [] -> aUnit CPrintHistory + + "l" : s -> aTermLi CLinearize s + + "p" : s -> aString CParse s + "t" : i:o: s -> aString (CTranslate (language i) (language o)) s + "gr" : [] -> aUnit (CGenerateRandom 1) + "gr" : n : [] -> aUnit (CGenerateRandom (readIntArg n)) -- deprecated 12/5/2001 + "pt" : s -> aTerm CPutTerm s +----- "wt" : f : s -> aTerm (CWrapTerm (string2id f)) s + "ma" : s -> aString CMorphoAnalyse s + "tt" : s -> aString CTestTokenizer s + "cc" : m : s -> aUnit $ CComputeConcrete (pzIdent m) $ unwords s + + "tq" : i:o:[] -> aUnit (CTranslationQuiz (language i) (language o)) + "tl":i:o:n:[] -> aUnit (CTranslationList (language i) (language o) (readIntArg n)) + "mq" : [] -> aUnit CMorphoQuiz + "ml" : n : [] -> aUnit (CMorphoList (readIntArg n)) + + "wf" : f : s -> aString (CWriteFile f) s + "af" : f : s -> aString (CAppendFile f) s + "rf" : f : [] -> aUnit (CReadFile f) + "sa" : s -> aString CSpeakAloud s + "ps" : s -> aString CPutString s + "st" : s -> aTerm CShowTerm s + "!" : s -> aUnit (CSystemCommand (unwords s)) + + "sf" : l : [] -> aUnit (CSetLocalFlag (language l)) + "sf" : [] -> aUnit CSetFlag + + "pg" : [] -> aUnit CPrintGrammar + "pi" : c : [] -> aUnit $ CPrintInformation (pzIdent c) + + "pj" : [] -> aUnit CPrintGramlet + "pxs" : [] -> aUnit CPrintCanonXMLStruct + "px" : [] -> aUnit CPrintCanonXML + "pm" : [] -> aUnit CPrintMultiGrammar + "po" : [] -> aUnit CPrintGlobalOptions + "pl" : [] -> aUnit CPrintLanguages + "h" : [] -> aUnit CHelp + + "q" : [] -> aImpure ICQuit + "eh" : f : [] -> aImpure (ICExecuteHistory f) + n : [] | all isDigit n -> aImpure (ICEarlierCommand (readIntArg n)) + + "es" : [] -> aImpure ICEditSession + "ts" : [] -> aImpure ICTranslateSession + + _ -> (CVoid, []) + + where + aString c ss = (c, pInputString (unwords ss)) + aTerm c ss = (c, [ASTrm $ unwords ss]) ---- [ASTrms [s2t (unwords ss)]]) + aUnit c = (c, [AUnit]) + aImpure = aUnit . CImpure + + aTermLi c ss = (c [], [ASTrm $ unwords ss]) + ---- (c forms, [ASTrms [term]]) where + ---- (forms,term) = ([], s2t (unwords ss)) ---- string2formsAndTerm (unwords ss) diff --git a/src/GF/Shell/SubShell.hs b/src/GF/Shell/SubShell.hs new file mode 100644 index 000000000..c910d3dd0 --- /dev/null +++ b/src/GF/Shell/SubShell.hs @@ -0,0 +1,43 @@ +module SubShell where + +import Operations +import UseIO +import ShellState +import Option +import API + +import CommandL +import ArchEdit + +-- AR 20/4/2000 -- 12/11/2001 + +editSession :: Options -> ShellState -> IO () +editSession opts st + | oElem makeFudget opts = fudlogueEdit font st' + | otherwise = initEditLoop st' (return ()) + where + st' = addGlobalOptions opts st + font = maybe myUniFont mkOptFont $ getOptVal opts useFont + +myUniFont = "-mutt-clearlyu-medium-r-normal--0-0-100-100-p-0-iso10646-1" +mkOptFont = id +{- ---- +translateSession :: Options -> ShellState -> IO () +translateSession opts st = do + let grs = allStateGrammars st + cat = firstCatOpts opts (firstStateGrammar st) + trans = unlines . translateBetweenAll grs cat + translateLoop opts trans + +translateLoop opts trans = do + let fud = oElem makeFudget opts + font = maybe myUniFont mkOptFont $ getOptVal opts useFont + if fud then fudlogueWrite font trans else loopLine + where + loopLine = do + putStrFlush "trans> " + s <- getLine + if s == "." then return () else do + putStrLnFlush $ trans s + loopLine +-} diff --git a/src/GF/Source/AbsGF.hs b/src/GF/Source/AbsGF.hs new file mode 100644 index 000000000..16d342dd8 --- /dev/null +++ b/src/GF/Source/AbsGF.hs @@ -0,0 +1,242 @@ +module AbsGF where + +import Ident --H + +-- Haskell module generated by the BNF converter, except for --H + +-- newtype Ident = Ident String deriving (Eq,Ord,Show) --H + +newtype LString = LString String deriving (Eq,Ord,Show) + +data Grammar = + Gr [ModDef] + deriving (Eq,Ord,Show) + +data ModDef = + MMain Ident Ident [ConcSpec] + | MAbstract Ident Extend Opens [TopDef] + | MResource Ident Extend Opens [TopDef] + | MResourceInt Ident Extend Opens [TopDef] + | MResourceImp Ident Ident Opens [TopDef] + | MConcrete Ident Ident Extend Opens [TopDef] + | MConcreteInt Ident Ident Extend Opens [TopDef] + | MConcreteImp Open Ident Ident + | MTransfer Ident Open Open Extend Opens [TopDef] + | MReuseAbs Ident Ident + | MReuseCnc Ident Ident + | MReuseAll Ident Extend Ident + deriving (Eq,Ord,Show) + +data ConcSpec = + ConcSpec Ident ConcExp + deriving (Eq,Ord,Show) + +data ConcExp = + ConcExp Ident [Transfer] + deriving (Eq,Ord,Show) + +data Transfer = + TransferIn Open + | TransferOut Open + deriving (Eq,Ord,Show) + +data Extend = + Ext Ident + | NoExt + deriving (Eq,Ord,Show) + +data Opens = + NoOpens + | Opens [Open] + deriving (Eq,Ord,Show) + +data Open = + OName Ident + | OQual Ident Ident + deriving (Eq,Ord,Show) + +data Def = + DDecl [Ident] Exp + | DDef [Ident] Exp + | DPatt Ident [Patt] Exp + | DFull [Ident] Exp Exp + deriving (Eq,Ord,Show) + +data TopDef = + DefCat [CatDef] + | DefFun [FunDef] + | DefDef [Def] + | DefData [ParDef] + | DefTrans [FlagDef] + | DefPar [ParDef] + | DefOper [Def] + | DefLincat [PrintDef] + | DefLindef [Def] + | DefLin [Def] + | DefPrintCat [PrintDef] + | DefPrintFun [PrintDef] + | DefFlag [FlagDef] + | DefPrintOld [PrintDef] + | DefLintype [Def] + | DefPattern [Def] + deriving (Eq,Ord,Show) + +data CatDef = + CatDef Ident [DDecl] + deriving (Eq,Ord,Show) + +data FunDef = + FunDef [Ident] Exp + deriving (Eq,Ord,Show) + +data ParDef = + ParDef Ident [ParConstr] + | ParDefIndir Ident Ident + | ParDefAbs Ident + deriving (Eq,Ord,Show) + +data ParConstr = + ParConstr Ident [DDecl] + deriving (Eq,Ord,Show) + +data PrintDef = + PrintDef [Ident] Exp + deriving (Eq,Ord,Show) + +data FlagDef = + FlagDef Ident Ident + deriving (Eq,Ord,Show) + +data LocDef = + LDDecl [Ident] Exp + | LDDef [Ident] Exp + | LDFull [Ident] Exp Exp + deriving (Eq,Ord,Show) + +data Exp = + EIdent Ident + | EConstr Ident + | ECons Ident + | ESort Sort + | EString String + | EInt Integer + | EMeta + | EEmpty + | EStrings String + | ERecord [LocDef] + | ETuple [TupleComp] + | EIndir Ident + | ETyped Exp Exp + | EProj Exp Label + | EQConstr Ident Ident + | EQCons Ident Ident + | EApp Exp Exp + | ETable [Case] + | ETTable Exp [Case] + | ECase Exp [Case] + | EVariants [Exp] + | EPre Exp [Altern] + | EStrs [Exp] + | EConAt Ident Exp + | ESelect Exp Exp + | ETupTyp Exp Exp + | EExtend Exp Exp + | EAbstr [Bind] Exp + | ECTable [Bind] Exp + | EProd Decl Exp + | ETType Exp Exp + | EConcat Exp Exp + | EGlue Exp Exp + | ELet [LocDef] Exp + | EEqs [Equation] + | ELString LString + | ELin Ident + deriving (Eq,Ord,Show) + +data Patt = + PW + | PV Ident + | PCon Ident + | PQ Ident Ident + | PInt Integer + | PStr String + | PR [PattAss] + | PTup [PattTupleComp] + | PC Ident [Patt] + | PQC Ident Ident [Patt] + deriving (Eq,Ord,Show) + +data PattAss = + PA [Ident] Patt + deriving (Eq,Ord,Show) + +data Label = + LIdent Ident + | LVar Integer + deriving (Eq,Ord,Show) + +data Sort = + Sort_Type + | Sort_PType + | Sort_Tok + | Sort_Str + | Sort_Strs + deriving (Eq,Ord,Show) + +data PattAlt = + AltP Patt + deriving (Eq,Ord,Show) + +data Bind = + BIdent Ident + | BWild + deriving (Eq,Ord,Show) + +data Decl = + DDec [Bind] Exp + | DExp Exp + deriving (Eq,Ord,Show) + +data TupleComp = + TComp Exp + deriving (Eq,Ord,Show) + +data PattTupleComp = + PTComp Patt + deriving (Eq,Ord,Show) + +data Case = + Case [PattAlt] Exp + deriving (Eq,Ord,Show) + +data Equation = + Equ [Patt] Exp + deriving (Eq,Ord,Show) + +data Altern = + Alt Exp Exp + deriving (Eq,Ord,Show) + +data DDecl = + DDDec [Bind] Exp + | DDExp Exp + deriving (Eq,Ord,Show) + +data OldGrammar = + OldGr Include [TopDef] + deriving (Eq,Ord,Show) + +data Include = + NoIncl + | Incl [FileName] + deriving (Eq,Ord,Show) + +data FileName = + FString String + | FIdent Ident + | FSlash FileName + | FDot FileName + | FMinus FileName + | FAddId Ident FileName + deriving (Eq,Ord,Show) + diff --git a/src/GF/Source/CompileM.hs b/src/GF/Source/CompileM.hs new file mode 100644 index 000000000..3d97a029e --- /dev/null +++ b/src/GF/Source/CompileM.hs @@ -0,0 +1,141 @@ +module CompileM where + +import Grammar +import Ident +import Option +import PrGrammar +import Update +import Lookup +import Modules +---import Rename + +import Operations +import UseIO + +import Monad + +compileMGrammar :: Options -> SourceGrammar -> IOE SourceGrammar +compileMGrammar opts sgr = do + + ioeErr $ checkUniqueModuleNames sgr + + deps <- ioeErr $ moduleDeps sgr + + deplist <- either return + (\ms -> ioeBad $ "circular modules" +++ unwords (map show ms)) $ + topoTest deps + + let deps' = closureDeps deps + + foldM (compileModule opts deps' sgr) emptyMGrammar deplist + +checkUniqueModuleNames :: MGrammar i f a r c -> Err () +checkUniqueModuleNames gr = do + let ms = map fst $ tree2list $ modules gr + msg = checkUnique ms + if null msg then return () else Bad $ unlines msg + +-- to decide what modules immediately depend on what, and check if the +-- dependencies are appropriate + +moduleDeps :: MGrammar i f a c r -> Err Dependencies +moduleDeps gr = mapM deps $ tree2list $ modules gr where + deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of + ModAbs m -> chDep (IdentM c MTAbstract) + (extends m) MTAbstract (opens m) MTAbstract + ModRes m -> chDep (IdentM c MTResource) + (extends m) MTResource (opens m) MTResource + ModCnc m -> do + a:ops <- case opens m of + os@(_:_) -> return os + _ -> Bad "no abstract indicated for concrete module" + aty <- lookupModuleType gr a + testErr (aty == MTAbstract) "the for-module is not an abstract syntax" + chDep (IdentM c (MTConcrete a)) (extends m) MTResource ops MTResource + + chDep it es ety os oty = do + ests <- mapM (lookupModuleType gr) es + testErr (all (==ety) ests) "inappropriate extension module type" + osts <- mapM (lookupModuleType gr) os + testErr (all (==oty) osts) "inappropriate open module type" + return (it, [IdentM e ety | e <- es] ++ [IdentM o oty | o <- os]) + +type Dependencies = [(IdentM Ident,[IdentM Ident])] + +---compileModule :: Options -> Dependencies -> SourceGrammar -> +--- CanonGrammar -> IdentM -> IOE CanonGrammar +compileModule opts deps sgr cgr i = do + + let name = identM i + + testIfCompiled deps name + + mi <- ioeErr $ lookupModule sgr name + + mi' <- case typeM i of + -- previously compiled cgr used as symbol table + MTAbstract -> compileAbstract cgr mi + MTResource -> compileResource cgr mi + MTConcrete a -> compileConcrete a cgr mi + + ifIsOpt doOutput $ writeCanonFile name mi' + + return $ addModule cgr name mi' + + where + + ifIsOpt o f = if (oElem o opts) then f else return () + doOutput = iOpt "o" + + +testIfCompiled :: Dependencies -> Ident -> IOE Bool +testIfCompiled _ _ = return False ---- + +---writeCanonFile :: Ident -> CanonModInfo -> IOE () +writeCanonFile name mi' = ioeIO $ writeFile (canonFileName name) [] ---- + +canonFileName n = n ++ ".gfc" ---- elsewhere! + +---compileAbstract :: CanonGrammar -> SourceModInfo -> IOE CanonModInfo +compileAbstract can (ModAbs m0) = do + let m1 = renameMAbstract m0 +{- + checkUnique + typeCheck + generateCode + addToCanon +-} + ioeBad "compile abs not yet" + +---compileResource :: CanonGrammar -> SourceModInfo -> IOE CanonModInfo +compileResource can md = do +{- + checkUnique + typeCheck + topoSort + compileOpers -- conservative, since more powerful than lin + generateCode + addToCanon +-} + ioeBad "compile res not yet" + +---compileConcrete :: Ident -> CanonGrammar -> SourceModInfo -> IOE CanonModInfo +compileConcrete ab can md = do +{- + checkUnique + checkComplete ab + typeCheck + topoSort + compileOpers + optimize + createPreservedOpers + generateCode + addToCanon +-} + ioeBad "compile cnc not yet" + + +-- to be imported + +closureDeps :: [(a,[a])] -> [(a,[a])] +closureDeps ds = ds ---- fix-point iteration diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs new file mode 100644 index 000000000..6303bcd99 --- /dev/null +++ b/src/GF/Source/GrammarToSource.hs @@ -0,0 +1,181 @@ +module GrammarToSource where + +import Operations +import Grammar +import Modules +import Option +import qualified AbsGF as P +import Ident + +-- AR 13/5/2003 +-- translate internal to parsable and printable source + +trGrammar :: SourceGrammar -> P.Grammar +trGrammar (MGrammar ms) = P.Gr (map trModule ms) -- no includes + +trModule :: (Ident,SourceModInfo) -> P.ModDef +trModule (i,mo) = case mo of + ModMod m -> mkModule i' (trExtend (extends m)) (mkOpens (map trOpen (opens m))) + (mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++ + (map trFlag (flags m)))) + where + i' = tri i + mkModule = case typeOfModule mo of + MTResource -> P.MResource + MTAbstract -> P.MAbstract + MTConcrete a -> P.MConcrete (tri a) + +trExtend :: Maybe Ident -> P.Extend +trExtend i = maybe P.NoExt (P.Ext . tri) i + +---- this has to be completed with other mtys +forName (MTConcrete a) = tri a + +trOpen :: OpenSpec Ident -> P.Open +trOpen o = case o of + OSimple i -> P.OName (tri i) + OQualif i j -> P.OQual (tri i) (tri j) + +mkOpens ds = if null ds then P.NoOpens else P.Opens ds +mkTopDefs ds = ds + +trAnyDef :: (Ident,Info) -> [P.TopDef] +trAnyDef (i,info) = let i' = tri i in case info of + AbsCat (Yes co) _ -> [P.DefCat [P.CatDef i' (map trDecl co)]] + AbsFun (Yes ty) _ -> [P.DefFun [P.FunDef [i'] (trt ty)]] + AbsFun (May b) _ -> [P.DefFun [P.FunDef [i'] (P.EIndir (tri b))]] + ---- don't destroy definitions! + + ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]] + ResParam pp -> [P.DefPar [case pp of + Yes ps -> P.ParDef i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps] + May b -> P.ParDefIndir i' $ tri b + _ -> P.ParDefAbs i']] + + CncCat (Yes ty) Nope _ -> + [P.DefLincat [P.PrintDef [i'] (trt ty)]] + CncCat pty ptr ppr -> + [P.DefLindef [trDef i' pty ptr]] + ---- P.DefPrintCat [P.PrintDef i' (trt pr)]] + CncFun _ ptr ppr -> + [P.DefLin [trDef i' nope ptr]] + ---- P.DefPrintFun [P.PrintDef i' (trt pr)]] + _ -> [] + +trDef :: Ident -> Perh Type -> Perh Term -> P.Def +trDef i pty ptr = case (pty,ptr) of + (Nope, Nope) -> P.DDef [i] (P.EMeta) --- + (_, Nope) -> P.DDecl [i] (trPerh pty) + (Nope, _ ) -> P.DDef [i] (trPerh ptr) + (_, _ ) -> P.DFull [i] (trPerh pty) (trPerh ptr) + +trPerh p = case p of + Yes t -> trt t + May b -> P.EIndir $ tri b + _ -> P.EMeta --- + + +trFlag :: Option -> P.TopDef +trFlag o = case o of + Opt (f,[x]) -> P.DefFlag [P.FlagDef (identC f) (identC x)] + _ -> P.DefFlag [] --- warning? + +trt :: Term -> P.Exp +trt trm = case trm of + Vr s -> P.EIdent $ tri s + Cn s -> P.ECons $ tri s + Con s -> P.EConstr $ tri s +---- ConAt id typ -> P.EConAt (tri id) (trt typ) + + Sort s -> P.ESort $ case s of + "Type" -> P.Sort_Type + "PType" -> P.Sort_PType + "Tok" -> P.Sort_Tok + "Str" -> P.Sort_Str + "Strs" -> P.Sort_Strs + _ -> error $ "not yet sort " +++ show trm ---- + + + App c a -> P.EApp (trt c) (trt a) + Abs x b -> P.EAbstr [trb x] (trt b) + +---- Eqs pts -> "fn" +++ prCurlyList [prtBranchOld pst | pst <- pts] --- +---- ECase e bs -> "case" +++ prt e +++ "of" +++ prCurlyList (map prtBranch bs) + + Meta m -> P.EMeta + Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b) + Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b) + + R r -> P.ERecord $ map trAssign r + RecType r -> P.ERecord $ map trLabelling r + ExtR x y -> P.EExtend (trt x) (trt y) + P t l -> P.EProj (trt t) (trLabel l) + Q t l -> P.EQCons (tri t) (tri l) + QC t l -> P.EQConstr (tri t) (tri l) + T (TTyped ty) cc -> P.ETTable (trt ty) (map trCase cc) + T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc) + T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc) + T _ cc -> P.ETable (map trCase cc) + + Table x v -> P.ETType (trt x) (trt v) + S f x -> P.ESelect (trt f) (trt x) +---- Alias c a t -> "{-" +++ prt c +++ "=" +++ "-}" +++ prt t +-- Alias c a t -> prt (Let (c,(Just a,t)) (Vr c)) -- thus Alias is only internal + + Let (x,(ma,b)) t -> + P.ELet [maybe (P.LDDef x' b') (\ty -> P.LDFull x' (trt ty) b') ma] (trt t) + where + b' = trt b + x' = [tri x] + + Empty -> P.EEmpty + K [] -> P.EEmpty + K a -> P.EString a + C a b -> P.EConcat (trt a) (trt b) + + EInt i -> P.EInt $ toInteger i + + Glue a b -> P.EGlue (trt a) (trt b) + Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt] + FV ts -> P.EVariants $ map trt ts + Strs tt -> P.EStrs $ map trt tt + _ -> error $ "not yet" +++ show trm ---- + +trp :: Patt -> P.Patt +trp p = case p of + PV s | isWildIdent s -> P.PW + PV s -> P.PV $ tri s + PC c [] -> P.PCon $ tri c + PC c a -> P.PC (tri c) (map trp a) + PP p c [] -> P.PQ (tri p) (tri c) + PP p c a -> P.PQC (tri p) (tri c) (map trp a) + PR r -> P.PR [P.PA [trLabelIdent l] (trp p) | (l,p) <- r] +---- PT t p -> prt p ---- prParenth (prt p +++ ":" +++ prt t) + + +trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty + where + t' = trt t + x = [trLabelIdent lab] + +trLabelling (lab,ty) = P.LDDecl [trLabelIdent lab] (trt ty) + +trCase (patt,trm) = P.Case [P.AltP (trp patt)] (trt trm) + +trDecl (x,ty) = P.DDDec [trb x] (trt ty) + +tri :: Ident -> Ident +tri i = case prIdent i of + s@('_':_:_) -> identC $ 'h':s ---- unsafe; needed since _3 etc are generated + s -> identC $ s + +trb i = if isWildIdent i then P.BWild else P.BIdent (tri i) + +trLabel i = case i of + LIdent s -> P.LIdent $ identC s + LVar i -> P.LVar $ toInteger i + +trLabelIdent i = identC $ case i of + LIdent s -> s + LVar i -> "v" ++ show i --- should not happen + diff --git a/src/GF/Source/LexGF.hs b/src/GF/Source/LexGF.hs new file mode 100644 index 000000000..e9406dd78 --- /dev/null +++ b/src/GF/Source/LexGF.hs @@ -0,0 +1,127 @@ +module LexGF where + +import Alex +import ErrM + +pTSpec p = PT p . TS + +mk_LString p = PT p . eitherResIdent T_LString + +ident p = PT p . eitherResIdent TV + +string p = PT p . TL . unescapeInitTail + +int p = PT p . TI + + +data Tok = + TS String -- reserved words + | TL String -- string literals + | TI String -- integer literals + | TV String -- identifiers + | TD String -- double precision float literals + | TC String -- character literals + | T_LString String + + deriving (Eq,Show) + +data Token = + PT Posn Tok + | Err Posn + deriving Show + +tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l +tokenPos (Err (Pn _ l _) :_) = "line " ++ show l +tokenPos _ = "end of file" + +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 + +tokens:: String -> [Token] +tokens inp = scan tokens_scan inp + +tokens_scan:: Scan Token +tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx + where + stop_act p "" = [] + stop_act p inp = [Err p] + +eitherResIdent :: (String -> Tok) -> String -> Tok +eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where + isResWord s = isInTree s $ + B "let" (B "concrete" (B "Tok" (B "Str" (B "PType" (B "Lin" N N) N) (B "Strs" N N)) (B "case" (B "abstract" (B "Type" N N) N) (B "cat" N N))) (B "fun" (B "flags" (B "def" (B "data" N N) N) (B "fn" N N)) (B "in" (B "grammar" N N) (B "include" N N)))) (B "pattern" (B "of" (B "lindef" (B "lincat" (B "lin" N N) N) (B "lintype" N N)) (B "out" (B "oper" (B "open" N N) N) (B "param" N N))) (B "strs" (B "resource" (B "printname" (B "pre" N N) N) (B "reuse" N N)) (B "transfer" (B "table" N N) (B "variants" N N)))) + +data BTree = N | B String BTree BTree deriving (Show) + +isInTree :: String -> BTree -> Bool +isInTree x tree = case tree of + N -> False + B a left right + | x < a -> isInTree x left + | x > a -> isInTree x right + | x == a -> True + +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 + _ -> [] + +tokens_acts = [("ident",ident),("int",int),("mk_LString",mk_LString),("pTSpec",pTSpec),("string",string)] + +tokens_lx :: [(Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))] +tokens_lx = [lx__0_0,lx__1_0,lx__2_0,lx__3_0,lx__4_0,lx__5_0,lx__6_0,lx__7_0,lx__8_0,lx__9_0,lx__10_0,lx__11_0,lx__12_0,lx__13_0,lx__14_0,lx__15_0,lx__16_0,lx__17_0,lx__18_0,lx__19_0,lx__20_0,lx__21_0] +lx__0_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__0_0 = (False,[],-1,(('\t','\255'),[('\t',10),('\n',10),('\v',10),('\f',10),('\r',10),(' ',10),('!',14),('"',18),('$',14),('\'',15),('(',14),(')',14),('*',11),('+',13),(',',14),('-',1),('.',14),('/',14),('0',21),('1',21),('2',21),('3',21),('4',21),('5',21),('6',21),('7',21),('8',21),('9',21),(':',14),(';',14),('<',14),('=',12),('>',14),('?',14),('@',14),('A',17),('B',17),('C',17),('D',17),('E',17),('F',17),('G',17),('H',17),('I',17),('J',17),('K',17),('L',17),('M',17),('N',17),('O',17),('P',17),('Q',17),('R',17),('S',17),('T',17),('U',17),('V',17),('W',17),('X',17),('Y',17),('Z',17),('[',14),('\\',14),(']',14),('_',14),('a',17),('b',17),('c',17),('d',17),('e',17),('f',17),('g',17),('h',17),('i',17),('j',17),('k',17),('l',17),('m',17),('n',17),('o',17),('p',17),('q',17),('r',17),('s',17),('t',17),('u',17),('v',17),('w',17),('x',17),('y',17),('z',17),('{',4),('|',14),('}',14),('\192',17),('\193',17),('\194',17),('\195',17),('\196',17),('\197',17),('\198',17),('\199',17),('\200',17),('\201',17),('\202',17),('\203',17),('\204',17),('\205',17),('\206',17),('\207',17),('\208',17),('\209',17),('\210',17),('\211',17),('\212',17),('\213',17),('\214',17),('\216',17),('\217',17),('\218',17),('\219',17),('\220',17),('\221',17),('\222',17),('\223',17),('\224',17),('\225',17),('\226',17),('\227',17),('\228',17),('\229',17),('\230',17),('\231',17),('\232',17),('\233',17),('\234',17),('\235',17),('\236',17),('\237',17),('\238',17),('\239',17),('\240',17),('\241',17),('\242',17),('\243',17),('\244',17),('\245',17),('\246',17),('\248',17),('\249',17),('\250',17),('\251',17),('\252',17),('\253',17),('\254',17),('\255',17)])) +lx__1_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__1_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('-','>'),[('-',2),('>',14)])) +lx__2_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__2_0 = (False,[],2,(('\n','\n'),[('\n',3)])) +lx__3_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__3_0 = (True,[(0,"",[],Nothing,Nothing)],-1,(('0','0'),[])) +lx__4_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__4_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('-','-'),[('-',5)])) +lx__5_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__5_0 = (False,[],5,(('-','-'),[('-',8)])) +lx__6_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__6_0 = (False,[],5,(('-','}'),[('-',8),('}',7)])) +lx__7_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__7_0 = (True,[(1,"",[],Nothing,Nothing)],5,(('-','-'),[('-',8)])) +lx__8_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__8_0 = (False,[],5,(('-','}'),[('-',6),('}',9)])) +lx__9_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__9_0 = (True,[(1,"",[],Nothing,Nothing)],-1,(('0','0'),[])) +lx__10_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__10_0 = (True,[(2,"",[],Nothing,Nothing)],-1,(('\t',' '),[('\t',10),('\n',10),('\v',10),('\f',10),('\r',10),(' ',10)])) +lx__11_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__11_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('*','*'),[('*',14)])) +lx__12_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__12_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('>','>'),[('>',14)])) +lx__13_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__13_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('+','+'),[('+',14)])) +lx__14_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__14_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('0','0'),[])) +lx__15_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__15_0 = (False,[],15,(('\'','\''),[('\'',16)])) +lx__16_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__16_0 = (True,[(4,"mk_LString",[],Nothing,Nothing)],15,(('\'','\''),[('\'',16)])) +lx__17_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__17_0 = (True,[(5,"ident",[],Nothing,Nothing)],-1,(('\'','\255'),[('\'',17),('0',17),('1',17),('2',17),('3',17),('4',17),('5',17),('6',17),('7',17),('8',17),('9',17),('A',17),('B',17),('C',17),('D',17),('E',17),('F',17),('G',17),('H',17),('I',17),('J',17),('K',17),('L',17),('M',17),('N',17),('O',17),('P',17),('Q',17),('R',17),('S',17),('T',17),('U',17),('V',17),('W',17),('X',17),('Y',17),('Z',17),('_',17),('a',17),('b',17),('c',17),('d',17),('e',17),('f',17),('g',17),('h',17),('i',17),('j',17),('k',17),('l',17),('m',17),('n',17),('o',17),('p',17),('q',17),('r',17),('s',17),('t',17),('u',17),('v',17),('w',17),('x',17),('y',17),('z',17),('\192',17),('\193',17),('\194',17),('\195',17),('\196',17),('\197',17),('\198',17),('\199',17),('\200',17),('\201',17),('\202',17),('\203',17),('\204',17),('\205',17),('\206',17),('\207',17),('\208',17),('\209',17),('\210',17),('\211',17),('\212',17),('\213',17),('\214',17),('\216',17),('\217',17),('\218',17),('\219',17),('\220',17),('\221',17),('\222',17),('\223',17),('\224',17),('\225',17),('\226',17),('\227',17),('\228',17),('\229',17),('\230',17),('\231',17),('\232',17),('\233',17),('\234',17),('\235',17),('\236',17),('\237',17),('\238',17),('\239',17),('\240',17),('\241',17),('\242',17),('\243',17),('\244',17),('\245',17),('\246',17),('\248',17),('\249',17),('\250',17),('\251',17),('\252',17),('\253',17),('\254',17),('\255',17)])) +lx__18_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__18_0 = (False,[],18,(('\n','\\'),[('\n',-1),('"',20),('\\',19)])) +lx__19_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__19_0 = (False,[],-1,(('"','t'),[('"',18),('\'',18),('\\',18),('n',18),('t',18)])) +lx__20_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__20_0 = (True,[(6,"string",[],Nothing,Nothing)],-1,(('0','0'),[])) +lx__21_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)])) +lx__21_0 = (True,[(7,"int",[],Nothing,Nothing)],-1,(('0','9'),[('0',21),('1',21),('2',21),('3',21),('4',21),('5',21),('6',21),('7',21),('8',21),('9',21)])) + diff --git a/src/GF/Source/PrintGF.hs b/src/GF/Source/PrintGF.hs new file mode 100644 index 000000000..9d71dfe6e --- /dev/null +++ b/src/GF/Source/PrintGF.hs @@ -0,0 +1,435 @@ +module PrintGF where + +-- pretty-printer generated by the BNF converter, except --H + +import AbsGF +import Ident --H +import Char + +-- the top-level printing method +printTree :: Print a => a -> String +printTree = render . prt 0 + +-- you may want to change render and parenth + +render :: [String] -> String +render = rend 0 where + rend i ss = case ss of + + --H these three are hand-written + "{0" :ts -> cons "{" $ rend (i+1) ts + t :"}0" :ts -> cons t $ space "}" $ rend (i-1) ts + t : "." :ts -> cons t $ cons "." $ rend i ts + + "[" :ts -> cons "[" $ rend i ts + "(" :ts -> cons "(" $ rend i ts + "{" :ts -> cons "{" $ new (i+1) $ rend (i+1) ts + "}" : ";":ts -> new (i-1) $ space "}" $ cons ";" $ new (i-1) $ rend (i-1) ts + "}" :ts -> new (i-1) $ cons "}" $ new (i-1) $ rend (i-1) ts + ";" :ts -> cons ";" $ new i $ rend i ts + t : "," :ts -> cons t $ space "," $ rend i ts + t : ")" :ts -> cons t $ cons ")" $ rend i ts + t : "]" :ts -> cons t $ cons "]" $ rend i ts + t :ts -> space t $ rend i ts + _ -> "" + cons s t = s ++ t + new i s = '\n' : replicate (2*i) ' ' ++ dropWhile isSpace s + space t s = if null s then t else t ++ " " ++ s + +parenth :: [String] -> [String] +parenth ss = ["("] ++ ss ++ [")"] + +-- the printer class does the job +class Print a where + prt :: Int -> a -> [String] + prtList :: [a] -> [String] + prtList = concat . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Integer where + prt _ = (:[]) . show + +instance Print Double where + prt _ = (:[]) . show + +instance Print Char where + prt _ s = ["'" ++ mkEsc s ++ "'"] + prtList s = ["\"" ++ concatMap mkEsc s ++ "\""] + +mkEsc s = case s of + _ | elem s "\\\"'" -> '\\':[s] + '\n' -> "\\n" + '\t' -> "\\t" + _ -> [s] + +prPrec :: Int -> Int -> [String] -> [String] +prPrec i j = if j (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [","] , prt 0 xs]) + + +instance Print LString where + prt _ (LString i) = [i] + + + +instance Print Grammar where + prt i e = case e of + Gr moddefs -> prPrec i 0 (concat [prt 0 moddefs]) + + +instance Print ModDef where + prt i e = case e of + MMain id0 id concspecs -> prPrec i 0 (concat [["grammar"] , prt 0 id0 , ["="] , ["{"] , ["abstract"] , ["="] , prt 0 id , [";"] , prt 0 concspecs , ["}"]]) + MAbstract id extend opens topdefs -> prPrec i 0 (concat [["abstract"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]]) + MResource id extend opens topdefs -> prPrec i 0 (concat [["resource"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]]) + MResourceInt id extend opens topdefs -> prPrec i 0 (concat [["resource"] , ["abstract"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]]) + MResourceImp id0 id opens topdefs -> prPrec i 0 (concat [["resource"] , prt 0 id0 , ["of"] , prt 0 id , ["="] , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]]) + MConcrete id0 id extend opens topdefs -> prPrec i 0 (concat [["concrete"] , prt 0 id0 , ["of"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]]) + MConcreteInt id0 id extend opens topdefs -> prPrec i 0 (concat [["concrete"] , ["abstract"] , ["of"] , prt 0 id0 , ["in"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]]) + MConcreteImp open id0 id -> prPrec i 0 (concat [["concrete"] , ["of"] , prt 0 open , ["="] , prt 0 id0 , ["**"] , prt 0 id]) + MTransfer id open0 open extend opens topdefs -> prPrec i 0 (concat [["transfer"] , prt 0 id , [":"] , prt 0 open0 , ["->"] , prt 0 open , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]]) + MReuseAbs id0 id -> prPrec i 0 (concat [["resource"] , ["abstract"] , prt 0 id0 , ["="] , ["reuse"] , prt 0 id]) + MReuseCnc id0 id -> prPrec i 0 (concat [["resource"] , ["concrete"] , prt 0 id0 , ["="] , ["reuse"] , prt 0 id]) + MReuseAll id0 extend id -> prPrec i 0 (concat [["resource"] , prt 0 id0 , ["="] , prt 0 extend , ["reuse"] , prt 0 id]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print ConcSpec where + prt i e = case e of + ConcSpec id concexp -> prPrec i 0 (concat [prt 0 id , ["="] , prt 0 concexp]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print ConcExp where + prt i e = case e of + ConcExp id transfers -> prPrec i 0 (concat [prt 0 id , prt 0 transfers]) + + +instance Print Transfer where + prt i e = case e of + TransferIn open -> prPrec i 0 (concat [["("] , ["transfer"] , ["in"] , prt 0 open , [")"]]) + TransferOut open -> prPrec i 0 (concat [["("] , ["transfer"] , ["out"] , prt 0 open , [")"]]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print Extend where + prt i e = case e of + Ext id -> prPrec i 0 (concat [prt 0 id , ["**"]]) + NoExt -> prPrec i 0 (concat []) + + +instance Print Opens where + prt i e = case e of + NoOpens -> prPrec i 0 (concat []) + Opens opens -> prPrec i 0 (concat [["open"] , prt 0 opens , ["in"]]) + + +instance Print Open where + prt i e = case e of + OName id -> prPrec i 0 (concat [prt 0 id]) + OQual id0 id -> prPrec i 0 (concat [["("] , prt 0 id0 , ["="] , prt 0 id , [")"]]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [","] , prt 0 xs]) + +instance Print Def where + prt i e = case e of + DDecl ids exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp]) + DDef ids exp -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 exp]) + DPatt id patts exp -> prPrec i 0 (concat [prt 0 id , prt 0 patts , ["="] , prt 0 exp]) + DFull ids exp0 exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp0 , ["="] , prt 0 exp]) + + prtList es = case es of + [x] -> (concat [prt 0 x , [";"]]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print TopDef where + prt i e = case e of + DefCat catdefs -> prPrec i 0 (concat [["cat"] , prt 0 catdefs]) + DefFun fundefs -> prPrec i 0 (concat [["fun"] , prt 0 fundefs]) + DefDef defs -> prPrec i 0 (concat [["def"] , prt 0 defs]) + DefData pardefs -> prPrec i 0 (concat [["data"] , prt 0 pardefs]) + DefTrans flagdefs -> prPrec i 0 (concat [["transfer"] , prt 0 flagdefs]) + DefPar pardefs -> prPrec i 0 (concat [["param"] , prt 0 pardefs]) + DefOper defs -> prPrec i 0 (concat [["oper"] , prt 0 defs]) + DefLincat printdefs -> prPrec i 0 (concat [["lincat"] , prt 0 printdefs]) + DefLindef defs -> prPrec i 0 (concat [["lindef"] , prt 0 defs]) + DefLin defs -> prPrec i 0 (concat [["lin"] , prt 0 defs]) + DefPrintCat printdefs -> prPrec i 0 (concat [["printname"] , ["cat"] , prt 0 printdefs]) + DefPrintFun printdefs -> prPrec i 0 (concat [["printname"] , ["fun"] , prt 0 printdefs]) + DefFlag flagdefs -> prPrec i 0 (concat [["flags"] , prt 0 flagdefs]) + DefPrintOld printdefs -> prPrec i 0 (concat [["printname"] , prt 0 printdefs]) + DefLintype defs -> prPrec i 0 (concat [["lintype"] , prt 0 defs]) + DefPattern defs -> prPrec i 0 (concat [["pattern"] , prt 0 defs]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print CatDef where + prt i e = case e of + CatDef id ddecls -> prPrec i 0 (concat [prt 0 id , prt 0 ddecls]) + + prtList es = case es of + [x] -> (concat [prt 0 x , [";"]]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print FunDef where + prt i e = case e of + FunDef ids exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp]) + + prtList es = case es of + [x] -> (concat [prt 0 x , [";"]]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print ParDef where + prt i e = case e of + ParDef id parconstrs -> prPrec i 0 (concat [prt 0 id , ["="] , prt 0 parconstrs]) + ParDefIndir id0 id -> prPrec i 0 (concat [prt 0 id0 , ["="] , ["("] , ["in"] , prt 0 id , [")"]]) + ParDefAbs id -> prPrec i 0 (concat [prt 0 id]) + + prtList es = case es of + [x] -> (concat [prt 0 x , [";"]]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print ParConstr where + prt i e = case e of + ParConstr id ddecls -> prPrec i 0 (concat [prt 0 id , prt 0 ddecls]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs]) + +instance Print PrintDef where + prt i e = case e of + PrintDef ids exp -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 exp]) + + prtList es = case es of + [x] -> (concat [prt 0 x , [";"]]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print FlagDef where + prt i e = case e of + FlagDef id0 id -> prPrec i 0 (concat [prt 0 id0 , ["="] , prt 0 id]) + + prtList es = case es of + [x] -> (concat [prt 0 x , [";"]]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print LocDef where + prt i e = case e of + LDDecl ids exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp]) + LDDef ids exp -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 exp]) + LDFull ids exp0 exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp0 , ["="] , prt 0 exp]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Exp where + prt i e = case e of + EIdent id -> prPrec i 4 (concat [prt 0 id]) + EConstr id -> prPrec i 4 (concat [["{0"] , prt 0 id , ["}0"]]) --H + ECons id -> prPrec i 4 (concat [["["] , prt 0 id , ["]"]]) + ESort sort -> prPrec i 4 (concat [prt 0 sort]) + EString str -> prPrec i 4 (concat [prt 0 str]) + EInt n -> prPrec i 4 (concat [prt 0 n]) + EMeta -> prPrec i 4 (concat [["?"]]) + EEmpty -> prPrec i 4 (concat [["["] , ["]"]]) + EStrings str -> prPrec i 4 (concat [["["] , prt 0 str , ["]"]]) + ERecord locdefs -> prPrec i 4 (concat [["{"] , prt 0 locdefs , ["}"]]) + ETuple tuplecomps -> prPrec i 4 (concat [["<"] , prt 0 tuplecomps , [">"]]) + EIndir id -> prPrec i 4 (concat [["("] , ["in"] , prt 0 id , [")"]]) + ETyped exp0 exp -> prPrec i 4 (concat [["<"] , prt 0 exp0 , [":"] , prt 0 exp , [">"]]) + EProj exp label -> prPrec i 3 (concat [prt 3 exp , ["."] , prt 0 label]) + EQConstr id0 id -> prPrec i 3 (concat [["{0"] , prt 0 id0 , ["."] , prt 0 id , ["}0"]]) --H + EQCons id0 id -> prPrec i 3 (concat [["["] , prt 0 id0 , ["."] , prt 0 id , ["]"]]) + EApp exp0 exp -> prPrec i 2 (concat [prt 2 exp0 , prt 3 exp]) + ETable cases -> prPrec i 2 (concat [["table"] , ["{"] , prt 0 cases , ["}"]]) + ETTable exp cases -> prPrec i 2 (concat [["table"] , prt 4 exp , ["{"] , prt 0 cases , ["}"]]) + ECase exp cases -> prPrec i 2 (concat [["case"] , prt 0 exp , ["of"] , ["{"] , prt 0 cases , ["}"]]) + EVariants exps -> prPrec i 2 (concat [["variants"] , ["{"] , prt 0 exps , ["}"]]) + EPre exp alterns -> prPrec i 2 (concat [["pre"] , ["{"] , prt 0 exp , [";"] , prt 0 alterns , ["}"]]) + EStrs exps -> prPrec i 2 (concat [["strs"] , ["{"] , prt 0 exps , ["}"]]) + EConAt id exp -> prPrec i 2 (concat [prt 0 id , ["@"] , prt 4 exp]) + ESelect exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , ["!"] , prt 2 exp]) + ETupTyp exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , ["*"] , prt 2 exp]) + EExtend exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , ["**"] , prt 2 exp]) + EAbstr binds exp -> prPrec i 0 (concat [["\\"] , prt 0 binds , ["->"] , prt 0 exp]) + ECTable binds exp -> prPrec i 0 (concat [["\\"] , ["\\"] , prt 0 binds , ["=>"] , prt 0 exp]) + EProd decl exp -> prPrec i 0 (concat [prt 0 decl , ["->"] , prt 0 exp]) + ETType exp0 exp -> prPrec i 0 (concat [prt 1 exp0 , ["=>"] , prt 0 exp]) + EConcat exp0 exp -> prPrec i 0 (concat [prt 1 exp0 , ["++"] , prt 0 exp]) + EGlue exp0 exp -> prPrec i 0 (concat [prt 1 exp0 , ["+"] , prt 0 exp]) + ELet locdefs exp -> prPrec i 0 (concat [["let"] , ["{"] , prt 0 locdefs , ["}"] , ["in"] , prt 0 exp]) + EEqs equations -> prPrec i 0 (concat [["fn"] , ["{"] , prt 0 equations , ["}"]]) + ELString lstring -> prPrec i 4 (concat [prt 0 lstring]) + ELin id -> prPrec i 2 (concat [["Lin"] , prt 0 id]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Patt where + prt i e = case e of + PW -> prPrec i 1 (concat [["_"]]) + PV id -> prPrec i 1 (concat [prt 0 id]) + PCon id -> prPrec i 1 (concat [["{0"] , prt 0 id , ["}0"]]) --H + PQ id0 id -> prPrec i 1 (concat [prt 0 id0 , ["."] , prt 0 id]) + PInt n -> prPrec i 1 (concat [prt 0 n]) + PStr str -> prPrec i 1 (concat [prt 0 str]) + PR pattasss -> prPrec i 1 (concat [["{"] , prt 0 pattasss , ["}"]]) + PTup patttuplecomps -> prPrec i 1 (concat [["<"] , prt 0 patttuplecomps , [">"]]) + PC id patts -> prPrec i 0 (concat [prt 0 id , prt 0 patts]) + PQC id0 id patts -> prPrec i 0 (concat [prt 0 id0 , ["."] , prt 0 id , prt 0 patts]) + + prtList es = case es of + [x] -> (concat [prt 1 x]) + x:xs -> (concat [prt 1 x , prt 0 xs]) + +instance Print PattAss where + prt i e = case e of + PA ids patt -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 patt]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Label where + prt i e = case e of + LIdent id -> prPrec i 0 (concat [prt 0 id]) + LVar n -> prPrec i 0 (concat [["$"] , prt 0 n]) + + +instance Print Sort where + prt i e = case e of + Sort_Type -> prPrec i 0 (concat [["Type"]]) + Sort_PType -> prPrec i 0 (concat [["PType"]]) + Sort_Tok -> prPrec i 0 (concat [["Tok"]]) + Sort_Str -> prPrec i 0 (concat [["Str"]]) + Sort_Strs -> prPrec i 0 (concat [["Strs"]]) + + +instance Print PattAlt where + prt i e = case e of + AltP patt -> prPrec i 0 (concat [prt 0 patt]) + + prtList es = case es of + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs]) + +instance Print Bind where + prt i e = case e of + BIdent id -> prPrec i 0 (concat [prt 0 id]) + BWild -> prPrec i 0 (concat [["_"]]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [","] , prt 0 xs]) + +instance Print Decl where + prt i e = case e of + DDec binds exp -> prPrec i 0 (concat [["("] , prt 0 binds , [":"] , prt 0 exp , [")"]]) + DExp exp -> prPrec i 0 (concat [prt 2 exp]) + + +instance Print TupleComp where + prt i e = case e of + TComp exp -> prPrec i 0 (concat [prt 0 exp]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [","] , prt 0 xs]) + +instance Print PattTupleComp where + prt i e = case e of + PTComp patt -> prPrec i 0 (concat [prt 0 patt]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [","] , prt 0 xs]) + +instance Print Case where + prt i e = case e of + Case pattalts exp -> prPrec i 0 (concat [prt 0 pattalts , ["=>"] , prt 0 exp]) + + prtList es = case es of + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Equation where + prt i e = case e of + Equ patts exp -> prPrec i 0 (concat [prt 0 patts , ["->"] , prt 0 exp]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print Altern where + prt i e = case e of + Alt exp0 exp -> prPrec i 0 (concat [prt 0 exp0 , ["/"] , prt 0 exp]) + + prtList es = case es of + [] -> (concat []) + [x] -> (concat [prt 0 x]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + +instance Print DDecl where + prt i e = case e of + DDDec binds exp -> prPrec i 0 (concat [["("] , prt 0 binds , [":"] , prt 0 exp , [")"]]) + DDExp exp -> prPrec i 0 (concat [prt 4 exp]) + + prtList es = case es of + [] -> (concat []) + x:xs -> (concat [prt 0 x , prt 0 xs]) + +instance Print OldGrammar where + prt i e = case e of + OldGr include topdefs -> prPrec i 0 (concat [prt 0 include , prt 0 topdefs]) + + +instance Print Include where + prt i e = case e of + NoIncl -> prPrec i 0 (concat []) + Incl filenames -> prPrec i 0 (concat [["include"] , prt 0 filenames]) + + +instance Print FileName where + prt i e = case e of + FString str -> prPrec i 0 (concat [prt 0 str]) + FIdent id -> prPrec i 0 (concat [prt 0 id]) + FSlash filename -> prPrec i 0 (concat [["/"] , prt 0 filename]) + FDot filename -> prPrec i 0 (concat [["."] , prt 0 filename]) + FMinus filename -> prPrec i 0 (concat [["-"] , prt 0 filename]) + FAddId id filename -> prPrec i 0 (concat [prt 0 id , prt 0 filename]) + + prtList es = case es of + [x] -> (concat [prt 0 x , [";"]]) + x:xs -> (concat [prt 0 x , [";"] , prt 0 xs]) + + diff --git a/src/GF/Source/SkelGF.hs b/src/GF/Source/SkelGF.hs new file mode 100644 index 000000000..cf0932a87 --- /dev/null +++ b/src/GF/Source/SkelGF.hs @@ -0,0 +1,289 @@ +module SkelGF where + +-- Haskell module generated by the BNF converter + +import AbsGF +import Ident +import ErrM +type Result = Err String + +failure :: Show a => a -> Result +failure x = Bad $ "Undefined case: " ++ show x + +transIdent :: Ident -> Result +transIdent x = case x of + _ -> failure x + + +transLString :: LString -> Result +transLString x = case x of + LString str -> failure x + + +transGrammar :: Grammar -> Result +transGrammar x = case x of + Gr moddefs -> failure x + + +transModDef :: ModDef -> Result +transModDef x = case x of + MMain id0 id concspecs -> failure x + MAbstract id extend opens topdefs -> failure x + MResource id extend opens topdefs -> failure x + MResourceInt id extend opens topdefs -> failure x + MResourceImp id0 id opens topdefs -> failure x + MConcrete id0 id extend opens topdefs -> failure x + MConcreteInt id0 id extend opens topdefs -> failure x + MConcreteImp open id0 id -> failure x + MTransfer id open0 open extend opens topdefs -> failure x + MReuseAbs id0 id -> failure x + MReuseCnc id0 id -> failure x + MReuseAll id0 extend id -> failure x + + +transConcSpec :: ConcSpec -> Result +transConcSpec x = case x of + ConcSpec id concexp -> failure x + + +transConcExp :: ConcExp -> Result +transConcExp x = case x of + ConcExp id transfers -> failure x + + +transTransfer :: Transfer -> Result +transTransfer x = case x of + TransferIn open -> failure x + TransferOut open -> failure x + + +transExtend :: Extend -> Result +transExtend x = case x of + Ext id -> failure x + NoExt -> failure x + + +transOpens :: Opens -> Result +transOpens x = case x of + NoOpens -> failure x + Opens opens -> failure x + + +transOpen :: Open -> Result +transOpen x = case x of + OName id -> failure x + OQual id0 id -> failure x + + +transDef :: Def -> Result +transDef x = case x of + DDecl ids exp -> failure x + DDef ids exp -> failure x + DPatt id patts exp -> failure x + DFull ids exp0 exp -> failure x + + +transTopDef :: TopDef -> Result +transTopDef x = case x of + DefCat catdefs -> failure x + DefFun fundefs -> failure x + DefDef defs -> failure x + DefData pardefs -> failure x + DefTrans flagdefs -> failure x + DefPar pardefs -> failure x + DefOper defs -> failure x + DefLincat printdefs -> failure x + DefLindef defs -> failure x + DefLin defs -> failure x + DefPrintCat printdefs -> failure x + DefPrintFun printdefs -> failure x + DefFlag flagdefs -> failure x + DefPrintOld printdefs -> failure x + DefLintype defs -> failure x + DefPattern defs -> failure x + + +transCatDef :: CatDef -> Result +transCatDef x = case x of + CatDef id ddecls -> failure x + + +transFunDef :: FunDef -> Result +transFunDef x = case x of + FunDef ids exp -> failure x + + +transParDef :: ParDef -> Result +transParDef x = case x of + ParDef id parconstrs -> failure x + ParDefIndir id0 id -> failure x + ParDefAbs id -> failure x + + +transParConstr :: ParConstr -> Result +transParConstr x = case x of + ParConstr id ddecls -> failure x + + +transPrintDef :: PrintDef -> Result +transPrintDef x = case x of + PrintDef ids exp -> failure x + + +transFlagDef :: FlagDef -> Result +transFlagDef x = case x of + FlagDef id0 id -> failure x + + +transLocDef :: LocDef -> Result +transLocDef x = case x of + LDDecl ids exp -> failure x + LDDef ids exp -> failure x + LDFull ids exp0 exp -> failure x + + +transExp :: Exp -> Result +transExp x = case x of + EIdent id -> failure x + EConstr id -> failure x + ECons id -> failure x + ESort sort -> failure x + EString str -> failure x + EInt n -> failure x + EMeta -> failure x + EEmpty -> failure x + EStrings str -> failure x + ERecord locdefs -> failure x + ETuple tuplecomps -> failure x + EIndir id -> failure x + ETyped exp0 exp -> failure x + EProj exp label -> failure x + EQConstr id0 id -> failure x + EQCons id0 id -> failure x + EApp exp0 exp -> failure x + ETable cases -> failure x + ETTable exp cases -> failure x + ECase exp cases -> failure x + EVariants exps -> failure x + EPre exp alterns -> failure x + EStrs exps -> failure x + EConAt id exp -> failure x + ESelect exp0 exp -> failure x + ETupTyp exp0 exp -> failure x + EExtend exp0 exp -> failure x + EAbstr binds exp -> failure x + ECTable binds exp -> failure x + EProd decl exp -> failure x + ETType exp0 exp -> failure x + EConcat exp0 exp -> failure x + EGlue exp0 exp -> failure x + ELet locdefs exp -> failure x + EEqs equations -> failure x + ELString lstring -> failure x + ELin id -> failure x + + +transPatt :: Patt -> Result +transPatt x = case x of + PW -> failure x + PV id -> failure x + PCon id -> failure x + PQ id0 id -> failure x + PInt n -> failure x + PStr str -> failure x + PR pattasss -> failure x + PTup patttuplecomps -> failure x + PC id patts -> failure x + PQC id0 id patts -> failure x + + +transPattAss :: PattAss -> Result +transPattAss x = case x of + PA ids patt -> failure x + + +transLabel :: Label -> Result +transLabel x = case x of + LIdent id -> failure x + LVar n -> failure x + + +transSort :: Sort -> Result +transSort x = case x of + Sort_Type -> failure x + Sort_PType -> failure x + Sort_Tok -> failure x + Sort_Str -> failure x + Sort_Strs -> failure x + + +transPattAlt :: PattAlt -> Result +transPattAlt x = case x of + AltP patt -> failure x + + +transBind :: Bind -> Result +transBind x = case x of + BIdent id -> failure x + BWild -> failure x + + +transDecl :: Decl -> Result +transDecl x = case x of + DDec binds exp -> failure x + DExp exp -> failure x + + +transTupleComp :: TupleComp -> Result +transTupleComp x = case x of + TComp exp -> failure x + + +transPattTupleComp :: PattTupleComp -> Result +transPattTupleComp x = case x of + PTComp patt -> failure x + + +transCase :: Case -> Result +transCase x = case x of + Case pattalts exp -> failure x + + +transEquation :: Equation -> Result +transEquation x = case x of + Equ patts exp -> failure x + + +transAltern :: Altern -> Result +transAltern x = case x of + Alt exp0 exp -> failure x + + +transDDecl :: DDecl -> Result +transDDecl x = case x of + DDDec binds exp -> failure x + DDExp exp -> failure x + + +transOldGrammar :: OldGrammar -> Result +transOldGrammar x = case x of + OldGr include topdefs -> failure x + + +transInclude :: Include -> Result +transInclude x = case x of + NoIncl -> failure x + Incl filenames -> failure x + + +transFileName :: FileName -> Result +transFileName x = case x of + FString str -> failure x + FIdent id -> failure x + FSlash filename -> failure x + FDot filename -> failure x + FMinus filename -> failure x + FAddId id filename -> failure x + + + diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs new file mode 100644 index 000000000..f9e098e08 --- /dev/null +++ b/src/GF/Source/SourceToGrammar.hs @@ -0,0 +1,505 @@ +module SourceToGrammar where + +import qualified Grammar as G +import qualified PrGrammar as GP +import qualified Modules as GM +import qualified Macros as M +import qualified Update as U +import qualified Option as GO +import qualified ModDeps as GD +import Ident +import AbsGF +import PrintGF +import RemoveLiT --- for bw compat +import Operations + +import Monad +import Char + +-- based on the skeleton Haskell module generated by the BNF converter + +type Result = Err String + +failure :: Show a => a -> Err b +failure x = Bad $ "Undefined case: " ++ show x + +transIdent :: Ident -> Err Ident +transIdent x = case x of + x -> return x + +transGrammar :: Grammar -> Err G.SourceGrammar +transGrammar x = case x of + Gr moddefs -> do + moddefs' <- mapM transModDef moddefs + GD.mkSourceGrammar moddefs' + +transModDef :: ModDef -> Err (Ident, G.SourceModInfo) +transModDef x = case x of + MMain id0 id concspecs -> do + id0' <- transIdent id0 + id' <- transIdent id + concspecs' <- mapM transConcSpec concspecs + return $ (id0', GM.ModMainGrammar (GM.MainGrammar id' concspecs')) + MAbstract id extends opens defs -> do + id' <- transIdent id + extends' <- transExtend extends + opens' <- transOpens opens + defs0 <- mapM transAbsDef $ getTopDefs defs + defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] + flags <- return [f | Right fs <- defs0, f <- fs] + return $ (id', GM.ModMod (GM.Module GM.MTAbstract flags extends' opens' defs')) + MResource id extends opens defs -> do + id' <- transIdent id + extends' <- transExtend extends + opens' <- transOpens opens + defs0 <- mapM transResDef $ getTopDefs defs + defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] + flags <- return [f | Right fs <- defs0, f <- fs] + return $ (id', GM.ModMod (GM.Module GM.MTResource flags extends' opens' defs')) + MConcrete id open extends opens defs -> do + id' <- transIdent id + open' <- transIdent open + extends' <- transExtend extends + opens' <- transOpens opens + defs0 <- mapM transCncDef $ getTopDefs defs + defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] + flags <- return [f | Right fs <- defs0, f <- fs] + return $ (id', + GM.ModMod (GM.Module (GM.MTConcrete open') flags extends' opens' defs')) + MTransfer id open0 open extends opens defs -> do + id' <- transIdent id + open0' <- transOpen open0 + open' <- transOpen open + extends' <- transExtend extends + opens' <- transOpens opens + defs0 <- mapM transAbsDef $ getTopDefs defs + defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] + flags <- return [f | Right fs <- defs0, f <- fs] + return $ (id', + GM.ModMod (GM.Module (GM.MTTransfer open0' open') flags extends' opens' defs')) + + MReuseAbs id0 id -> failure x + MReuseCnc id0 id -> failure x + MReuseAll r e c -> do + r' <- transIdent r + e' <- transExtend e + c' <- transIdent c + return $ (r', GM.ModMod (GM.Module (GM.MTReuse c') [] e' [] NT)) + +getTopDefs :: [TopDef] -> [TopDef] +getTopDefs x = x + +transConcSpec :: ConcSpec -> Err (GM.MainConcreteSpec Ident) +transConcSpec x = case x of + ConcSpec id concexp -> do + id' <- transIdent id + (m,mi,mo) <- transConcExp concexp + return $ GM.MainConcreteSpec id' m mi mo + +transConcExp :: ConcExp -> + Err (Ident, Maybe (GM.OpenSpec Ident),Maybe (GM.OpenSpec Ident)) +transConcExp x = case x of + ConcExp id transfers -> do + id' <- transIdent id + trs <- mapM transTransfer transfers + tin <- case [o | Left o <- trs] of + [o] -> return $ Just o + [] -> return $ Nothing + _ -> Bad "ambiguous transfer in" + tout <- case [o | Right o <- trs] of + [o] -> return $ Just o + [] -> return $ Nothing + _ -> Bad "ambiguous transfer out" + return (id',tin,tout) + +transTransfer :: Transfer -> + Err (Either (GM.OpenSpec Ident)(GM.OpenSpec Ident)) +transTransfer x = case x of + TransferIn open -> liftM Left $ transOpen open + TransferOut open -> liftM Right $ transOpen open + +transExtend :: Extend -> Err (Maybe Ident) +transExtend x = case x of + Ext id -> transIdent id >>= return . Just + NoExt -> return Nothing + +transOpens :: Opens -> Err [GM.OpenSpec Ident] +transOpens x = case x of + NoOpens -> return [] + Opens opens -> mapM transOpen opens + +transOpen :: Open -> Err (GM.OpenSpec Ident) +transOpen x = case x of + OName id -> liftM GM.OSimple $ transIdent id + OQual id m -> liftM2 GM.OQualif (transIdent id) (transIdent m) + +transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option]) +transAbsDef x = case x of + DefCat catdefs -> do + catdefs' <- mapM transCatDef catdefs + returnl [(cat, G.AbsCat (yes cont) nope) | (cat,cont) <- catdefs'] + DefFun fundefs -> do + fundefs' <- mapM transFunDef fundefs + returnl [(fun, G.AbsFun (yes typ) nope) | (funs,typ) <- fundefs', fun <- funs] + DefDef defs -> do + defs' <- liftM concat $ mapM getDefsGen defs + returnl [(c, G.AbsFun nope pe) | (c,(_,pe)) <- defs'] + DefData _ -> returnl [] ---- + DefTrans defs -> do + let (ids,vals) = unzip [(i,v) | FlagDef i v <- defs] + defs' <- liftM2 zip (mapM transIdent ids) (mapM transIdent vals) + returnl [(c, G.AbsTrans f) | (c,f) <- defs'] + DefFlag defs -> liftM Right $ mapM transFlagDef defs + _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x + +returnl :: a -> Err (Either a b) +returnl = return . Left + +transFlagDef :: FlagDef -> Err GO.Option +transFlagDef x = case x of + FlagDef f x -> return $ GO.Opt (prIdent f,[prIdent x]) + +transCatDef :: CatDef -> Err (Ident, G.Context) +transCatDef x = case x of + CatDef id ddecls -> liftM2 (,) (transIdent id) + (mapM transDDecl ddecls >>= return . concat) + +transFunDef :: FunDef -> Err ([Ident], G.Type) +transFunDef x = case x of + FunDef ids typ -> liftM2 (,) (mapM transIdent ids) (transExp typ) + +transResDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option]) +transResDef x = case x of + DefPar pardefs -> do + pardefs' <- mapM transParDef pardefs + returnl $ [(p, G.ResParam (if null pars + then nope -- abstract param type + else (yes pars))) | (p,pars) <- pardefs'] + ++ [(f, G.ResValue (yes (M.mkProdSimple co (G.Cn p)))) | + (p,pars) <- pardefs', (f,co) <- pars] + DefOper defs -> do + defs' <- liftM concat $ mapM getDefs defs + returnl [(f, G.ResOper pt pe) | (f,(pt,pe)) <- defs'] + + DefLintype defs -> do + defs' <- liftM concat $ mapM getDefs defs + returnl [(f, G.ResOper pt pe) | (f,(pt,pe)) <- defs'] + + DefFlag defs -> liftM Right $ mapM transFlagDef defs + _ -> Bad $ "illegal definition form in resource" +++ printTree x + +transParDef :: ParDef -> Err (Ident, [G.Param]) +transParDef x = case x of + ParDef id params -> liftM2 (,) (transIdent id) (mapM transParConstr params) + ParDefAbs id -> liftM2 (,) (transIdent id) (return []) + _ -> Bad $ "illegal definition in resource:" ++++ printTree x + +transCncDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option]) +transCncDef x = case x of + DefLincat defs -> do + defs' <- liftM concat $ mapM transPrintDef defs + returnl [(f, G.CncCat (yes t) nope nope) | (f,t) <- defs'] + DefLindef defs -> do + defs' <- liftM concat $ mapM getDefs defs + returnl [(f, G.CncCat pt pe nope) | (f,(pt,pe)) <- defs'] + DefLin defs -> do + defs' <- liftM concat $ mapM getDefs defs + returnl [(f, G.CncFun Nothing pe nope) | (f,(_,pe)) <- defs'] + DefPrintCat defs -> do + defs' <- liftM concat $ mapM transPrintDef defs + returnl [(f, G.CncCat nope nope (yes e)) | (f,e) <- defs'] + DefPrintFun defs -> do + defs' <- liftM concat $ mapM transPrintDef defs + returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] + DefPrintOld defs -> do -- a guess, for backward compatibility + defs' <- liftM concat $ mapM transPrintDef defs + returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] + DefFlag defs -> liftM Right $ mapM transFlagDef defs + DefPattern defs -> do + defs' <- liftM concat $ mapM getDefs defs + let defs2 = [(f, termInPattern t) | (f,(_,Yes t)) <- defs'] + returnl [(f, G.CncFun Nothing (yes t) nope) | (f,t) <- defs2] + + _ -> Bad $ "illegal definition in concrete syntax:" ++++ printTree x + +transPrintDef :: PrintDef -> Err [(Ident,G.Term)] +transPrintDef x = case x of + PrintDef id exp -> do + (ids,e) <- liftM2 (,) (mapM transIdent id) (transExp exp) + return $ [(i,e) | i <- ids] + +getDefsGen :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))] +getDefsGen d = case d of + DDecl ids t -> do + ids' <- mapM transIdent ids + t' <- transExp t + return [(i,(yes t', nope)) | i <- ids'] + DDef ids e -> do + ids' <- mapM transIdent ids + e' <- transExp e + return [(i,(nope, yes e')) | i <- ids'] + DFull ids t e -> do + ids' <- mapM transIdent ids + t' <- transExp t + e' <- transExp e + return [(i,(yes t', yes e')) | i <- ids'] + DPatt id patts e -> do + id' <- transIdent id + ps' <- mapM transPatt patts + e' <- transExp e + return [(id',(nope, yes (G.Eqs [(ps',e')])))] + +-- sometimes you need this special case, e.g. in linearization rules +getDefs :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))] +getDefs d = case d of + DPatt id patts e -> do + id' <- transIdent id + xs <- mapM tryMakeVar patts + e' <- transExp e + return [(id',(nope, yes (M.mkAbs xs e')))] + _ -> getDefsGen d + +-- accepts a pattern that is either a variable or a wild card +tryMakeVar :: Patt -> Err Ident +tryMakeVar p = do + p' <- transPatt p + case p' of + G.PV i -> return i + G.PW -> return identW + _ -> Bad $ "not a legal pattern in lambda binding" +++ GP.prt p' + +transExp :: Exp -> Err G.Term +transExp x = case x of + EIdent id -> liftM G.Vr $ transIdent id + EConstr id -> liftM G.Con $ transIdent id + ECons id -> liftM G.Cn $ transIdent id + EQConstr m c -> liftM2 G.QC (transIdent m) (transIdent c) + EQCons m c -> liftM2 G.Q (transIdent m) (transIdent c) + EString str -> return $ G.K str + ESort sort -> liftM G.Sort $ transSort sort + EInt n -> return $ G.EInt $ fromInteger n + EMeta -> return $ M.meta $ M.int2meta 0 + EEmpty -> return G.Empty + EStrings [] -> return G.Empty + EStrings str -> return $ foldr1 G.C $ map G.K $ words str + ERecord defs -> erecord2term defs + ETupTyp _ _ -> do + let tups t = case t of + ETupTyp x y -> tups x ++ [y] -- right-associative parsing + _ -> [t] + es <- mapM transExp $ tups x + return $ G.RecType $ M.tuple2recordType es + ETuple tuplecomps -> do + es <- mapM transExp [e | TComp e <- tuplecomps] + return $ G.R $ M.tuple2record es + EProj exp id -> liftM2 G.P (transExp exp) (trLabel id) + EApp exp0 exp -> liftM2 G.App (transExp exp0) (transExp exp) + ETable cases -> liftM (G.T G.TRaw) (transCases cases) + ETTable exp cases -> + liftM2 (\t c -> G.T (G.TTyped t) c) (transExp exp) (transCases cases) + ECase exp cases -> do + exp' <- transExp exp + cases' <- transCases cases + return $ G.S (G.T G.TRaw cases') exp' + ECTable binds exp -> liftM2 M.mkCTable (mapM transBind binds) (transExp exp) + + EVariants exps -> liftM G.FV $ mapM transExp exps + EPre exp alts -> liftM2 (curry G.Alts) (transExp exp) (mapM transAltern alts) + EStrs exps -> liftM G.Strs $ mapM transExp exps + ESelect exp0 exp -> liftM2 G.S (transExp exp0) (transExp exp) + EExtend exp0 exp -> liftM2 G.ExtR (transExp exp0) (transExp exp) + EAbstr binds exp -> liftM2 M.mkAbs (mapM transBind binds) (transExp exp) + ETyped exp0 exp -> liftM2 G.Typed (transExp exp0) (transExp exp) + + EProd decl exp -> liftM2 M.mkProdSimple (transDecl decl) (transExp exp) + ETType exp0 exp -> liftM2 G.Table (transExp exp0) (transExp exp) + EConcat exp0 exp -> liftM2 G.C (transExp exp0) (transExp exp) + EGlue exp0 exp -> liftM2 G.Glue (transExp exp0) (transExp exp) + ELet defs exp -> do + exp' <- transExp exp + defs0 <- mapM locdef2fields defs + defs' <- mapM tryLoc $ concat defs0 + return $ M.mkLet defs' exp' + where + tryLoc (c,(mty,Just e)) = return (c,(mty,e)) + tryLoc (c,_) = Bad $ "local definition of" +++ GP.prt c +++ "without value" + + ELString (LString str) -> return $ G.K str + ELin id -> liftM G.LiT $ transIdent id + + _ -> Bad $ "translation not yet defined for" +++ printTree x ---- + +--- this is complicated: should we change Exp or G.Term ? + +erecord2term :: [LocDef] -> Err G.Term +erecord2term ds = do + ds' <- mapM locdef2fields ds + mkR $ concat ds' + where + mkR fs = do + fs' <- transF fs + return $ case fs' of + Left ts -> G.RecType ts + Right ds -> G.R ds + transF [] = return $ Left [] --- empty record always interpreted as record type + transF fs@(f:_) = case f of + (lab,(Just ty,Nothing)) -> mapM tryRT fs >>= return . Left + _ -> mapM tryR fs >>= return . Right + tryRT f = case f of + (lab,(Just ty,Nothing)) -> return (M.ident2label lab,ty) + _ -> Bad $ "illegal record type field" +++ GP.prt (fst f) --- manifest fields ?! + tryR f = case f of + (lab,(mty, Just t)) -> return (M.ident2label lab,(mty,t)) + _ -> Bad $ "illegal record field" +++ GP.prt (fst f) + + +locdef2fields d = case d of + LDDecl ids t -> do + labs <- mapM transIdent ids + t' <- transExp t + return [(lab,(Just t',Nothing)) | lab <- labs] + LDDef ids e -> do + labs <- mapM transIdent ids + e' <- transExp e + return [(lab,(Nothing, Just e')) | lab <- labs] + LDFull ids t e -> do + labs <- mapM transIdent ids + t' <- transExp t + e' <- transExp e + return [(lab,(Just t', Just e')) | lab <- labs] + +trLabel :: Label -> Err G.Label +trLabel x = case x of + + -- this case is for bward compatibiity and should be removed + LIdent (IC ('v':ds)) | all isDigit ds -> return $ G.LVar $ readIntArg ds + + LIdent (IC s) -> return $ G.LIdent s + LVar x -> return $ G.LVar $ fromInteger x + +transSort :: Sort -> Err String +transSort x = case x of + _ -> return $ printTree x + +transPatt :: Patt -> Err G.Patt +transPatt x = case x of + PW -> return G.wildPatt + PV id -> liftM G.PV $ transIdent id + PC id patts -> liftM2 G.PC (transIdent id) (mapM transPatt patts) + PCon id -> liftM2 G.PC (transIdent id) (return []) + PInt n -> return $ G.PInt (fromInteger n) + PStr str -> return $ G.PString str + PR pattasss -> do + let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss] + ls = map LIdent $ concat lss + liftM G.PR $ liftM2 zip (mapM trLabel ls) (mapM transPatt ps) + PTup pcs -> + liftM (G.PR . M.tuple2recordPatt) (mapM transPatt [e | PTComp e <- pcs]) + PQ id0 id -> liftM3 G.PP (transIdent id0) (transIdent id) (return []) + PQC id0 id patts -> + liftM3 G.PP (transIdent id0) (transIdent id) (mapM transPatt patts) + +transBind :: Bind -> Err Ident +transBind x = case x of + BIdent id -> transIdent id + BWild -> return identW + +transDecl :: Decl -> Err [G.Decl] +transDecl x = case x of + DDec binds exp -> do + xs <- mapM transBind binds + exp' <- transExp exp + return [(x,exp') | x <- xs] + DExp exp -> liftM (return . M.mkDecl) $ transExp exp + +transCases :: [Case] -> Err [G.Case] +transCases = liftM concat . mapM transCase + +transCase :: Case -> Err [G.Case] +transCase (Case pattalts exp) = do + patts <- mapM transPatt [p | AltP p <- pattalts] + exp' <- transExp exp + return [(p,exp') | p <- patts] + +transAltern :: Altern -> Err (G.Term, G.Term) +transAltern x = case x of + Alt exp0 exp -> liftM2 (,) (transExp exp0) (transExp exp) + +transParConstr :: ParConstr -> Err G.Param +transParConstr x = case x of + ParConstr id ddecls -> do + id' <- transIdent id + ddecls' <- mapM transDDecl ddecls + return (id',concat ddecls') + +transDDecl :: DDecl -> Err [G.Decl] +transDDecl x = case x of + DDDec binds exp -> transDecl $ DDec binds exp + DDExp exp -> transDecl $ DExp exp + +-- to deal with the old format, sort judgements in three modules, forming +-- their names from a given string, e.g. file name or overriding user-given string + +transOldGrammar :: OldGrammar -> String -> Err G.SourceGrammar +transOldGrammar x name = case x of + OldGr includes topdefs -> do --- includes must be collected separately + let moddefs = sortTopDefs topdefs + g1 <- transGrammar $ Gr moddefs + removeLiT g1 --- needed for bw compatibility with an obsolete feature + where + sortTopDefs ds = [mkAbs a,mkRes r,mkCnc c] + where (a,r,c) = foldr srt ([],[],[]) ds + srt d (a,r,c) = case d of + DefCat catdefs -> (d:a,r,c) + DefFun fundefs -> (d:a,r,c) + DefDef defs -> (d:a,r,c) + DefData pardefs -> (d:a,r,c) + DefPar pardefs -> (a,d:r,c) + DefOper defs -> (a,d:r,c) + DefLintype defs -> (a,d:r,c) + DefLincat defs -> (a,r,d:c) + DefLindef defs -> (a,r,d:c) + DefLin defs -> (a,r,d:c) + DefPattern defs -> (a,r,d:c) + DefFlag defs -> (a,r,d:c) --- a guess + DefPrintCat printdefs -> (a,r,d:c) + DefPrintFun printdefs -> (a,r,d:c) + DefPrintOld printdefs -> (a,r,d:c) + mkAbs a = MAbstract absName NoExt (Opens []) $ topDefs a + mkRes r = MResource resName NoExt (Opens []) $ topDefs r + mkCnc r = MConcrete cncName absName NoExt (Opens [OName resName]) $ topDefs r + topDefs t = t + + absName = identC topic + resName = identC ("Res" ++ lang) + cncName = identC lang + + (beg,rest) = span (/='.') name + (topic,lang) = case rest of -- to avoid overwriting old files + ".gf" -> ("Abs" ++ beg,"Cnc" ++ beg) + [] -> ("Abs" ++ beg,"Cnc" ++ beg) + _:s -> (beg, takeWhile (/='.') s) + +transInclude :: Include -> Err [FilePath] +transInclude x = case x of + NoIncl -> return [] + Incl filenames -> return $ map trans filenames + where + trans f = case f of + FString s -> s + FIdent (IC s) -> s + FSlash filename -> '/' : trans filename + FDot filename -> '.' : trans filename + FMinus filename -> '-' : trans filename + FAddId (IC s) filename -> s ++ trans filename + +termInPattern :: G.Term -> G.Term +termInPattern t = M.mkAbs xx $ G.R [(s, (Nothing, toP body))] where + toP t = case t of + G.Vr x -> G.P t s + _ -> M.composSafeOp toP t + s = G.LIdent "s" + (xx,body) = abss [] t + abss xs t = case t of + G.Abs x b -> abss (x:xs) b + _ -> (reverse xs,t) diff --git a/src/GF/Source/TestGF.hs b/src/GF/Source/TestGF.hs new file mode 100644 index 000000000..f1c8e49a1 --- /dev/null +++ b/src/GF/Source/TestGF.hs @@ -0,0 +1,22 @@ +-- automatically generated by BNF Converter +module TestGF where + +import LexGF +import ParGF +import SkelGF +import PrintGF +import AbsGF +import ErrM + +type ParseFun a = [Token] -> Err a + +runFile :: (Print a, Show a) => ParseFun a -> FilePath -> IO() +runFile p f = readFile f >>= run p + +run :: (Print a, Show a) => ParseFun a -> String -> IO() +run p s = case (p (myLexer s)) of + Bad s -> do putStrLn "\nParse Failed...\n" + putStrLn s + Ok tree -> do putStrLn "\nParse Successful!" + putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree + putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree diff --git a/src/GF/System/Arch.hs b/src/GF/System/Arch.hs new file mode 100644 index 000000000..5fb963fec --- /dev/null +++ b/src/GF/System/Arch.hs @@ -0,0 +1,71 @@ +module Arch ( + myStdGen, prCPU, selectLater, modifiedFiles, ModTime, getModTime,getNowTime, + welcomeArch, fetchCommand) where + +import Time +import Random +import CPUTime +import Monad (filterM) +import Directory +import Readline + +---- import qualified UnicodeF as U --(fudlogueWrite) + +-- architecture/compiler dependent definitions for unix/hbc + +myStdGen :: Int -> IO StdGen --- +--- myStdGen _ = newStdGen --- gives always the same result +myStdGen int0 = do + t0 <- getClockTime + cal <- toCalendarTime t0 + let int = int0 + ctSec cal + fromInteger (div (ctPicosec cal) 10000000) + return $ mkStdGen int + +prCPU cpu = do + cpu' <- getCPUTime + putStrLn (show ((cpu' - cpu) `div` 1000000000) ++ " msec") + return cpu' + +welcomeArch = "This is the system compiled with ghc." + +fetchCommand :: String -> IO (String) +fetchCommand s = do + res <- readline s + case res of + Nothing -> return "q" + Just s -> do addHistory s + return s + +-- selects the one with the later modification time of two + +selectLater :: FilePath -> FilePath -> IO FilePath +selectLater x y = do + ex <- doesFileExist x + if not ex + then return y --- which may not exist + else do + ey <- doesFileExist y + if not ey + then return x + else do + tx <- getModificationTime x + ty <- getModificationTime y + return $ if tx < ty then y else x + +-- a file is considered as modified also if it has not been read yet + +modifiedFiles :: [(FilePath,ModTime)] -> [FilePath] -> IO [FilePath] +modifiedFiles ofs fs = print (map fst ofs) >> filterM isModified fs where + isModified file = case lookup file ofs of + Just to -> do + t <- getModTime file + return $ to < t + _ -> return True + +type ModTime = ClockTime + +getModTime :: FilePath -> IO ModTime +getModTime = getModificationTime + +getNowTime :: IO ModTime +getNowTime = getClockTime diff --git a/src/GF/Text/Arabic.hs b/src/GF/Text/Arabic.hs new file mode 100644 index 000000000..6df79c4a9 --- /dev/null +++ b/src/GF/Text/Arabic.hs @@ -0,0 +1,48 @@ +module Arabic where + +mkArabic :: String -> String +mkArabic = reverse . unwords . (map mkArabicWord) . words +--- reverse : assumes everything's on same line + +type ArabicChar = Char + +mkArabicWord :: String -> [ArabicChar] +mkArabicWord = map mkArabicChar . getLetterPos + +getLetterPos :: String -> [(Char,Int)] +getLetterPos [] = [] +getLetterPos ('I':cs) = ('*',7) : getLetterPos cs -- 0xfe80 +getLetterPos ('O':cs) = ('*',8) : getIn cs -- 0xfe8b +getLetterPos ('l':'a':cs) = ('*',5) : getLetterPos cs -- 0xfefb +getLetterPos [c] = [(c,1)] -- 1=isolated +getLetterPos (c:cs) | isReduced c = (c,1) : getLetterPos cs +getLetterPos (c:cs) = (c,3) : getIn cs -- 3=initial + + +getIn [] = [] +getIn ('I':cs) = ('*',7) : getLetterPos cs -- 0xfe80 +getIn ('O':cs) = ('*',9) : getIn cs -- 0xfe8c +getIn ('l':'a':cs) = ('*',6) : getLetterPos cs -- 0xfefc +getIn [c] = [(c,2)] -- 2=final +getIn (c:cs) | isReduced c = (c,2) : getLetterPos cs +getIn (c:cs) = (c,4) : getIn cs -- 4=medial + +isReduced :: Char -> Bool +isReduced c = c `elem` "UuWiYOaAdVrzwj" + +mkArabicChar ('*',p) | p > 4 && p < 10 = + (map toEnum [0xfefb,0xfefc,0xfe80,0xfe8b,0xfe8c]) !! (p-5) +mkArabicChar cp@(c,p) = case lookup c cc of Just c' -> (c' !! (p-1)) ; _ -> c + where + cc = mkArabicTab allArabicCodes allArabic + +mkArabicTab (c:cs) as = (c,as1) : mkArabicTab cs as2 where + (as1,as2) = if isReduced c then splitAt 2 as else splitAt 4 as +mkArabicTab [] _ = [] + +allArabicCodes = "UuWiYOabAtvgHCdVrzscSDTZoxfqklmnhwjy" + +allArabic :: String +allArabic = (map toEnum [0xfe81 .. 0xfef4]) -- I=0xfe80 + + diff --git a/src/GF/Text/Greek.hs b/src/GF/Text/Greek.hs new file mode 100644 index 000000000..8cbba8c54 --- /dev/null +++ b/src/GF/Text/Greek.hs @@ -0,0 +1,158 @@ +module Greek where + +mkGreek :: String -> String +mkGreek = unwords . (map mkGreekWord) . mkGravis . words + +--- TODO : optimize character formation by factorizing the case expressions + +type GreekChar = Char + +mkGreekWord :: String -> [GreekChar] +mkGreekWord = map (toEnum . mkGreekChar) . mkGreekSpec + +mkGravis :: [String] -> [String] +mkGravis [] = [] +mkGravis [w] = [w] +mkGravis (w1:w2:ws) + | stressed w2 = mkG w1 : mkGravis (w2:ws) + | otherwise = w1 : w2 : mkGravis ws + where + stressed w = any (`elem` "'~`") w + mkG :: String -> String + mkG w = let (w1,w2) = span (/='\'') w in + case w2 of + '\'':v:cs | not (any isVowel cs) -> w1 ++ "`" ++ [v] ++ cs + '\'':'!':v:cs | not (any isVowel cs) -> w1 ++ "`!" ++ [v] ++ cs + _ -> w + isVowel c = elem c "aehiouw" + +mkGreekSpec :: String -> [(Char,Int)] +mkGreekSpec str = case str of + [] -> [] + '(' :'\'': '!' : c : cs -> (c,25) : mkGreekSpec cs + '(' :'~' : '!' : c : cs -> (c,27) : mkGreekSpec cs + '(' :'`' : '!' : c : cs -> (c,23) : mkGreekSpec cs + '(' : '!' : c : cs -> (c,21) : mkGreekSpec cs + ')' :'\'': '!' : c : cs -> (c,24) : mkGreekSpec cs + ')' :'~' : '!' : c : cs -> (c,26) : mkGreekSpec cs + ')' :'`' : '!' : c : cs -> (c,22) : mkGreekSpec cs + ')' : '!' : c : cs -> (c,20) : mkGreekSpec cs + '\'': '!' : c : cs -> (c,30) : mkGreekSpec cs + '~' : '!' : c : cs -> (c,31) : mkGreekSpec cs + '`' : '!' : c : cs -> (c,32) : mkGreekSpec cs + '!' : c : cs -> (c,33) : mkGreekSpec cs + '(' :'\'': c : cs -> (c,5) : mkGreekSpec cs + '(' :'~' : c : cs -> (c,7) : mkGreekSpec cs + '(' :'`' : c : cs -> (c,3) : mkGreekSpec cs + '(' : c : cs -> (c,1) : mkGreekSpec cs + ')' :'\'': c : cs -> (c,4) : mkGreekSpec cs + ')' :'~' : c : cs -> (c,6) : mkGreekSpec cs + ')' :'`' : c : cs -> (c,2) : mkGreekSpec cs + ')' : c : cs -> (c,0) : mkGreekSpec cs + '\'': c : cs -> (c,10) : mkGreekSpec cs + '~' : c : cs -> (c,11) : mkGreekSpec cs + '`' : c : cs -> (c,12) : mkGreekSpec cs + c : cs -> (c,-1) : mkGreekSpec cs + +mkGreekChar (c,-1) = case lookup c cc of Just c' -> c' ; _ -> fromEnum c + where + cc = zip "abgdezhqiklmnxoprjstyfcuw" allGreekMin +mkGreekChar (c,n) = case (c,n) of + ('a',10) -> 0x03ac + ('a',11) -> 0x1fb6 + ('a',12) -> 0x1f70 + ('a',30) -> 0x1fb4 + ('a',31) -> 0x1fb7 + ('a',32) -> 0x1fb2 + ('a',33) -> 0x1fb3 + ('a',n) | n >19 -> 0x1f80 + n - 20 + ('a',n) -> 0x1f00 + n + ('e',10) -> 0x03ad -- ' +-- ('e',11) -> 0x1fb6 -- ~ can't happen + ('e',12) -> 0x1f72 -- ` + ('e',n) -> 0x1f10 + n + ('h',10) -> 0x03ae -- ' + ('h',11) -> 0x1fc6 -- ~ + ('h',12) -> 0x1f74 -- ` + + ('h',30) -> 0x1fc4 + ('h',31) -> 0x1fc7 + ('h',32) -> 0x1fc2 + ('h',33) -> 0x1fc3 + ('h',n) | n >19 -> 0x1f90 + n - 20 + + ('h',n) -> 0x1f20 + n + ('i',10) -> 0x03af -- ' + ('i',11) -> 0x1fd6 -- ~ + ('i',12) -> 0x1f76 -- ` + ('i',n) -> 0x1f30 + n + ('o',10) -> 0x03cc -- ' +-- ('o',11) -> 0x1fb6 -- ~ can't happen + ('o',12) -> 0x1f78 -- ` + ('o',n) -> 0x1f40 + n + ('y',10) -> 0x03cd -- ' + ('y',11) -> 0x1fe6 -- ~ + ('y',12) -> 0x1f7a -- ` + ('y',n) -> 0x1f50 + n + ('w',10) -> 0x03ce -- ' + ('w',11) -> 0x1ff6 -- ~ + ('w',12) -> 0x1f7c -- ` + + ('w',30) -> 0x1ff4 + ('w',31) -> 0x1ff7 + ('w',32) -> 0x1ff2 + ('w',33) -> 0x1ff3 + ('w',n) | n >19 -> 0x1fa0 + n - 20 + + ('w',n) -> 0x1f60 + n + ('r',1) -> 0x1fe5 + _ -> mkGreekChar (c,-1) --- should not happen + +allGreekMin :: [Int] +allGreekMin = [0x03b1 .. 0x03c9] + + +{- +encoding of Greek writing. Those hard to guess are marked with --- + + maj min +A a Alpha 0391 03b1 +B b Beta 0392 03b2 +G g Gamma 0393 03b3 +D d Delta 0394 03b4 +E e Epsilon 0395 03b5 +Z z Zeta 0396 03b6 +H h Eta --- 0397 03b7 +Q q Theta --- 0398 03b8 +I i Iota 0399 03b9 +K k Kappa 039a 03ba +L l Lambda 039b 03bb +M m My 039c 03bc +N n Ny 039d 03bd +X x Xi 039e 03be +O o Omikron 039f 03bf +P p Pi 03a0 03c0 +R r Rho 03a1 03c1 + j Sigma --- 03c2 +S s Sigma 03a3 03c3 +T t Tau 03a4 03c4 +Y y Ypsilon 03a5 03c5 +F f Phi 03a6 03c6 +C c Khi --- 03a7 03c7 +U u Psi 03a8 03c8 +W w Omega --- 03a9 03c9 + +( spiritus asper +) spiritus lenis +! iota subscriptum + +' acutus +~ circumflexus +` gravis + +-} + + + + + diff --git a/src/GF/Text/Hebrew.hs b/src/GF/Text/Hebrew.hs new file mode 100644 index 000000000..ebcc078e3 --- /dev/null +++ b/src/GF/Text/Hebrew.hs @@ -0,0 +1,21 @@ +module Hebrew where + +mkHebrew :: String -> String +mkHebrew = reverse . unwords . (map mkHebrewWord) . words +--- reverse : assumes everything's on same line + +type HebrewChar = Char + +mkHebrewWord :: String -> [HebrewChar] +mkHebrewWord = map mkHebrewChar + +mkHebrewChar c = case lookup c cc of Just c' -> c' ; _ -> c + where + cc = zip allHebrewCodes allHebrew + +allHebrewCodes = "-abgdhwzHTyKklMmNnSoPpCcqrst" + +allHebrew :: String +allHebrew = (map toEnum (0x05be : [0x05d0 .. 0x05ea])) + + diff --git a/src/GF/Text/Russian.hs b/src/GF/Text/Russian.hs new file mode 100644 index 000000000..07605a83a --- /dev/null +++ b/src/GF/Text/Russian.hs @@ -0,0 +1,31 @@ +module Russian where + +-- an ad hoc ASCII encoding. Delimiters: /_ _/ +mkRussian :: String -> String +mkRussian = unwords . (map mkRussianWord) . words + +-- the KOI8 encoding, incomplete. Delimiters: /* */ +mkRusKOI8 :: String -> String +mkRusKOI8 = unwords . (map mkRussianKOI8) . words + +type RussianChar = Char + +mkRussianWord :: String -> [RussianChar] +mkRussianWord = map (mkRussianChar allRussianCodes) + +mkRussianKOI8 :: String -> [RussianChar] +mkRussianKOI8 = map (mkRussianChar allRussianKOI8) + +mkRussianChar chars c = case lookup c cc of Just c' -> c' ; _ -> c + where + cc = zip chars allRussian + +allRussianCodes = + "ÅåABVGDEXZIJKLMNOPRSTUFHCQW£}!*ÖYÄabvgdexzijklmnoprstufhcqw#01'öyä" +allRussianKOI8 = + "^@áâ÷çäåöúéêëìíîïðòóôõæèãþûýøùÿüàñÁÂ×ÇÄÅÖÚÉÊËÌÍÎÏÐÒÓÔÕÆÈÃÞÛÝØÙßÜÀÑ" + +allRussian :: String +allRussian = (map toEnum (0x0401:0x0451:[0x0410 .. 0x044f])) -- Ëë in odd places + + diff --git a/src/GF/Text/Text.hs b/src/GF/Text/Text.hs new file mode 100644 index 000000000..08e897a9b --- /dev/null +++ b/src/GF/Text/Text.hs @@ -0,0 +1,56 @@ +module Text where + +import Operations +import Char + +-- elementary text postprocessing. AR 21/11/2001 +-- This is very primitive indeed. The functions should work on +-- token lists and not on strings. AR 5/12/2002 + + +formatAsTextLit :: String -> String +formatAsTextLit = formatAsText . unwords . map unStringLit . words +--- hope that there will be deforestation... + +formatAsCodeLit :: String -> String +formatAsCodeLit = formatAsCode . unwords . map unStringLit . words + +formatAsText :: String -> String +formatAsText = unwords . format . cap . words where + format ws = case ws of + w : c : ww | major c -> (w ++ c) : format (cap ww) + w : c : ww | minor c -> (w ++ c) : format ww + c : ww | para c -> "\n\n" : format ww + w : ww -> w : format ww + [] -> [] + cap (p:(c:cs):ww) | para p = p : (toUpper c : cs) : ww + cap ((c:cs):ww) = (toUpper c : cs) : ww + cap [] = [] + major = flip elem (map singleton ".!?") + minor = flip elem (map singleton ",:;") + para = (=="

") + +formatAsCode :: String -> String +formatAsCode = unwords . format . words where + format ws = case ws of + p : w : ww | parB p -> format ((p ++ w') : ww') where (w':ww') = format (w:ww) + w : p : ww | par p -> format ((w ++ p') : ww') where (p':ww') = format (p:ww) + w : ww -> w : format ww + [] -> [] + parB = flip elem (map singleton "([{") + parE = flip elem (map singleton "}])") + par t = parB t || parE t + +performBinds :: String -> String +performBinds = unwords . format . words where + format ws = case ws of + w : "&+" : u : ws -> format ((w ++ u) : ws) + w : ws -> w : format ws + [] -> [] + +unStringLit :: String -> String +unStringLit s = case s of + c : cs | strlim c && strlim (last cs) -> init cs + _ -> s + where + strlim = (=='\'') diff --git a/src/GF/Text/UTF8.hs b/src/GF/Text/UTF8.hs new file mode 100644 index 000000000..57b711b4b --- /dev/null +++ b/src/GF/Text/UTF8.hs @@ -0,0 +1,35 @@ +module UTF8 where + +-- From the Char module supplied with HBC. +-- code by Thomas Hallgren (Jul 10 1999) + +-- 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 _ = error "UniChar.decodeUTF8: bad data" + +encodeUTF8 :: String -> String +encodeUTF8 "" = "" +encodeUTF8 (c:cs) = + if c > '\x0000' && c < '\x0080' then + c : encodeUTF8 cs + else if c < toEnum 0x0800 then + let i = fromEnum c + in toEnum (0xc0 + i `div` 0x40) : + toEnum (0x80 + i `mod` 0x40) : + encodeUTF8 cs + else + let i = fromEnum c + in toEnum (0xe0 + i `div` 0x1000) : + toEnum (0x80 + (i `mod` 0x1000) `div` 0x40) : + toEnum (0x80 + i `mod` 0x40) : + encodeUTF8 cs diff --git a/src/GF/Text/Unicode.hs b/src/GF/Text/Unicode.hs new file mode 100644 index 000000000..78aba0461 --- /dev/null +++ b/src/GF/Text/Unicode.hs @@ -0,0 +1,24 @@ +module Unicode where + +import Greek (mkGreek) +import Arabic (mkArabic) +import Hebrew (mkHebrew) +import Russian (mkRussian, mkRusKOI8) + +-- ad hoc Unicode conversions from different alphabets + +-- AR 12/4/2000, 18/9/2001, 30/5/2002 + +mkUnicode s = case s of + '/':'/':cs -> mkGreek (remClosing cs) + '/':'+':cs -> mkHebrew (remClosing cs) + '/':'-':cs -> mkArabic (remClosing cs) + '/':'_':cs -> mkRussian (remClosing cs) + '/':'*':cs -> mkRusKOI8 (remClosing cs) + _ -> s + +remClosing cs + | lcs > 1 && last cs == '/' = take (lcs-2) cs + | otherwise = cs + where lcs = length cs + diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs new file mode 100644 index 000000000..bf84d776b --- /dev/null +++ b/src/GF/UseGrammar/Custom.hs @@ -0,0 +1,256 @@ +module Custom where + +import Operations +import Text +import Tokenize +import qualified Grammar as G +import qualified AbsGFC as A +import qualified GFC as C +import qualified AbsGF as GF +import qualified MMacros as MM +import AbsCompute +import TypeCheck +------import Compile +import ShellState +import Editing +import Paraphrases +import Option +import CF +import CFIdent + +---- import CFtoGrammar +import PPrCF +import PrGrammar + +----import Morphology +-----import GrammarToHaskell +-----import GrammarToCanon (showCanon, showCanonOpt) +-----import qualified GrammarToGFC as GFC + +-- the cf parsing algorithms +import ChartParser -- or some other CF Parser + +import MoreCustom -- either small/ or big/. The one in Small is empty. + +import UseIO + +-- minimal version also used in Hugs. AR 2/12/2002. + +-- databases for customizable commands. AR 21/11/2001 +-- for: grammar parsers, grammar printers, term commands, string commands +-- idea: items added here are usable throughout GF; nothing else need be edited +-- they are often usable through the API: hence API cannot be imported here! + +-- Major redesign 3/4/2002: the first entry in each database is DEFAULT. +-- If no other value is given, the default is selected. +-- Because of this, two invariants have to be preserved: +-- ** no databases may be empty +-- ** additions are made to the end of the database + +-- these are the databases; the comment gives the name of the flag + +-- grammarFormat, "-format=x" or file suffix +customGrammarParser :: CustomData (FilePath -> IOE C.CanonGrammar) + +-- grammarPrinter, "-printer=x" +customGrammarPrinter :: CustomData (StateGrammar -> String) + +-- syntaxPrinter, "-printer=x" +customSyntaxPrinter :: CustomData (GF.Grammar -> String) + +-- termPrinter, "-printer=x" +customTermPrinter :: CustomData (StateGrammar -> A.Exp -> String) + +-- termCommand, "-transform=x" +customTermCommand :: CustomData (StateGrammar -> A.Exp -> [A.Exp]) + +-- editCommand, "-edit=x" +customEditCommand :: CustomData (StateGrammar -> Action) + +-- filterString, "-filter=x" +customStringCommand :: CustomData (StateGrammar -> String -> String) + +-- useParser, "-parser=x" +customParser :: CustomData (StateGrammar -> CFCat -> CFParser) + +-- useTokenizer, "-lexer=x" +customTokenizer :: CustomData (StateGrammar -> String -> [CFTok]) + +-- useUntokenizer, "-unlexer=x" --- should be from token list to string +customUntokenizer :: CustomData (StateGrammar -> String -> String) + + +-- this is the way of selecting an item +customOrDefault :: Options -> OptFun -> CustomData a -> a +customOrDefault opts optfun db = maybe (defaultCustomVal db) id $ + customAsOptVal opts optfun db + +-- to produce menus of custom operations +customInfo :: CustomData a -> (String, [String]) +customInfo c = (titleCustomData c, map (ciStr . fst) (dbCustomData c)) + +------------------------------- + +type CommandId = String + +strCI :: String -> CommandId +strCI = id + +ciStr :: CommandId -> String +ciStr = id + +ciOpt :: CommandId -> Option +ciOpt = iOpt + +newtype CustomData a = CustomData (String, [(CommandId,a)]) +customData title db = CustomData (title,db) +dbCustomData (CustomData (_,db)) = db +titleCustomData (CustomData (t,_)) = t + +lookupCustom :: CustomData a -> CommandId -> Maybe a +lookupCustom = flip lookup . dbCustomData + +customAsOptVal :: Options -> OptFun -> CustomData a -> Maybe a +customAsOptVal opts optfun db = do + arg <- getOptVal opts optfun + lookupCustom db (strCI arg) + +-- take the first entry from the database +defaultCustomVal :: CustomData a -> a +defaultCustomVal (CustomData (s,db)) = + ifNull (error ("empty database:" +++ s)) (snd . head) db + +------------------------------------------------------------------------- +-- and here's the customizable part: + +-- grammar parsers: the ID is also used as file name suffix +customGrammarParser = + customData "Grammar parsers, selected by file name suffix" $ + [ +------ (strCI "gf", compileModule noOptions) -- DEFAULT +-- add your own grammar parsers here + ] + ++ moreCustomGrammarParser + + +customGrammarPrinter = + customData "Grammar printers, selected by option -printer=x" $ + [ +---- (strCI "gf", prt) -- DEFAULT + (strCI "cf", prCF . stateCF) + +{- ---- + (strCI "gf", prt . st2grammar . stateGrammarST) -- DEFAULT + ,(strCI "canon", showCanon "Lang" . stateGrammarST) + ,(strCI "gfc", GFC.showGFC . stateGrammarST) + ,(strCI "canonOpt",showCanonOpt "Lang" . stateGrammarST) + ,(strCI "morpho", prMorpho . stateMorpho) + ,(strCI "opts", prOpts . stateOptions) +-} +-- add your own grammar printers here +--- also include printing via grammar2syntax! + ] + ++ moreCustomGrammarPrinter + +customSyntaxPrinter = + customData "Syntax printers, selected by option -printer=x" $ + [ +-- add your own grammar printers here + ] + ++ moreCustomSyntaxPrinter + + +customTermPrinter = + customData "Term printers, selected by option -printer=x" $ + [ + (strCI "gf", const prt) -- DEFAULT +-- add your own term printers here + ] + ++ moreCustomTermPrinter + +customTermCommand = + customData "Term transformers, selected by option -transform=x" $ + [ + (strCI "identity", \_ t -> [t]) -- DEFAULT +{- ---- + ,(strCI "compute", \g t -> err (const [t]) return (computeAbsTerm g t)) + ,(strCI "paraphrase", \g t -> mkParaphrases g t) + ,(strCI "typecheck", \g t -> err (const []) return (checkIfValidExp g t)) + ,(strCI "solve", \g t -> editAsTermCommand g + (uniqueRefinements g) t) + ,(strCI "context", \g t -> editAsTermCommand g + (contextRefinements g) t) +-} +--- ,(strCI "delete", \g t -> [MM.mExp0]) +-- add your own term commands here + ] + ++ moreCustomTermCommand + +customEditCommand = + customData "Editor state transformers, selected by option -edit=x" $ + [ + (strCI "identity", const return) -- DEFAULT + ,(strCI "transfer", const return) --- done ad hoc on top level +{- ---- + ,(strCI "typecheck", reCheckState) + ,(strCI "solve", solveAll) + ,(strCI "context", contextRefinements) + ,(strCI "compute", computeSubTree) +-} + ,(strCI "paraphrase", const return) --- done ad hoc on top level +-- add your own edit commands here + ] + ++ moreCustomEditCommand + +customStringCommand = + customData "String filters, selected by option -filter=x" $ + [ + (strCI "identity", const $ id) -- DEFAULT + ,(strCI "erase", const $ const "") + ,(strCI "take100", const $ take 100) + ,(strCI "text", const $ formatAsText) + ,(strCI "code", const $ formatAsCode) +---- ,(strCI "latexfile", const $ mkLatexFile) + ,(strCI "length", const $ show . length) +-- add your own string commands here + ] + ++ moreCustomStringCommand + +customParser = + customData "Parsers, selected by option -parser=x" $ + [ + (strCI "chart", chartParser . stateCF) +-- add your own parsers here + ] + ++ moreCustomParser + +customTokenizer = + customData "Tokenizers, selected by option -lexer=x" $ + [ + (strCI "words", const $ tokWords) + ,(strCI "literals", const $ tokLits) + ,(strCI "vars", const $ tokVars) + ,(strCI "chars", const $ map (tS . singleton)) + ,(strCI "code", const $ lexHaskell) + ,(strCI "text", const $ lexText) +---- ,(strCI "codelit", lexHaskellLiteral . stateIsWord) +---- ,(strCI "textlit", lexTextLiteral . stateIsWord) + ,(strCI "codeC", const $ lexC2M) + ,(strCI "codeCHigh", const $ lexC2M' True) +-- add your own tokenizers here + ] + ++ moreCustomTokenizer + +customUntokenizer = + customData "Untokenizers, selected by option -unlexer=x" $ + [ + (strCI "unwords", const $ id) -- DEFAULT + ,(strCI "text", const $ formatAsText) + ,(strCI "code", const $ formatAsCode) + ,(strCI "textlit", const $ formatAsTextLit) + ,(strCI "codelit", const $ formatAsCodeLit) + ,(strCI "concat", const $ concat . words) + ,(strCI "bind", const $ performBinds) +-- add your own untokenizers here + ] + ++ moreCustomUntokenizer diff --git a/src/GF/UseGrammar/Editing.hs b/src/GF/UseGrammar/Editing.hs new file mode 100644 index 000000000..616ddc7cc --- /dev/null +++ b/src/GF/UseGrammar/Editing.hs @@ -0,0 +1,358 @@ +module Editing where + +import Abstract +import qualified GFC +import TypeCheck +import LookAbs +import AbsCompute + +import Operations +import Zipper + +-- generic tree editing, with some grammar notions assumed. AR 18/8/2001 +-- 19/6/2003 for GFC + +type CGrammar = GFC.CanonGrammar + +type State = Loc TrNode + +-- the "empty" state +initState :: State +initState = tree2loc uTree + +isRootState :: State -> Bool +isRootState s = case actPath s of + Top -> True + _ -> False + +actTree :: State -> Tree +actTree (Loc (t,_)) = t + +actPath :: State -> Path TrNode +actPath (Loc (_,p)) = p + +actVal :: State -> Val +actVal = valNode . nodeTree . actTree + +actCat :: State -> Cat +actCat = errVal undefined . val2cat . actVal ---- undef + +actAtom :: State -> Atom +actAtom = atomTree . actTree + +actExp = tree2exp . actTree + +-- current local bindings +actBinds :: State -> Binds +actBinds = bindsNode . nodeTree . actTree + +-- constraints in current subtree +actConstrs :: State -> Constraints +actConstrs = allConstrsTree . actTree + +-- constraints in the whole tree +allConstrs :: State -> Constraints +allConstrs = allConstrsTree . loc2tree + +-- metas in current subtree +actMetas :: State -> [Meta] +actMetas = metasTree . actTree + +-- metas in the whole tree +allMetas :: State -> [Meta] +allMetas = metasTree . loc2tree + +actTreeBody :: State -> Tree +actTreeBody = bodyTree . actTree + +allPrevBinds :: State -> Binds +allPrevBinds = concatMap bindsNode . traverseCollect . actPath + +allBinds :: State -> Binds +allBinds s = actBinds s ++ allPrevBinds s + +actGen :: State -> Int +actGen = length . allBinds -- symbol generator for VGen + +allPrevVars :: State -> [Var] +allPrevVars = map fst . allPrevBinds + +allVars :: State -> [Var] +allVars = map fst . allBinds + +vGenIndex = length . allBinds + +actIsMeta = atomIsMeta . actAtom + +actMeta :: State -> Err Meta +actMeta = getMetaAtom . actAtom + +-- meta substs are not only on the actual path... +entireMetaSubst :: State -> MetaSubst +entireMetaSubst = concatMap metaSubstsNode . scanTree . loc2tree + +isCompleteTree = null . filter atomIsMeta . map atomNode . scanTree +isCompleteState = isCompleteTree . loc2tree + +initStateCat :: Context -> Cat -> Err State +initStateCat cont cat = do + return $ tree2loc (Tr (mkNode [] mAtom (cat2val cont cat) ([],[]), [])) + +-- this function only concerns the body of an expression... +annotateInState :: CGrammar -> Exp -> State -> Err Tree +annotateInState gr exp state = do + let binds = allBinds state + val = actVal state + annotateIn gr binds exp (Just val) + +-- ...whereas this one works with lambda abstractions +annotateExpInState :: CGrammar -> Exp -> State -> Err Tree +annotateExpInState gr exp state = do + let cont = allPrevBinds state + binds = actBinds state + val = actVal state + typ <- mkProdVal binds val + annotateIn gr binds exp (Just typ) + +treeByExp :: (Exp -> Err Exp) -> CGrammar -> Exp -> State -> Err Tree +treeByExp trans gr exp0 state = do + exp <- trans exp0 + annotateExpInState gr exp state + +-- actions + +type Action = State -> Err State + +newCat :: CGrammar -> Cat -> Action +newCat gr cat@(m,c) _ = do + cont <- lookupCatContext gr m c + testErr (null cont) "start cat must have null context" -- for easier meta refresh + initStateCat cont cat + +newTree :: Tree -> Action +newTree t _ = return $ tree2loc t + +newExpTC :: CGrammar -> Exp -> Action +newExpTC gr t s = annotate gr (refreshMetas [] t) >>= flip newTree s + +goNextMeta, goPrevMeta, goNextNewMeta, goPrevNewMeta, goNextMetaIfCan :: Action + +goNextMeta = repeatUntilErr actIsMeta goAhead -- can be the location itself +goPrevMeta = repeatUntilErr actIsMeta goBack + +goNextNewMeta s = goAhead s >>= goNextMeta -- always goes away from location +goPrevNewMeta s = goBack s >>= goPrevMeta + +goNextMetaIfCan = actionIfPossible goNextMeta + +actionIfPossible a s = return $ errVal s (a s) + +goFirstMeta, goLastMeta :: Action +goFirstMeta s = goNextMeta $ goRoot s +goLastMeta s = goLast s >>= goPrevMeta + +noMoreMetas :: State -> Bool +noMoreMetas = err (const True) (const False) . goNextMeta + +replaceSubTree :: Tree -> Action +replaceSubTree tree state = changeLoc state tree + +refineWithTree :: Bool -> CGrammar -> Tree -> Action +refineWithTree der gr tree state = do + m <- errIn "move pointer to meta" $ actMeta state + state' <- replaceSubTree tree state + let cs0 = allConstrs state' + (cs,ms) = splitConstraints cs0 + v = vClos $ tree2exp (bodyTree tree) + msubst = (m,v) : ms + metaSubstRefinements gr msubst $ mapLoc (performMetaSubstNode msubst) state' + + -- without dep. types, no constraints, no grammar needed - simply: do + -- testErr (actIsMeta state) "move pointer to meta" + -- replaceSubTree tree state + +refineAllNodes :: Action -> Action +refineAllNodes act state = do + let estate0 = goFirstMeta state + case estate0 of + Bad _ -> return state + Ok state0 -> do + (state',n) <- tryRefine 0 state0 + if n==0 + then return state + else actionIfPossible goFirstMeta state' + where + tryRefine n state = err (const $ return (state,n)) return $ do + state' <- goNextMeta state + meta <- actMeta state' + case act state' of + Ok state2 -> tryRefine (n+1) state2 + _ -> err (const $ return (state',n)) return $ do + state2 <- goNextNewMeta state' + tryRefine n state2 + +uniqueRefinements :: CGrammar -> Action +uniqueRefinements = refineAllNodes . uniqueRefine + +metaSubstRefinements :: CGrammar -> MetaSubst -> Action +metaSubstRefinements gr = refineAllNodes . metaSubstRefine gr + +contextRefinements :: CGrammar -> Action +contextRefinements gr = refineAllNodes contextRefine where + contextRefine state = case varRefinementsState state of + [(e,_)] -> refineWithAtom False gr e state + _ -> Bad "no unique refinement in context" + varRefinementsState state = + [r | r@(e,_) <- refinementsState gr state, isVariable e] + +uniqueRefine :: CGrammar -> Action +uniqueRefine gr state = case refinementsState gr state of + [(e,_)] -> refineWithAtom False gr e state + _ -> Bad "no unique refinement" + +metaSubstRefine :: CGrammar -> MetaSubst -> Action +metaSubstRefine gr msubst state = do + m <- errIn "move pointer to meta" $ actMeta state + case lookup m msubst of + Just v -> do + e <- val2expSafe v + refineWithExpTC False gr e state + _ -> Bad "no metavariable substitution available" + +refineWithExpTC :: Bool -> CGrammar -> Exp -> Action +refineWithExpTC der gr exp0 state = do + let oldmetas = allMetas state + exp = refreshMetas oldmetas exp0 + tree0 <- annotateInState gr exp state + let tree = addBinds (actBinds state) $ tree0 + refineWithTree der gr tree state + +refineWithAtom :: Bool -> CGrammar -> Ref -> Action -- function or variable +refineWithAtom der gr at state = do + val <- lookupRef gr (allBinds state) at + typ <- val2exp val + let oldvars = allVars state + exp <- ref2exp oldvars typ at + refineWithExpTC der gr exp state + +-- in this command, we know that the result is well-typed, since computation +-- rules have been type checked and the result is equal + +computeSubTree :: CGrammar -> Action +computeSubTree gr state = do + let exp = tree2exp (actTree state) + tree <- treeByExp (compute gr) gr exp state + replaceSubTree tree state + +-- but here we don't, since the transfer flag isn't type checked, +-- and computing the transfer function is not checked to preserve equality + +transferSubTree :: Maybe Fun -> CGrammar -> Action +transferSubTree Nothing _ s = return s +transferSubTree (Just fun) gr state = do + let exp = mkApp (qq fun) [tree2exp $ actTree state] + tree <- treeByExp (compute gr) gr exp state + state' <- replaceSubTree tree state + reCheckState gr state' + +deleteSubTree :: CGrammar -> Action +deleteSubTree gr state = + if isRootState state + then do + let cat = actCat state + newCat gr cat state + else do + let metas = allMetas state + binds = actBinds state + exp = refreshMetas metas mExp0 + tree <- annotateInState gr exp state + state' <- replaceSubTree (addBinds binds tree) state + reCheckState gr state' --- must be unfortunately done. 20/11/2001 + +wrapWithFun :: CGrammar -> (Fun,Int) -> Action +wrapWithFun gr (f@(m,c),i) state = do + typ <- lookupFunType gr m c + let olds = allPrevVars state + oldmetas = allMetas state + exp0 <- fun2wrap olds ((f,i),typ) (tree2exp (actTreeBody state)) + let exp = refreshMetas oldmetas exp0 + tree0 <- annotateInState gr exp state + let tree = addBinds (actBinds state) $ tree0 + state' <- replaceSubTree tree state + reCheckState gr state' --- must be unfortunately done. 20/11/2001 + +alphaConvert :: CGrammar -> (Var,Var) -> Action +alphaConvert gr (x,x') state = do + let oldvars = allPrevVars state + testErr (notElem x' oldvars) ("clash with previous bindings" +++ show x') + let binds0 = actBinds state + vars0 = map fst binds0 + testErr (notElem x' vars0) ("clash with other bindings" +++ show x') + let binds = [(if z==x then x' else z, t) | (z,t) <- binds0] + vars = map fst binds + exp' <- alphaConv (vars ++ oldvars) (x,x') (tree2exp (actTreeBody state)) + let exp = mkAbs vars exp' + tree <- annotateExpInState gr exp state + replaceSubTree tree state + +changeFunHead :: CGrammar -> Fun -> Action +changeFunHead gr f state = do + let state' = changeNode (changeAtom (const (atomC f))) state + reCheckState gr state' --- must be done because of constraints elsewhere + +peelFunHead :: CGrammar -> Action +peelFunHead gr state = do + state' <- forgetNode state + reCheckState gr state' --- must be done because of constraints elsewhere + +-- an expensive operation +reCheckState :: CGrammar -> State -> Err State +reCheckState gr st = annotate gr (tree2exp (loc2tree st)) >>= return . tree2loc + +-- extract metasubstitutions from constraints and solve them +solveAll :: CGrammar -> State -> Err State +solveAll gr st0 = do + st <- reCheckState gr st0 + let cs0 = allConstrs st + (cs,ms) = splitConstraints cs0 + metaSubstRefinements gr ms $ mapLoc (performMetaSubstNode ms) st + + +-- active refinements + +refinementsState :: CGrammar -> State -> [(Term,Val)] +refinementsState gr state = + let filt = possibleRefVal gr state in + if actIsMeta state + then refsForType filt gr (allBinds state) (actVal state) + else [] + +wrappingsState :: CGrammar -> State -> [((Fun,Int),Type)] +wrappingsState gr state + | actIsMeta state = [] + | isRootState state = funs + | otherwise = [rule | rule@(_,typ) <- funs, possibleRefVal gr state aval typ] + where + funs = funsOnType (possibleRefVal gr state) gr aval + aval = actVal state + +headChangesState :: CGrammar -> State -> [Fun] +headChangesState gr state = errVal [] $ do + f@(m,c) <- funAtom (actAtom state) + typ0 <- lookupFunType gr m c + return [fun | (fun,typ) <- funRulesOf gr, fun /= f, typ == typ0] + --- alpha-conv ! + +canPeelState :: CGrammar -> State -> Bool +canPeelState gr state = errVal False $ do + f@(m,c) <- funAtom (actAtom state) + typ <- lookupFunType gr m c + return $ isInOneType typ + +possibleRefVal :: CGrammar -> State -> Val -> Type -> Bool +possibleRefVal gr state val typ = errVal True $ do --- was False + vtyp <- valType typ + let gen = actGen state + cs <- return [(val, vClos vtyp)] --- eqVal gen val (vClos vtyp) --- only poss cs + return $ possibleConstraints gr cs --- a simple heuristic + diff --git a/src/GF/UseGrammar/GetTree.hs b/src/GF/UseGrammar/GetTree.hs new file mode 100644 index 000000000..9b545c7dd --- /dev/null +++ b/src/GF/UseGrammar/GetTree.hs @@ -0,0 +1,46 @@ +module GetTree where + +import GFC +import Values +import qualified Grammar as G +import Ident +import MMacros +import Macros +import Rename +import TypeCheck +import PGrammar +import ShellState + +import Operations + +-- how to form linearizable trees from strings and from terms of different levels +-- +-- String --> raw Term --> annot, qualif Term --> Tree + +string2tree :: StateGrammar -> String -> Tree +string2tree gr = errVal uTree . string2treeErr gr + +string2treeErr :: StateGrammar -> String -> Err Tree +string2treeErr gr s = do + t <- pTerm s + let t1 = refreshMetas [] t + let t2 = qualifTerm abstr t1 + annotate grc t2 + where + abstr = absId gr + grc = grammar gr + +string2Cat, string2Fun :: StateGrammar -> String -> (Ident,Ident) +string2Cat gr c = (absId gr,identC c) +string2Fun = string2Cat + +strings2Cat, strings2Fun :: String -> (Ident,Ident) +strings2Cat s = (identC m, identC (drop 1 c)) where (m,c) = span (/= '.') s +strings2Fun = strings2Cat + +string2ref :: StateGrammar -> String -> Err G.Term +string2ref _ ('x':'_':ds) = return $ freshAsTerm ds --- hack for generated vars +string2ref gr s = + if elem '.' s + then return $ uncurry G.Q $ strings2Fun s + else return $ G.Vr $ identC s diff --git a/src/GF/UseGrammar/Information.hs b/src/GF/UseGrammar/Information.hs new file mode 100644 index 000000000..569d8ace6 --- /dev/null +++ b/src/GF/UseGrammar/Information.hs @@ -0,0 +1,130 @@ +module Information where + +import Grammar +import Ident +import Modules +import Option +import CF +import PPrCF +import ShellState +import PrGrammar +import Lookup +import qualified GFC +import qualified AbsGFC + +import Operations +import UseIO + +-- information on module, category, function, operation, parameter,... AR 16/9/2003 +-- uses source grammar + +-- the top level function + +showInformation :: Options -> ShellState -> Ident -> IOE () +showInformation opts st c = do + is <- ioeErr $ getInformation opts st c + mapM_ (putStrLnE . prInformation opts c) is + +-- the data type of different kinds of information + +data Information = + IModAbs SourceAbs + | IModRes SourceRes + | IModCnc SourceCnc + | IModule SourceAbs ---- to be deprecated + | ICatAbs Ident Context [Ident] + | ICatCnc Ident Type [CFRule] Term + | IFunAbs Ident Type (Maybe Term) + | IFunCnc Ident Type [CFRule] Term + | IOper Ident Type Term + | IParam Ident [Param] [Term] + | IValue Ident Type + +type CatId = AbsGFC.CIdent +type FunId = AbsGFC.CIdent + +prInformation :: Options -> Ident -> Information -> String +prInformation opts c i = unlines $ prt c : case i of + IModule m -> [ + "module of type" +++ show (mtype m), + "extends" +++ show (extends m), + "opens" +++ show (opens m), + "defines" +++ unwords (map prt (ownConstants (jments m))) + ] + ICatAbs m co _ -> [ + "category in abstract module" +++ prt m, + "context" +++ prContext co + ] + ICatCnc m ty cfs tr -> [ + "category in concrete module" +++ prt m, + "linearization type" +++ prt ty + ] + IFunAbs m ty _ -> [ + "function in abstract module" +++ prt m, + "type" +++ prt ty + ] + IFunCnc m ty cfs tr -> [ + "function in concrete module" +++ prt m, + "linearization" +++ prt tr + --- "linearization type" +++ prt ty + ] + IOper m ty tr -> [ + "operation in resource module" +++ prt m, + "type" +++ prt ty, + "definition" +++ prt tr + ] + IParam m ty ts -> [ + "parameter type in resource module" +++ prt m, + "constructors" +++ unwords (map prParam ty), + "values" +++ unwords (map prt ts) + ] + IValue m ty -> [ + "parameter constructor in resource module" +++ prt m, + "type" +++ show ty + ] + +-- also finds out if an identifier is defined in many places + +getInformation :: Options -> ShellState -> Ident -> Err [Information] +getInformation opts st c = allChecks $ [ + do + m <- lookupModule src c + case m of + ModMod mo -> return $ IModule mo + _ -> prtBad "not a source module" c + ] ++ map lookInSrc ss ++ map lookInCan cs + where + lookInSrc (i,m) = do + j <- lookupInfo m c + case j of + AbsCat (Yes co) _ -> return $ ICatAbs i co [] --- + AbsFun (Yes ty) _ -> return $ IFunAbs i ty Nothing --- + CncCat (Yes ty) _ _ -> do + ---- let cat = ident2CFCat i c + ---- rs <- concat [rs | (c,rs) <- cf, ] + return $ ICatCnc i ty [] ty --- + CncFun _ (Yes tr) _ -> do + rs <- return [] + return $ IFunCnc i tr rs tr --- + ResOper (Yes ty) (Yes tr) -> return $ IOper i ty tr + ResParam (Yes ps) -> do + ts <- allParamValues src (QC i c) + return $ IParam i ps ts + ResValue (Yes ty) -> return $ IValue i ty --- + + _ -> prtBad "nothing available for" i + lookInCan (i,m) = do + Bad "nothing available yet in canonical" + + src = srcModules st + can = canModules st + ss = [(i,m) | (i,ModMod m) <- modules src] + cs = [(i,m) | (i,ModMod m) <- modules can] + cf = concatMap ruleGroupsOfCF $ map snd $ cfs st + +ownConstants :: BinTree (Ident, Info) -> [Ident] +ownConstants = map fst . filter isOwn . tree2list where + isOwn (c,i) = case i of + AnyInd _ _ -> False + _ -> True + diff --git a/src/GF/UseGrammar/Linear.hs b/src/GF/UseGrammar/Linear.hs new file mode 100644 index 000000000..da1bfce52 --- /dev/null +++ b/src/GF/UseGrammar/Linear.hs @@ -0,0 +1,195 @@ +module Linear where + +import GFC +import AbsGFC +import qualified Abstract as A +import MkGFC (rtQIdent) ---- +import Ident +import PrGrammar +import CMacros +import Look +import Str +import Unlex +----import TypeCheck -- to annotate + +import Operations +import Zipper + +import Monad + +-- Linearization for canonical GF. AR 7/6/2003 + +-- The worker function: linearize a Tree, return +-- a record. Possibly mark subtrees. + +-- NB. Constants in trees are annotated by the name of the abstract module. +-- A concrete module name must be given to find (and choose) linearization rules. + +linearizeToRecord :: CanonGrammar -> Marker -> Ident -> A.Tree -> Err Term +linearizeToRecord gr mk m = lin [] where + + lin ts t = errIn ("lint" +++ prt t) $ ---- + if A.isFocusNode (A.nodeTree t) + then liftM markFocus $ lint ts t + else lint ts t + + lint ts t@(Tr (n,xs)) = do + + let binds = A.bindsNode n + at = A.atomNode n + c <- A.val2cat $ A.valNode n + xs' <- mapM (\ (i,x) -> lin (i:ts) x) $ zip [0..] xs + + r <- case at of + A.AtC f -> look f >>= comp xs' + A.AtL s -> return $ recS $ tK $ prt at + A.AtI i -> return $ recS $ tK $ prt at + A.AtV x -> lookCat c >>= comp [tK (prt at)] + A.AtM m -> lookCat c >>= comp [tK (prt at)] + + return $ mk ts $ mkBinds binds r + + look = lookupLin gr . redirectIdent m . rtQIdent + comp = ccompute gr + mkBinds bs bdy = case bdy of + R fs -> R $ [Ass (LV i) (tK (prt t)) | (i,(t,_)) <- zip [0..] bs] ++ fs + + recS t = R [Ass (L (identC "s")) t] ---- + + lookCat = return . errVal defLindef . look + ---- should always be given in the module + +type Marker = [Int] -> Term -> Term + +-- if no marking is wanted, use the following + +noMark :: [Int] -> Term -> Term +noMark = const id + +-- thus the special case: + +linearizeNoMark :: CanonGrammar -> Ident -> A.Tree -> Err Term +linearizeNoMark gr = linearizeToRecord gr noMark + +-- expand tables in linearized term to full, normal-order tables +-- NB expand from inside-out so that values are not looked up in copies of branches + +expandLinTables :: CanonGrammar -> Term -> Err Term +expandLinTables gr t = case t of + R rs -> liftM (R . map (uncurry Ass)) $ mapPairsM exp [(l,r) | Ass l r <- rs] + T ty rs -> do + rs' <- mapPairsM exp [(l,r) | Cas l r <- rs] -- expand from inside-out + let t' = T ty $ map (uncurry Cas) rs' + vs <- alls ty + ps <- mapM term2patt vs + ts' <- mapM (comp . S t') $ vs + return $ T ty [Cas [p] t | (p,t) <- zip ps ts'] + FV ts -> liftM FV $ mapM exp ts + _ -> return t + where + alls = allParamValues gr + exp = expandLinTables gr + comp = ccompute gr [] + +-- from records, one can get to records of tables of strings + +rec2strTables :: Term -> Err [[(Label,[([Patt],[Str])])]] +rec2strTables r = do + vs <- allLinValues r + mapM (mapPairsM (mapPairsM strsFromTerm)) vs + +-- from these tables, one may want to extract the ones for the "s" label + +strTables2sTables :: [[(Label,[([Patt],[Str])])]] -> [[([Patt],[Str])]] +strTables2sTables ts = [t | r <- ts, (l,t) <- r, l == linLab0] + +linLab0 :: Label +linLab0 = L (identC "s") + +-- to get lists of token lists is easy +sTables2strs :: [[([Patt],[Str])]] -> [[Str]] +sTables2strs = map snd . concat + +-- from this, to get a list of strings --- customize unlexer +strs2strings :: [[Str]] -> [String] +strs2strings = map unlex + +-- finally, a top-level function to get a string from an expression +linTree2string :: CanonGrammar -> Ident -> A.Tree -> String +linTree2string gr m e = err id id $ do + t <- linearizeNoMark gr m e + r <- expandLinTables gr t + ts <- rec2strTables r + let ss = strs2strings $ sTables2strs $ strTables2sTables ts + ifNull (prtBad "empty linearization of" e) (return . head) ss + + +-- argument is a Tree, value is a list of strs; needed in Parsing + +allLinsOfTree :: CanonGrammar -> Ident -> A.Tree -> [Str] +allLinsOfTree gr a e = err (singleton . str) id $ do + e' <- return e ---- annotateExp gr e + r <- linearizeNoMark gr a e' + r' <- expandLinTables gr r + ts <- rec2strTables r' + return $ concat $ sTables2strs $ strTables2sTables ts + +{- +-- the value is a list of strs +allLinStrings :: CanonGrammar -> Tree -> [Str] +allLinStrings gr ft = case allLinsAsStrs gr ft of + Ok ts -> map snd $ concat $ map snd $ concat ts + Bad s -> [str s] + +-- the value is a list of strs, not forgetting their arguments +allLinsAsStrs :: CanonGrammar -> Tree -> Err [[(Label,[([Patt],Str)])]] +allLinsAsStrs gr ft = do + lpts <- allLinearizations gr ft + return $ concat $ mapM (mapPairsM (mapPairsM strsFromTerm)) lpts + +-- the value is a list of terms of type Str, not forgetting their arguments +allLinearizations :: CanonGrammar -> Tree -> Err [[(Label,[([Patt],Term)])]] +allLinearizations gr ft = linearizeTree gr ft >>= allLinValues + +-- to a list of strings +linearizeToStrings :: CanonGrammar -> ([Int] ->Term -> Term) -> Tree -> Err [String] +linearizeToStrings gr mk = liftM (map unlex) . linearizeToStrss gr mk + +-- to a list of token lists +linearizeToStrss :: CanonGrammar -> ([Int] -> Term -> Term) -> Tree -> Err [[Str]] +linearizeToStrss gr mk e = do + R rs <- linearizeToRecord gr mk e ---- + t <- lookupErr linLab0 [(r,s) | Ass r s <- rs] + return $ map strsFromTerm $ allInTable t + + +-- the value is a list of strings, not forgetting their arguments +allLinsOfFun :: CanonGrammar -> CIdent -> Err [[(Label,[([Patt],Term)])]] +allLinsOfFun gr f = do + t <- lookupLin gr f + allLinValues t + + + +-} + + + + +{- ---- +-- returns printname if one exists; otherwise linearizes with metas +printOrLinearize :: CanonGrammar -> Fun -> String +printOrLinearize gr f = +{- ---- + errVal (prtt f) $ case lookupPrintname cnc f of + Ok s -> return s + _ -> -} + + unlines $ take 1 $ err singleton id $ + do + t <- lookupFunType gr f + f' <- ref2exp [] t (AC f) --- [] + lin f' + where + lin = linearizeToStrings gr (const id) ---- +-} diff --git a/src/GF/UseGrammar/MoreCustom.hs b/src/GF/UseGrammar/MoreCustom.hs new file mode 100644 index 000000000..0ebbb25fb --- /dev/null +++ b/src/GF/UseGrammar/MoreCustom.hs @@ -0,0 +1,15 @@ +module MoreCustom where + +-- All these lists are supposed to be empty! +-- Items should be added to ../Custom.hs instead. + +moreCustomGrammarParser = [] +moreCustomGrammarPrinter = [] +moreCustomSyntaxPrinter = [] +moreCustomTermPrinter = [] +moreCustomTermCommand = [] +moreCustomEditCommand = [] +moreCustomStringCommand = [] +moreCustomParser = [] +moreCustomTokenizer = [] +moreCustomUntokenizer = [] diff --git a/src/GF/UseGrammar/Morphology.hs b/src/GF/UseGrammar/Morphology.hs new file mode 100644 index 000000000..102e41340 --- /dev/null +++ b/src/GF/UseGrammar/Morphology.hs @@ -0,0 +1,116 @@ +module Morphology where + +import AbsGFC +import GFC +import PrGrammar + +import Operations + +import Char +import List (sortBy, intersperse) +import Monad (liftM) + +-- construct a morphological analyser from a GF grammar. AR 11/4/2001 + +-- we have found the binary search tree sorted by word forms more efficient +-- than a trie, at least for grammars with 7000 word forms + +type Morpho = BinTree (String,[String]) + +emptyMorpho = NT + +-- with literals +appMorpho :: Morpho -> String -> (String,[String]) +appMorpho m s = (s, ps ++ ms) where + ms = case lookupTree id s m of + Ok vs -> vs + _ -> [] + ps = [] ---- case lookupLiteral s of + ---- Ok (t,_) -> [tagPrt t] + ---- _ -> [] + +-- without literals +appMorphoOnly :: Morpho -> String -> (String,[String]) +appMorphoOnly m s = (s, ms) where + ms = case lookupTree id s m of + Ok vs -> vs + _ -> [] + +-- recognize word, exluding literals +isKnownWord :: Morpho -> String -> Bool +isKnownWord mo = not . null . snd . appMorphoOnly mo + +mkMorpho :: CanonGrammar -> Morpho +mkMorpho gr = emptyMorpho ---- +{- ---- +mkMorpho gr = mkMorphoTree $ concat $ map mkOne $ allItems where + mkOne (Left (fun,c)) = map (prOne fun c) $ allLins fun + mkOne (Right (fun,_)) = map (prSyn fun) $ allSyns fun + + -- gather forms of lexical items + allLins fun = errVal [] $ do + ts <- allLinsOfFun gr fun + ss <- mapM (mapPairsM (mapPairsM (return . wordsInTerm))) ts + return [(p,s) | (p,fs) <- concat $ map snd $ concat ss, s <- fs] + prOne f c (ps,s) = (s, prt f +++ tagPrt c ++ concat (map tagPrt ps)) + + -- gather syncategorematic words + allSyns fun = errVal [] $ do + tss <- allLinsOfFun gr fun + let ss = [s | ts <- tss, (_,fs) <- ts, (_,s) <- fs] + return $ concat $ map wordsInTerm ss + prSyn f s = (s, "+" ++ tagPrt f) + + -- all words, Left from lexical rules and Right syncategorematic + allItems = [lexRole t (f,c) | (f,c) <- allFuns, t <- lookType f] where + allFuns = allFunsWithValCat ab + lookType = errVal [] . liftM (:[]) . lookupFunType ab + lexRole t = case typeForm t of + Ok ([],_,_) -> Left + _ -> Right +-} + +-- printing full-form lexicon and results + +prMorpho :: Morpho -> String +prMorpho = unlines . map prMorphoAnalysis . tree2list + +prMorphoAnalysis :: (String,[String]) -> String +prMorphoAnalysis (w,fs) = unlines (w:fs) + +prMorphoAnalysisShort :: (String,[String]) -> String +prMorphoAnalysisShort (w,fs) = prBracket (w' ++ prTList "/" fs) where + w' = if null fs then w +++ "*" else "" + +tagPrt :: Print a => a -> String +tagPrt = ("+" ++) . prt --- could look up print name in grammar + +-- print all words recognized + +allMorphoWords :: Morpho -> [String] +allMorphoWords = map fst . tree2list + +-- analyse running text and show results either in short form or on separate lines +morphoTextShort mo = unwords . map (prMorphoAnalysisShort . appMorpho mo) . words +morphoText mo = unlines . map (('\n':) . prMorphoAnalysis . appMorpho mo) . words + +-- format used in the Italian Verb Engine +prFullForm :: Morpho -> String +prFullForm = unlines . map prOne . tree2list where + prOne (s,ps) = s ++ " : " ++ unwords (intersperse "/" ps) + +-- auxiliaries + +mkMorphoTree :: (Ord a, Eq b) => [(a,b)] -> BinTree (a,[b]) +mkMorphoTree = sorted2tree . sortAssocs + +sortAssocs :: (Ord a, Eq b) => [(a,b)] -> [(a,[b])] +sortAssocs = arrange . sortBy (\ (x,_) (y,_) -> compare x y) where + arrange ((x,v):xvs) = arr x [v] xvs + arrange [] = [] + arr y vs xs = case xs of + (x,v):xvs -> if x==y then arr y vvs xvs else (y,vs) : arr x [v] xvs + where vvs = if elem v vs then vs else (v:vs) + _ -> [(y,vs)] + + diff --git a/src/GF/UseGrammar/Paraphrases.hs b/src/GF/UseGrammar/Paraphrases.hs new file mode 100644 index 000000000..f5dc710f9 --- /dev/null +++ b/src/GF/UseGrammar/Paraphrases.hs @@ -0,0 +1,53 @@ +module Paraphrases (mkParaphrases) where + +import Operations +import AbsGFC +import GFC +import Look +import CMacros ---- (mkApp, eqStrIdent) +import AbsCompute +import List (nub) + +-- paraphrases of GF terms. AR 6/10/1998 -- 24/9/1999 -- 5/7/2000 -- 5/6/2002 +-- Copyright (c) Aarne Ranta 1998--99, under GNU General Public License (see GPL) +-- thus inherited from the old GF. Incomplete and inefficient... + +mkParaphrases :: CanonGrammar -> Exp -> [Exp] +mkParaphrases st t = [t] +---- mkParaphrases st = nub . map (beta []) . paraphrases (allDefs st) + +{- ---- +type Definition = (Fun,Trm) + +paraphrases :: [Definition] -> Trm -> [Trm] +paraphrases th t = + t : + paraImmed th t ++ +--- paraMatch th t ++ + case t of + App c a -> [App d b | d <- paraphrases th c, b <- paraphrases th a] + Abs x b -> [Abs x d | d <- paraphrases th b] + c -> [] + +paraImmed :: [Definition] -> Trm -> [Trm] +paraImmed defs t = + [Cn f | (f, u) <- defs, t == u] ++ --- eqTerm + case t of + Cn c -> [u | (f, u) <- defs, eqStrIdent f c] + _ -> [] +-} +{- --- +paraMatch :: [Definition] -> Trm -> [Trm] +paraMatch th@defs t = + [mkApp (Cn f) xx | (PC f zz, u) <- defs, + let (fs,sn) = fullApp u, fs == h, length sn == length zz] ++ + case findAMatch defs t of + Ok (g,b) -> [substTerm [] g b] + _ -> [] + where + (h,xx) = fullApp t + fullApp c = case c of + App f a -> (f', a' ++ [a]) where (f',a') = fullApp f + c -> (c,[]) + +-} diff --git a/src/GF/UseGrammar/Parsing.hs b/src/GF/UseGrammar/Parsing.hs new file mode 100644 index 000000000..4cd4f4bc8 --- /dev/null +++ b/src/GF/UseGrammar/Parsing.hs @@ -0,0 +1,98 @@ +module Parsing where + +import CheckM +import qualified AbsGFC as C +import GFC +import MkGFC (trExp) ---- +import CMacros +import Linear +import Str +import CF +import CFIdent +import Ident +import TypeCheck +import Values +--import CFMethod +import Tokenize +import Profile +import Option +import Custom +import ShellState + +import Operations + +import List (nub) +import Monad (liftM) + +-- AR 26/1/2000 -- 8/4 -- 28/1/2001 -- 9/12/2002 + +parseString :: Options -> StateGrammar -> CFCat -> String -> Err [Tree] +parseString os sg cat = liftM fst . parseStringMsg os sg cat + +parseStringMsg :: Options -> StateGrammar -> CFCat -> String -> Err ([Tree],String) +parseStringMsg os sg cat s = do + (ts,(_,ss)) <- checkStart $ parseStringC os sg cat s + return (ts,unlines ss) + +parseStringC :: Options -> StateGrammar -> CFCat -> String -> Check [Tree] +parseStringC opts0 sg cat s = do + let opts = unionOptions opts0 $ stateOptions sg + cf = stateCF sg + gr = stateGrammarST sg + cn = cncId sg + tok = customOrDefault opts useTokenizer customTokenizer sg + parser = customOrDefault opts useParser customParser sg cat + tokens2trms opts sg cn parser (tok s) + +tokens2trms :: Options ->StateGrammar ->Ident -> CFParser -> [CFTok] -> Check [Tree] +tokens2trms opts sg cn parser as = do + let res@(trees,info) = parser as + ts0 <- return $ nub (cfParseResults res) + ts <- case () of + _ | null ts0 -> checkWarn "No success in cf parsing" >> return [] + _ | raw -> do + ts1 <- return (map cf2trm0 ts0) ----- should not need annot + mapM (checkErr . (annotate gr) . trExp) ts1 ---- complicated + _ -> do + (ts1,_) <- checkErr $ mapErr postParse ts0 + ts2 <- mapM (checkErr . (annotate gr) . trExp) ts1 ---- + if forgive then return ts2 else do + let tsss = [(t, allLinsOfTree gr cn t) | t <- ts2] + ps = [t | (t,ss) <- tsss, + any (compatToks as) (map str2cftoks ss)] + if null ps + then raise $ "Failure in morphology." ++ + if verb + then "\nPossible corrections: " +++++ + unlines (nub (map sstr (concatMap snd tsss))) + else "" + else return ps + + if verb + then checkWarn $ " the token list" +++ show as ++++ unknown as +++++ info + else return () + + return $ optIntOrAll opts flagNumber $ nub ts + where + gr = stateGrammarST sg + + raw = oElem rawParse opts + verb = oElem beVerbose opts + forgive = oElem forgiveParse opts + + unknown ts = case filter noMatch ts of + [] -> "where all words are known" + us -> "with the unknown tokens" +++ show us --- needs to be fixed for literals + terminals = map TS $ cfTokens $ stateCF sg + noMatch t = all (not . compatTok t) terminals + + +--- too much type checking in building term info? return FullTerm to save work? + +-- raw parsing: so simple it is for a context-free CF grammar +cf2trm0 :: CFTree -> C.Exp +cf2trm0 (CFTree (fun, (_, trees))) = mkAppAtom (cffun2trm fun) (map cf2trm0 trees) + where + cffun2trm (CFFun (fun,_)) = fun + mkApp = foldl C.EApp + mkAppAtom a = mkApp (C.EAtom a) diff --git a/src/GF/UseGrammar/Randomized.hs b/src/GF/UseGrammar/Randomized.hs new file mode 100644 index 000000000..dceb6acc6 --- /dev/null +++ b/src/GF/UseGrammar/Randomized.hs @@ -0,0 +1,47 @@ +module Randomized where + +import Abstract +import Editing + +import Operations +import Zipper + +--- import Arch (myStdGen) --- circular for hbc +import Random --- (mkStdGen, StdGen, randoms) --- bad import for hbc + +-- random generation and refinement. AR 22/8/2001 +-- implemented as sequence of refinement menu selecsions, encoded as integers + +myStdGen = mkStdGen --- + +-- build one random tree; use mx to prevent infinite search +mkRandomTree :: StdGen -> Int -> CGrammar -> QIdent -> Err Tree +mkRandomTree gen mx gr cat = mkTreeFromInts (take mx (randoms gen)) gr cat + +refineRandom :: StdGen -> Int -> CGrammar -> Action +refineRandom gen mx = mkStateFromInts $ take mx $ map abs (randoms gen) + +-- build a tree from a list of integers +mkTreeFromInts :: [Int] -> CGrammar -> QIdent -> Err Tree +mkTreeFromInts ints gr cat = do + st0 <- newCat gr cat initState + state <- mkStateFromInts ints gr st0 + return $ loc2tree state + +mkStateFromInts :: [Int] -> CGrammar -> Action +mkStateFromInts ints gr = mkRandomState ints where + mkRandomState [] state = do + testErr (isCompleteState state) "not completed" + return state + mkRandomState (n:ns) state = do + let refs = refinementsState gr state + testErr (not (null refs)) $ "no refinements available for" +++ + prt (actVal state) + (ref,_) <- (refs !? (n `mod` (length refs))) + state1 <- refineWithAtom False gr ref state + if isCompleteState state1 + then return state1 + else do + state2 <- goNextMeta state1 + mkRandomState ns state2 + diff --git a/src/GF/UseGrammar/RealMoreCustom.hs b/src/GF/UseGrammar/RealMoreCustom.hs new file mode 100644 index 000000000..b9f461a1f --- /dev/null +++ b/src/GF/UseGrammar/RealMoreCustom.hs @@ -0,0 +1,122 @@ +module MoreCustom where + +import Operations +import Text +import Tokenize +import UseGrammar +import qualified UseSyntax as S +import ShellState +import Editing +import Paraphrases +import Option +import CF +import CFIdent --- (CFTok, tS) + +import EBNF +import CFtoGrammar +import PPrCF + +import CFtoHappy +import Morphology +import GrammarToHaskell +import GrammarToCanon (showCanon) +import GrammarToXML +import qualified SyntaxToLatex as L +import GFTex +import MkResource +import SeparateOper + +-- the cf parsing algorithms +import ChartParser -- or some other CF Parser +import Earley -- such as this one +---- import HappyParser -- or this... + +import qualified PPrSRG as SRG +import PPrGSL + +import qualified TransPredCalc as PC + +-- databases for customizable commands. AR 21/11/2001 +-- Extends ../Custom. + +moreCustomGrammarParser = + [ + (strCIm "gfl", S.parseGrammar . extractGFLatex) + ,(strCIm "tex", S.parseGrammar . extractGFLatex) + ,(strCIm "ebnf", pAsGrammar pEBNFasGrammar) + ,(strCIm "cf", pAsGrammar pCFAsGrammar) +-- add your own grammar parsers here + ] + where + -- use a parser with no imports or flags + pAsGrammar p = err Bad (\g -> return (([],noOptions),g)) . p + + +moreCustomGrammarPrinter = + [ + (strCIm "happy", cf2HappyS . stateCF) + ,(strCIm "srg", SRG.prSRG . stateCF) + ,(strCIm "gsl", prGSL . stateCF) + ,(strCIm "gfhs", show . stateGrammarST) + ,(strCIm "haskell", grammar2haskell . st2grammar . stateGrammarST) + ,(strCIm "xml", unlines . prDTD . grammar2dtd . stateAbstract) + ,(strCIm "fullform",prFullForm . stateMorpho) + ,(strCIm "resource",prt . st2grammar . mkResourceGrammar . stateGrammarST) + ,(strCIm "resourcetypes", + prt . operTypeGrammar . st2grammar . mkResourceGrammar . stateGrammarST) + ,(strCIm "resourcedefs", + prt . operDefGrammar . st2grammar . mkResourceGrammar . stateGrammarST) +-- add your own grammar printers here +--- also include printing via grammar2syntax! + ] + +moreCustomSyntaxPrinter = + [ + (strCIm "gf", S.prSyntax) -- DEFAULT + ,(strCIm "latex", L.syntax2latexfile) +-- add your own grammar printers here + ] + +moreCustomTermPrinter = + [ + (strCIm "xml", \g t -> unlines $ prElementX $ term2elemx (stateAbstract g) t) +-- add your own term printers here + ] + +moreCustomTermCommand = + [ + (strCIm "predcalc", \_ t -> PC.transfer t) +-- add your own term commands here + ] + +moreCustomEditCommand = + [ +-- add your own edit commands here + ] + +moreCustomStringCommand = + [ +-- add your own string commands here + ] + +moreCustomParser = + [ + (strCIm "chart", chartParser . stateCF) + ,(strCIm "earley", earleyParser . stateCF) +-- ,(strCIm "happy", const $ lexHaskell) +-- ,(strCIm "td", const $ lexText) +-- add your own parsers here + ] + +moreCustomTokenizer = + [ +-- add your own tokenizers here + ] + +moreCustomUntokenizer = + [ +-- add your own untokenizers here + ] + + +strCIm = id diff --git a/src/GF/UseGrammar/Session.hs b/src/GF/UseGrammar/Session.hs new file mode 100644 index 000000000..bf2dd30ab --- /dev/null +++ b/src/GF/UseGrammar/Session.hs @@ -0,0 +1,110 @@ +module Session where + +import Abstract +import Option +---- import Custom +import Editing + +import Operations + +-- First version 8/2001. Adapted to GFC with modules 19/6/2003. +-- Nothing had to be changed, which is a sign of good modularity. + +-- keep these abstract + +type SState = [(State,[Exp],SInfo)] -- exps are candidate refinements +type SInfo = ([String],(Int,Options)) -- string is message, int is the view + +initSState :: SState +initSState = [(initState, [], (["Select category to start"],(0,noOptions)))] + -- instead of empty + +okInfo n = ([],(n,True)) + +stateSState ((s,_,_):_) = s +candsSState ((_,ts,_):_) = ts +infoSState ((_,_,i):_) = i +msgSState ((_,_,(m,_)):_) = m +viewSState ((_,_,(_,(v,_))):_) = v +optsSState ((_,_,(_,(_,o))):_) = o + +treeSState = actTree . stateSState + + +-- from state to state + +type ECommand = SState -> SState + +-- elementary commands + +-- change state, drop cands, drop message, preserve options +changeState :: State -> ECommand +changeState s ss = changeMsg [] $ (s,[],infoSState ss) : ss + +changeCands :: [Exp] -> ECommand +changeCands ts ss@((s,_,(_,b)):_) = (s,ts,(candInfo ts,b)) : ss -- add new state + +changeMsg :: [String] -> ECommand +changeMsg m ((s,ts,(_,b)):ss) = (s,ts,(m,b)) : ss -- just change message + +changeView :: ECommand +changeView ((s,ts,(m,(v,b))):ss) = (s,ts,(m,(v+1,b))) : ss -- toggle view + +changeStOptions :: (Options -> Options) -> ECommand +changeStOptions f ((s,ts,(m,(v,o))):ss) = (s,ts,(m,(v, f o))) : ss + +noNeedForMsg = changeMsg [] -- everything's all right: no message + +candInfo ts = case length ts of + 0 -> ["no acceptable alternative"] + 1 -> ["just one acceptable alternative"] + n -> [show n +++ "alternatives to select"] + +-- keep SState abstract from this on + +-- editing commands + +action2command :: Action -> ECommand +action2command act state = case act (stateSState state) of + Ok s -> changeState s state + Bad m -> changeMsg [m] state + +action2commandNext :: Action -> ECommand -- move to next meta after execution +action2commandNext act = action2command (\s -> act s >>= goNextMetaIfCan) + +undoCommand :: ECommand +undoCommand ss@[_] = changeMsg ["cannot go back"] ss +undoCommand (_:ss) = changeMsg ["successful undo"] ss + +selectCand :: CGrammar -> Int -> ECommand +selectCand gr i state = err (\m -> changeMsg [m] state) id $ do + exp <- candsSState state !? i + let s = stateSState state + tree <- annotateInState gr exp s + return $ case replaceSubTree tree s of + Ok st' -> changeState st' state + Bad s -> changeMsg [s] state + +refineByExps :: Bool -> CGrammar -> [Exp] -> ECommand +refineByExps der gr trees = case trees of + [t] -> action2commandNext (refineWithExpTC der gr t) + _ -> changeCands trees + +replaceByTrees :: CGrammar -> [Exp] -> ECommand +replaceByTrees gr trees = case trees of + [t] -> action2commandNext (\s -> + annotateExpInState gr t s >>= flip replaceSubTree s) + _ -> changeCands trees + +{- ---- +replaceByEditCommand :: CGrammar -> String -> ECommand +replaceByEditCommand gr co = + action2command $ + maybe return ($ gr) $ + lookupCustom customEditCommand (strCI co) + +replaceByTermCommand :: CGrammar -> String -> Exp -> ECommand +replaceByTermCommand gr co exp = + replaceByTrees gr $ maybe [exp] (\f -> f (abstractOf gr) exp) $ + lookupCustom customTermCommand (strCI co) +-} diff --git a/src/GF/UseGrammar/TeachYourself.hs b/src/GF/UseGrammar/TeachYourself.hs new file mode 100644 index 000000000..9037b9198 --- /dev/null +++ b/src/GF/UseGrammar/TeachYourself.hs @@ -0,0 +1,69 @@ +module TeachYourself where + +import Operations +import UseIO + +import UseGrammar +import Linear (allLinsIfContinuous) +import ShellState +import API +import Option + +import Random --- (randoms) --- bad import for hbc +import Arch (myStdGen) +import System + +-- translation and morphology quiz. AR 10/5/2000 -- 12/4/2002 + +teachTranslation :: Options -> GFGrammar -> GFGrammar -> IO () +teachTranslation opts ig og = do + tts <- transTrainList opts ig og infinity + let qas = [ (q, mkAnswer as) | (q,as) <- tts] + teachDialogue qas "Welcome to GF Translation Quiz." + +transTrainList :: + Options -> GFGrammar -> GFGrammar -> Integer -> IO [(String,[String])] +transTrainList opts ig og number = do + ts <- randomTermsIO opts ig (fromInteger number) + return $ map mkOne $ ts + where + cat = firstCatOpts opts ig + mkOne t = (norml (linearize ig t),map (norml . linearize og) (homonyms ig cat t)) + +teachMorpho :: Options -> GFGrammar -> IO () +teachMorpho opts ig = useIOE () $ do + tts <- morphoTrainList opts ig infinity + let qas = [ (q, mkAnswer as) | (q,as) <- tts] + ioeIO $ teachDialogue qas "Welcome to GF Morphology Quiz." + +morphoTrainList :: Options -> GFGrammar -> Integer -> IOE [(String,[String])] +morphoTrainList opts ig number = do + ts <- ioeIO $ randomTreesIO opts ig (fromInteger number) + gen <- ioeIO $ myStdGen (fromInteger number) + mkOnes gen ts + where + mkOnes gen (t:ts) = do + psss <- ioeErr $ allLinsIfContinuous gr t + let pss = concat psss + let (i,gen') = randomR (0, length pss - 1) gen + (ps,ss) <- ioeErr $ pss !? i + (_,ss0) <- ioeErr $ pss !? 0 + let bas = sstrV $ take 1 ss0 + more <- mkOnes gen' ts + return $ (bas +++ ":" +++ unwords (map prt ps), return (sstrV ss)) : more + mkOnes gen [] = return [] + + gr = stateConcrete ig + +-- compare answer to the list of possible answers, increase score and give feedback +mkAnswer :: [String] -> String -> (Integer, String) +mkAnswer as s = if (elem (norml s) as) + then (1,"Yes.") + else (0,"No, not" +++ s ++ ", but" ++++ unlines as) + +norml = unwords . words + +--- the maximal number of precompiled quiz problems +infinity :: Integer +infinity = 123 + diff --git a/src/GF/UseGrammar/Tokenize.hs b/src/GF/UseGrammar/Tokenize.hs new file mode 100644 index 000000000..dd0879931 --- /dev/null +++ b/src/GF/UseGrammar/Tokenize.hs @@ -0,0 +1,130 @@ +module Tokenize where + +import Operations +---- import UseGrammar (isLiteral,identC) +import CFIdent + +import Char + +-- lexers = tokenizers, to prepare input for GF grammars. AR 4/1/2002 +-- an entry for each is included in Custom.customTokenizer + +-- just words + +tokWords :: String -> [CFTok] +tokWords = map tS . words + +tokLits :: String -> [CFTok] +tokLits = map mkCFTok . words + +tokVars :: String -> [CFTok] +tokVars = map mkCFTokVar . words + +mkCFTok :: String -> CFTok +mkCFTok s = tS s ---- if (isLiteral s) then (mkLit s) else (tS s) + +mkCFTokVar :: String -> CFTok +mkCFTokVar s = case s of + '?':_:_ -> tM s + 'x':'_':_ -> tV s + 'x':[] -> tV s + '$':xs@(_:_) -> if last s == '$' then tV (init xs) else tS s + _ -> tS s + +mkLit :: String -> CFTok +mkLit s = if (all isDigit s) then (tI s) else (tL s) + +mkTL :: String -> CFTok +mkTL s = if (all isDigit s) then (tI s) else (tL ("'" ++ s ++ "'")) + + +-- Haskell lexer, usable for much code + +lexHaskell :: String -> [CFTok] +lexHaskell ss = case lex ss of + [(w@(_:_),ws)] -> tS w : lexHaskell ws + _ -> [] + +-- somewhat shaky text lexer + +lexText :: String -> [CFTok] +lexText = uncap . lx where + + lx s = case s of + p : cs | isMPunct p -> tS [p] : uncap (lx cs) + p : cs | isPunct p -> tS [p] : lx cs + s : cs | isSpace s -> lx cs + _ : _ -> getWord s + _ -> [] + + getWord s = tS w : lx ws where (w,ws) = span isNotSpec s + isMPunct c = elem c ".!?" + isPunct c = elem c ",:;()\"" + isNotSpec c = not (isMPunct c || isPunct c || isSpace c) + uncap (TS (c:cs) : ws) = tC (c:cs) : ws + uncap s = s + +-- lexer for C--, a mini variant of C + +lexC2M :: String -> [CFTok] +lexC2M = lexC2M' False + +lexC2M' :: Bool -> String -> [CFTok] +lexC2M' isHigherOrder s = case s of + '#':cs -> lexC $ dropWhile (/='\n') cs + '/':'*':cs -> lexC $ dropComment cs + c:cs | isSpace c -> lexC cs + c:cs | isAlpha c -> getId s + c:cs | isDigit c -> getLit s + c:d:cs | isSymb [c,d] -> tS [c,d] : lexC cs + c:cs | isSymb [c] -> tS [c] : lexC cs + _ -> [] --- covers end of file and unknown characters + where + lexC = lexC2M' isHigherOrder + getId s = mkT i : lexC cs where (i,cs) = span isIdChar s + getLit s = tI i : lexC cs where (i,cs) = span isDigit s + isIdChar c = isAlpha c || isDigit c || elem c "'_" + isSymb = reservedAnsiCSymbol + dropComment s = case s of + '*':'/':cs -> cs + _:cs -> dropComment cs + _ -> [] + mkT i = if (isRes i) then (tS i) else + if isHigherOrder then (tV i) else (tL ("'" ++ i ++ "'")) + isRes = reservedAnsiC + + +reservedAnsiCSymbol s = case lookupTree show s ansiCtree of + Ok True -> True + _ -> False + +reservedAnsiC s = case lookupTree show s ansiCtree of + Ok False -> True + _ -> False + +-- for an efficient lexer: precompile this! +ansiCtree = buildTree $ [(s,True) | s <- reservedAnsiCSymbols] ++ + [(s,False) | s <- reservedAnsiCWords] + +reservedAnsiCSymbols = words $ + "<<= >>= << >> ++ -- == <= >= *= += -= %= /= &= ^= |= " ++ + "^ { } = , ; + * - ( ) < > & % ! ~" + +reservedAnsiCWords = words $ + "auto break case char const continue default " ++ + "do double else enum extern float for goto if int " ++ + "long register return short signed sizeof static struct switch typedef " ++ + "union unsigned void volatile while " ++ + "main printin putchar" --- these are not ansi-C + +-- turn unknown tokens into string literals; not recursively for literals 123, 'foo' + +unknown2string :: (String -> Bool) -> [CFTok] -> [CFTok] +unknown2string isKnown = map mkOne where + mkOne t@(TS s) = if isKnown s then t else mkTL s + mkOne t@(TC s) = if isKnown s then t else mkTL s + mkOne t = t + +lexTextLiteral isKnown = unknown2string isKnown . lexText +lexHaskellLiteral isKnown = unknown2string isKnown . lexHaskell + diff --git a/src/HelpFile.hs b/src/HelpFile.hs new file mode 100644 index 000000000..224535134 --- /dev/null +++ b/src/HelpFile.hs @@ -0,0 +1,376 @@ +module HelpFile where + +txtHelpFile = + "\n-- commands that change the state" ++ + "\n" ++ + "\ni, import: i File" ++ + "\n Reads a grammar from File and compiles it into a GF runtime grammar." ++ + "\n Files \"include\"d in File are read recursively, nubbing repetitions." ++ + "\n If a grammar with the same language name is already in the state," ++ + "\n it is overwritten - but only if compilation succeeds. " ++ + "\n The grammar parser depends on the file name suffix:" ++ + "\n .gf normal GF source " ++ + "\n .gfl LaTeX file with grammar in \\begGF..\\end{verbatim} environments" ++ + "\n .tex LaTeX file with grammar in \\begGF..\\end{verbatim} environments" ++ + "\n .gfc already optimized - skip compilation and type checking" ++ + "\n .gfhc already compiled (a Haskell data object)" ++ + "\n .ebnf EBNF format" ++ + "\n .cf Context-free format" ++ + "\n options:" ++ + "\n -v verbose: give lots of messages " ++ + "\n -s silent: don't give error messages" ++ + "\n -opt perform branch-sharing optimization" ++ + "\n -retain retain oper and lintype definitions" ++ + "\n -nocf don't build context-free grammar (thus no parser)" ++ + "\n -nocheckcirc don't eliminate circular rules from CF " ++ + "\n -nocirc do eliminate circ rules (default; currently just explicit ones)" ++ + "\n flags:" ++ + "\n -lang set the name used for the grammar in the session" ++ + "\n" ++ + "\nrl, remove language: rl Language" ++ + "\n Takes away the language from the state." ++ + "\n" ++ + "\ne, empty state: e" ++ + "\n Takes away all languages and resets all global flags." ++ + "\n" ++ + "\nsf, set flags: sf Language? Flag*" ++ + "\n The values of the Flags are set for Language. If no language" ++ + "\n is specified, the flags are set globally." ++ + "\n" ++ + "\n-- commands that give information about the state" ++ + "\n" ++ + "\npg, print grammar: pg" ++ + "\n Prints the actual grammar (overridden by the -lang=X flag)." ++ + "\n The -printer=X flag sets the format in which the grammar is" ++ + "\n written." ++ + "\n N.B. since grammars are compiled when imported, this command" ++ + "\n generally does not show the grammar in the same format as the" ++ + "\n source. In particular, the -printer=latex is not supported. " ++ + "\n Use the command tg -printer=latex File to print the source " ++ + "\n grammar in LaTeX." ++ + "\n options:" ++ + "\n -utf8 apply UTF8-encoding to the grammar" ++ + "\n" ++ + "\n flags: " ++ + "\n -printer" ++ + "\n -lang" ++ + "\n " ++ + "\n" ++ + "\npm, print multigrammar: pm" ++ + "\n Prints the current multilingual grammar into a Haskell file" ++ + "\n in a canonical format (usable by the canonical GF editor)." ++ + "\n options" ++ + "\n -opt perform branch-sharing optimization (should not have been done at import)" ++ + "\n" ++ + "\npo, print options: po" ++ + "\n Prints those flag values in the current state that differ from defaults." ++ + "\n" ++ + "\npl, print languages: pl" ++ + "\n Prints the names of currently available languages." ++ + "\n" ++ + "\n" ++ + "\n-- commands that execute and show the session history" ++ + "\n" ++ + "\neh, execute history: eh File" ++ + "\n Executes commands in the file." ++ + "\n" ++ + "\nph, print history; ph" ++ + "\n Prints the commands issued during the GF session." ++ + "\n The result is readable by the eh command." ++ + "\n HINT: write \"ph | wf foo.hist\" to save the history." ++ + "\n" ++ + "\n" ++ + "\n-- linearization, parsing, translation, and computation" ++ + "\n" ++ + "\nl, linearize: l PattList? Tree" ++ + "\n Shows all linearization forms of Tree by the actual grammar" ++ + "\n (which is overridden by the -lang flag). " ++ + "\n The pattern list has the form [P, ... ,Q] where P,...,Q follow GF " ++ + "\n syntax for patterns. All those forms are generated that match with the" ++ + "\n pattern list. Too short lists are filled with variables in the end." ++ + "\n Only the -table flag is available if a pattern list is specified." ++ + "\n HINT: see GF language specification for the syntax of Pattern and Term." ++ + "\n You can also copy and past parsing results." ++ + "\n options: " ++ + "\n -table show parameters" ++ + "\n -struct bracketed form" ++ + "\n -record record, i.e. explicit GF concrete syntax term" ++ + "\n flags:" ++ + "\n -lang linearize in this grammar" ++ + "\n -number give this number of forms at most" ++ + "\n -unlexer filter output through unlexer" ++ + "\n" ++ + "\np, parse: p String" ++ + "\n Shows all Trees returned for String by the actual" ++ + "\n grammar (overridden by the -lang flag), in the category S (overridden" ++ + "\n by the -cat flag)." ++ + "\n options:" ++ + "\n -n non-strict: tolerates morphological errors" ++ + "\n -ign ignore unknown words when parsing" ++ + "\n -raw return context-free terms in raw form" ++ + "\n -v verbose: give more information if parsing fails" ++ + "\n flags:" ++ + "\n -cat parse in this category" ++ + "\n -lang parse in this grammar" ++ + "\n -lexer filter input through this lexer" ++ + "\n -parser use this context-free parsing method" ++ + "\n -number return this many results at most" ++ + "\n" ++ + "\ntt, test tokenizer: tt String" ++ + "\n Show the token list sent to the parser when String is parsed." ++ + "\n HINT: can be useful when debugging the parser." ++ + "\n flags: " ++ + "\n -lexer use this lexer" ++ + "\n" ++ + "\ncc, compute concrete: cc Term" ++ + "\n Compute a term by concrete syntax definitions. " ++ + "\n N.B. You need the flag -retain when importing the grammar, if you want " ++ + "\n the oper definitions to be retained after compilation; otherwise this" ++ + "\n command does not expand oper constants." ++ + "\n N.B.' The resulting Term is not a term in the sense of abstract syntax," ++ + "\n and hence not a valid input to a Tree-demanding command." ++ + "\n flags:" ++ + "\n -lang" ++ + "\n" ++ + "\nt, translate: t Lang Lang String" ++ + "\n Parses String in Lang1 and linearizes the resulting Trees in Lang2." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n -lexer" ++ + "\n -parser" ++ + "\n" ++ + "\ngr, generate random: gr" ++ + "\n Generates a random Tree." ++ + "\n flags:" ++ + "\n -cat generate in this category" ++ + "\n -lang use the abstract syntax of this grammar" ++ + "\n -number generate this number of trees" ++ + "\n -depth use this number of search steps at most" ++ + "\n" ++ + "\nma, morphologically analyse: ma String" ++ + "\n Runs morphological analysis on each word in String and displays" ++ + "\n the results line by line." ++ + "\n options:" ++ + "\n -short show analyses in bracketed words, instead of separate lines" ++ + "\n flags:" ++ + "\n -lang" ++ + "\n" ++ + "\n" ++ + "\n-- elementary generation of Strings and Trees" ++ + "\n" ++ + "\nps, put string: ps String" ++ + "\n Returns its argument String, like Unix echo." ++ + "\n HINT. The strength of ps comes from the possibility to receive the argument" ++ + "\n from a pipeline, and altering it by the -filter flag." ++ + "\n flags:" ++ + "\n -filter filter the result through this string processor " ++ + "\n -length cut the string after this number of characters" ++ + "\n" ++ + "\npt, put tree: pt Tree" ++ + "\n Returns its argument Tree, like a specialized Unix echo." ++ + "\n HINT. The strength of pt comes from the possibility to receive the argument" ++ + "\n from a pipeline, and altering it by the -transform flag." ++ + "\n flags:" ++ + "\n -transform transform the result by this term processor" ++ + "\n -number generate this number of terms at most" ++ + "\n" ++ + "\nst, show tree: st Tree" ++ + "\n Prints the tree as a string. Unlike pt, this command cannot be" ++ + "\n used in a pipe to produce a tree, since its output is a string." ++ + "\n flags:" ++ + "\n -printer show the tree in a special format (-printer=xml supported)" ++ + "\n" ++ + "\nwt, wrap tree: wt Fun Tree" ++ + "\n Returns its argument Tree wrapped in the function Fun." ++ + "\n flags:" ++ + "\n -c compute the resulting tree" ++ + "\n" ++ + "\n" ++ + "\n-- subshells" ++ + "\n" ++ + "\nes, editing session: es" ++ + "\n Opens an interactive editing session." ++ + "\n N.B. Exit from a Fudget session is to the Unix shell, not to GF. " ++ + "\n options:" ++ + "\n -f Fudget GUI (necessary for Unicode; only available in X Window System)" ++ + "\n" ++ + "\nts, translation session: ts" ++ + "\n Translates input lines from any of the actual languages to any other one." ++ + "\n To exit, type a full stop (.) alone on a line." ++ + "\n N.B. Exit from a Fudget session is to the Unix shell, not to GF. " ++ + "\n HINT: Set -parser and -lexer locally in each grammar." ++ + "\n options:" ++ + "\n -f Fudget GUI (necessary for Unicode; only available in X Window System)" ++ + "\n flags:" ++ + "\n -cat" ++ + "\n" ++ + "\ntq, translation quiz: tq Lang Lang" ++ + "\n Random-generates translation exercises from Lang1 to Lang2," ++ + "\n keeping score of success." ++ + "\n To interrupt, type a full stop (.) alone on a line." ++ + "\n HINT: Set -parser and -lexer locally in each grammar." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n" ++ + "\ntl, translation list: tl Lang Lang Int" ++ + "\n Random-generates a list of Int translation exercises from Lang1 to Lang2." ++ + "\n HINT: use wf to save the exercises in a file." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n" ++ + "\nmq, morphology quiz: mq" ++ + "\n Random-generates morphological exercises," ++ + "\n keeping score of success." ++ + "\n To interrupt, type a full stop (.) alone on a line." ++ + "\n HINT: use printname judgements in your grammar to" ++ + "\n produce nice expressions for desired forms." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n -lang" ++ + "\n" ++ + "\nml, morphology list: tl Int" ++ + "\n Random-generates a list of Int morphological exercises," ++ + "\n keeping score of success." ++ + "\n HINT: use wf to save the exercises in a file." ++ + "\n flags:" ++ + "\n -cat" ++ + "\n -lang" ++ + "\n" ++ + "\n" ++ + "\n-- IO related commands" ++ + "\n" ++ + "\nrf, read file: rf File" ++ + "\n Returns the contents of File as a String; error is File does not exist." ++ + "\n" ++ + "\nwf, write file: wf File String" ++ + "\n Writes String into File; File is created if it does not exist." ++ + "\n N.B. the command overwrites File without a warning." ++ + "\n" ++ + "\naf, append file: af File" ++ + "\n Writes String into the end of File; File is created if it does not exist." ++ + "\n" ++ + "\ntg, transform grammar: tg File" ++ + "\n Reads File, parses as a grammar, but instead of compiling further, prints it. " ++ + "\n The environment is not changed. When parsing the grammar, the same file" ++ + "\n name suffixes are supported as in the i command." ++ + "\n HINT: use this command to print the grammar in another format (the -printer" ++ + "\n flag); pipe it to wf to save this format." ++ + "\n flags:" ++ + "\n -printer (only -printer=latex supported currently)" ++ + "\n" ++ + "\ncl, convert latex: cl File" ++ + "\n Reads File, which is expected to be in LaTeX form." ++ + "\n Two environments are treated in special ways:" ++ + "\n \\begGF - \\end{verbatim}, which contains GF judgements," ++ + "\n \\begTGF - \\end{verbatim}, which contains a GF expression (displayed), and" ++ + "\n \\begInTGF - \\end{verbatim}, which contains a GF expressions (inlined)." ++ + "\n Moreover, certain macros should be included in the file; you can" ++ + "\n get those macros by applying 'tg -printer=latex foo.gf' to any grammar" ++ + "\n foo.gf. Notice that the same File can be imported as a GF grammar," ++ + "\n consisting of all the judgements in \\begGF environments." ++ + "\n HINT: pipe with 'wf Foo.tex' to generate a new Latex file." ++ + "\n" ++ + "\nsa, speak aloud: sa String" ++ + "\n Uses the Festival speech generator to produce speech for String." ++ + "\n The command cupports Festival's language flag, which is sent verbatim" ++ + "\n to Festival, e.g. -language=spanish. Omitting this flag gives the " ++ + "\n system-dependent default voice (often British English)." ++ + "\n flags:" ++ + "\n -language" ++ + "\n" ++ + "\nh, help: h" ++ + "\n Displays this help message." ++ + "\n" ++ + "\nq, quit: q" ++ + "\n Exits GF." ++ + "\n HINT: you can use 'ph | wf history' to save your session." ++ + "\n" ++ + "\n!, system command: ! String" ++ + "\n Issues a system command. No value is returned to GF." ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n-- Flags. The availability of flags is defined separately for each command." ++ + "\n" ++ + "\n-cat: category in which parsing is performed." ++ + "\n The default is S." ++ + "\n" ++ + "\n-depth: the search depth in e.g. random generation." ++ + "\n The default depends on application." ++ + "\n" ++ + "\n-filter: operation performed on a string. The default is identity." ++ + "\n -filter=identity no change" ++ + "\n -filter=erase erase the text" ++ + "\n -filter=take100 show the first 100 characters" ++ + "\n -filter=length show the length of the string" ++ + "\n -filter=text format as text (punctuation, capitalization)" ++ + "\n -filter=code format as code (spacing, indentation)" ++ + "\n -filter=latexfile embed in a LaTeX file " ++ + "\n" ++ + "\n-lang: grammar used when executing a grammar-dependent command." ++ + "\n The default is the last-imported grammar." ++ + "\n" ++ + "\n-language: voice used by Festival as its --language flag in the sa command. " ++ + "\n The default is system-dependent. " ++ + "\n" ++ + "\n-length: the maximum number of characters shown of a string. " ++ + "\n The default is unlimited." ++ + "\n" ++ + "\n-lexer: tokenization transforming a string into lexical units for a parser." ++ + "\n The default is words." ++ + "\n -lexer=words tokens are separated by spaces or newlines" ++ + "\n -lexer=literals like words, but GF integer and string literals recognized" ++ + "\n -lexer=vars like words, but \"x\",\"x_...\",\"$...$\" as vars, \"?...\" as meta" ++ + "\n -lexer=chars each character is a token" ++ + "\n -lexer=code use Haskell's lex" ++ + "\n -lexer=text with conventions on punctuation and capital letters" ++ + "\n -lexer=codelit like code, but treat unknown words as string literals" ++ + "\n -lexer=textlit like text, but treat unknown words as string literals" ++ + "\n -lexer=codeC use a C-like lexer" ++ + "\n" ++ + "\n-number: the maximum number of generated items in a list. " ++ + "\n The default is unlimited." ++ + "\n" ++ + "\n-parser: Context-free parsing algorithm. The default is chart." ++ + "\n -parser=earley Earley algorithm" ++ + "\n -parser=chart bottom-up chart parser" ++ + "\n" ++ + "\n-printer: format in which the grammar is printed. The default is gf." ++ + "\n -printer=gf GF grammar" ++ + "\n -printer=cf context-free grammar" ++ + "\n -printer=resource resource grammar (cat+lincat, fun+lin --> oper)" ++ + "\n -printer=resourcetypes resource grammar type signatures" ++ + "\n -printer=resourcedefs resource grammar operation definitions" ++ + "\n -printer=happy source file for Happy parser generator" ++ + "\n -printer=srg speech recognition grammar" ++ + "\n -printer=canon grammar compiled into a canonical form, Haskell module" ++ + "\n -printer=canonOpt canonical form, with branch-sharing optimization" ++ + "\n -printer=gfhs compiled grammar as Haskell data object" ++ + "\n -printer=haskell abstract syntax in Haskell, with translations to/from GF" ++ + "\n -printer=morpho full-form lexicon, long format" ++ + "\n -printer=latex LaTeX file (for the tg command)" ++ + "\n -printer=fullform full-form lexicon, short format" ++ + "\n -printer=xml XML: DTD for the pg command, object for st" ++ + "\n" ++ + "\n-startcat: like -cat, but used in grammars (to avoid clash with the keyword cat)" ++ + "\n" ++ + "\n-transform: transformation performed on a syntax tree. The default is identity." ++ + "\n -transform=identity no change" ++ + "\n -transform=compute compute by using definitions in the grammar" ++ + "\n -transform=typecheck return the term only if it is type-correct" ++ + "\n -transform=solve solve metavariables as derived refinements" ++ + "\n -transform=context solve metavariables by unique refinements as variables" ++ + "\n -transform=delete replace the term by metavariable" ++ + "\n -transform=predcalc generating sentences from predicate calculus formulas" ++ + "\n" ++ + "\n-unlexer: untokenization transforming linearization output into a string." ++ + "\n The default is unwords." ++ + "\n -unlexer=unwords space-separated token list (like unwords)" ++ + "\n -unlexer=text format as text: punctuation, capitalization, paragraph

" ++ + "\n -unlexer=code format as code (spacing, indentation)" ++ + "\n -unlexer=textlit like text, but remove string literal quotes" ++ + "\n -unlexer=codelit like code, but remove string literal quotes" ++ + "\n -unlexer=concat remove all spaces" ++ + "\n -unlexer=bind like identity, but bind at \"&+\"" ++ + "\n" ++ + [] \ No newline at end of file diff --git a/src/JavaGUI/DynamicTree.java b/src/JavaGUI/DynamicTree.java new file mode 100644 index 000000000..6acc6ff64 --- /dev/null +++ b/src/JavaGUI/DynamicTree.java @@ -0,0 +1,272 @@ + +/* + * This code is based on an example provided by Richard Stanford, + * a tutorial reader. + */ + +import java.awt.*; +import javax.swing.*; +import javax.swing.tree.*; +import javax.swing.event.*; +import java.util.Vector; +import java.awt.event.*; + +public class DynamicTree extends JPanel implements KeyListener, + ActionListener{ + public static DefaultMutableTreeNode rootNode; + protected DefaultTreeModel treeModel; + public JTree tree; + public int oldSelection = 0; + private Toolkit toolkit = Toolkit.getDefaultToolkit(); + JPopupMenu popup = new JPopupMenu(); + JMenuItem menuItem; + Timer timer = new Timer(500, this); + MouseEvent m; + + public DynamicTree() { + timer.setRepeats(false); + rootNode = new DefaultMutableTreeNode("Root Node"); + treeModel = new DefaultTreeModel(rootNode); + treeModel.addTreeModelListener(new MyTreeModelListener()); + + tree = new JTree(treeModel); + tree.setRootVisible(false); + tree.setEditable(false); + tree.getSelectionModel().setSelectionMode + (TreeSelectionModel.SINGLE_TREE_SELECTION); + tree.addKeyListener(this); + menuItem = new JMenuItem("Paste"); + menuItem.addActionListener(this); + popup.add(menuItem); + + //Add listener to components that can bring up popup menus. + MouseListener popupListener = new PopupListener(); + tree.addMouseListener(popupListener); + + tree.addTreeSelectionListener(new TreeSelectionListener() { + public void valueChanged(TreeSelectionEvent e) { + if (tree.getSelectionRows()!=null) { + if (GFEditor.nodeTable == null) + {if (GFEditor.debug) System.out.println("null node table");} + else + {if (GFEditor.debug) System.out.println("node table: "+ + GFEditor.nodeTable.contains(new Integer(0)) +" "+ + GFEditor.nodeTable.keys().nextElement()); } + if (tree.getSelectionPath() == null) + {if (GFEditor.debug) System.out.println("null root path"); } + else + {if (GFEditor.debug) System.out.println("selected path"+ + tree.getSelectionPath());} + int i = ((Integer)GFEditor.nodeTable.get( + tree.getSelectionPath())).intValue(); + int j = oldSelection; + GFEditor.treeChanged = true; + if (i>j) GFEditor.send("> "+String.valueOf(i-j)); + else GFEditor.send("< "+String.valueOf(j-i)); + } + } + }); + + tree.setCellRenderer(new MyRenderer()); + tree.setShowsRootHandles(true); + setPreferredSize(new Dimension(200, 100)); + JScrollPane scrollPane = new JScrollPane(tree); + setLayout(new GridLayout(1,0)); + add(scrollPane); + } + + /** Remove all nodes except the root node. */ + public void clear() { + rootNode.removeAllChildren(); + treeModel.reload(); + } + + /** Remove the currently selected node. */ + public void removeCurrentNode() { + TreePath currentSelection = tree.getSelectionPath(); + if (currentSelection != null) { + DefaultMutableTreeNode currentNode = (DefaultMutableTreeNode) + (currentSelection.getLastPathComponent()); + MutableTreeNode parent = (MutableTreeNode)(currentNode.getParent()); + if (parent != null) { + treeModel.removeNodeFromParent(currentNode); + return; + } + } + + // Either there was no selection, or the root was selected. + toolkit.beep(); + } + + /** Add child to the currently selected node. */ + public DefaultMutableTreeNode addObject(Object child) { + DefaultMutableTreeNode parentNode = null; + TreePath parentPath = tree.getSelectionPath(); + + if (parentPath == null) { + parentNode = rootNode; + } else { + parentNode = (DefaultMutableTreeNode) + (parentPath.getLastPathComponent()); + } + + return addObject(parentNode, child, true); + } + + public DefaultMutableTreeNode addObject(DefaultMutableTreeNode parent, + Object child) { + return addObject(parent, child, false); + } + + public DefaultMutableTreeNode addObject(DefaultMutableTreeNode parent, + Object child, + boolean shouldBeVisible) { + DefaultMutableTreeNode childNode = + new DefaultMutableTreeNode(child); + + if (parent == null) { + parent = rootNode; + } + + treeModel.insertNodeInto(childNode, parent, + parent.getChildCount()); + + // Make sure the user can see the lovely new node. + if (shouldBeVisible) { + tree.scrollPathToVisible(new TreePath(childNode.getPath())); + } + return childNode; + } + + class MyTreeModelListener implements TreeModelListener { + public void treeNodesChanged(TreeModelEvent e) { + DefaultMutableTreeNode node; + node = (DefaultMutableTreeNode) + (e.getTreePath().getLastPathComponent()); + + /* + * If the event lists children, then the changed + * node is the child of the node we've already + * gotten. Otherwise, the changed node and the + * specified node are the same. + */ + try { + int index = e.getChildIndices()[0]; + node = (DefaultMutableTreeNode) + (node.getChildAt(index)); + } catch (NullPointerException exc) {} + + if (GFEditor.debug) System.out.println + ("The user has finished editing the node."); + if (GFEditor.debug) System.out.println( + "New value: " + node.getUserObject()); + } + public void treeNodesInserted(TreeModelEvent e) { + } + public void treeNodesRemoved(TreeModelEvent e) { + } + public void treeStructureChanged(TreeModelEvent e) { + } + } + + private class MyRenderer extends DefaultTreeCellRenderer { + ImageIcon tutorialIcon; + + public MyRenderer() { + tutorialIcon = new ImageIcon("images/middle.gif"); + } + + public Component getTreeCellRendererComponent( + JTree tree, + Object value, + boolean sel, + boolean expanded, + boolean leaf, + int row, + boolean hasFocus) { + + super.getTreeCellRendererComponent( + tree, value, sel, + expanded, leaf, row, + hasFocus); + if (leaf && isTutorialBook(value)) + setIcon(tutorialIcon); + + return this; + } + protected boolean isTutorialBook(Object value) { + DefaultMutableTreeNode node = + (DefaultMutableTreeNode)value; + String nodeInfo = + (String)(node.getUserObject()); + + if (nodeInfo.indexOf("?") >= 0) { + return true; + } + + return false; + } + + }//class + + class PopupListener extends MouseAdapter { + public void mousePressed(MouseEvent e) { + int selRow = tree.getRowForLocation(e.getX(), e.getY()); + tree.setSelectionRow(selRow); + if (GFEditor.debug) System.out.println("selection changed!"); + maybeShowPopup(e); + } + + public void mouseReleased(MouseEvent e) { + if (GFEditor.debug) System.out.println("mouse released!"); + maybeShowPopup(e); + } + } + void maybeShowPopup(MouseEvent e) { + if (GFEditor.debug) System.out.println("may be!"); + if (e.isPopupTrigger()) { + m=e; + timer.start(); + } + } + void addMenuItem(String name){ + menuItem = new JMenuItem(name); + menuItem.addActionListener(this); + popup.add(menuItem); + + } + + public void actionPerformed(ActionEvent ae) + { + if (ae.getSource()==timer){ + if (GFEditor.debug) System.out.println("changing menu!"); + popup.removeAll(); + for (int i = 0; i"); + private JButton rightMeta = new JButton(">?"); + private JButton read = new JButton("Read"); + // private JButton parse = new JButton("Parse"); + // private JButton term = new JButton("Term"); + private JButton alpha = new JButton("Alpha"); + private JButton random = new JButton("Random"); + private JButton undo = new JButton("Undo"); + + private JPanel inputPanel = new JPanel(); + private JPanel inputPanel2 = new JPanel(); + private JPanel inputPanel3 = new JPanel(); + private JButton ok = new JButton("OK"); + private JButton cancel = new JButton("Cancel"); + private JTextField inputField = new JTextField(); + private JLabel inputLabel = new JLabel("Read: "); + private JButton browse = new JButton("Browse..."); + private ButtonGroup readGroup = new ButtonGroup(); + private JRadioButton termReadButton = new JRadioButton("Term"); + private JRadioButton stringReadButton = new JRadioButton("String"); + + private JDialog dialog; + + private static JComboBox menu = new JComboBox(newMenu); + private JComboBox filter = new JComboBox(filterMenu); + private JComboBox modify = new JComboBox(modifyMenu); + // private JComboBox mode = new JComboBox(modeMenu); + + private JPanel downPanel = new JPanel(); + private JSplitPane treePanel; + private JPanel upPanel = new JPanel(); + private JPanel middlePanel = new JPanel(); + private JPanel middlePanelUp = new JPanel(); + private JPanel middlePanelDown = new JPanel(); + private JSplitPane centerPanel; + private static JFrame gui2 = new JFrame(); + private JPanel centerPanel2= new JPanel(); + private JPanel centerPanelDown = new JPanel(); + private JScrollPane outputPanelDown = new JScrollPane(list); + private JScrollPane outputPanelCenter = new JScrollPane(output); + private JPanel outputPanelUp = new JPanel(); + private JPanel statusPanel = new JPanel(); + private static JLabel statusLabel = new JLabel(status); + private Container cp; + + private static JMenuBar menuBar= new JMenuBar();; + private static ButtonGroup menuGroup = new ButtonGroup(); + private JMenu viewMenu= new JMenu("View"); + private JMenu submenu= new JMenu("language"); + private JMenu modeMenu= new JMenu("Menus"); + private static JMenu langMenu= new JMenu("Languages"); + private static JMenu fileMenu= new JMenu("File"); + private JRadioButtonMenuItem rbMenuItem; + private JRadioButtonMenuItem rbMenuItemLong; + // private JRadioButtonMenuItem rbMenuItemAbs; + private JRadioButtonMenuItem rbMenuItemUnTyped; + private static JMenuItem fileMenuItem; + private static JCheckBoxMenuItem cbMenuItem; + private static RadioListener myListener ; + private static ButtonGroup group = new ButtonGroup(); + private static ButtonGroup languageGroup = new ButtonGroup(); + + public GFEditor() + { + this.addWindowListener(new WindowAdapter() { + public void windowClosing(WindowEvent e) { + endProgram(); + } + }); + setJMenuBar(menuBar); + setTitle("GF Syntax Editor"); + viewMenu.setToolTipText("View settings"); + fileMenu.setToolTipText("Main operations"); + langMenu.setToolTipText("Language settings"); + menuBar.add(fileMenu); + menuBar.add(langMenu); + menuBar.add(viewMenu); + menuBar.add(modeMenu); + + cbMenuItem = new JCheckBoxMenuItem("Tree"); + cbMenuItem.setActionCommand("showTree"); + myListener = new RadioListener(); + cbMenuItem.addActionListener(myListener); + cbMenuItem.setSelected(true); + viewMenu.add(cbMenuItem); + viewMenu.addSeparator(); + + fileMenuItem = new JMenuItem("Open..."); + fileMenuItem.setActionCommand("open"); + fileMenuItem.addActionListener(this); + fileMenu.add(fileMenuItem); + fileMenuItem = new JMenuItem("New Topic..."); + fileMenuItem.setActionCommand("newTopic"); + fileMenuItem.addActionListener(this); + fileMenu.add(fileMenuItem); + fileMenuItem = new JMenuItem("Reset"); + fileMenuItem.setActionCommand("reset"); + fileMenuItem.addActionListener(this); + fileMenu.add(fileMenuItem); + fileMenuItem = new JMenuItem("Save As..."); + fileMenuItem.setActionCommand("save"); + fileMenuItem.addActionListener(this); + fileMenu.add(fileMenuItem); + fileMenu.addSeparator(); + fileMenuItem = new JMenuItem("Exit"); + fileMenuItem.setActionCommand("quit"); + fileMenuItem.addActionListener(this); + fileMenu.add(fileMenuItem); + + rbMenuItem = new JRadioButtonMenuItem("One window"); + rbMenuItem.setActionCommand("combine"); + rbMenuItem.addActionListener(myListener); + rbMenuItem.setSelected(true); +/* rbMenuItem.setMnemonic(KeyEvent.VK_R); + rbMenuItem.setAccelerator(KeyStroke.getKeyStroke( + KeyEvent.VK_1, ActionEvent.ALT_MASK)); + rbMenuItem.getAccessibleContext().setAccessibleDescription( + "This doesn't really do anything"); +*/ + menuGroup.add(rbMenuItem); + viewMenu.add(rbMenuItem); + + rbMenuItem = new JRadioButtonMenuItem("Split windows"); + rbMenuItem.setMnemonic(KeyEvent.VK_O); + rbMenuItem.setActionCommand("split"); + rbMenuItem.addActionListener(myListener); + menuGroup.add(rbMenuItem); + viewMenu.add(rbMenuItem); + + modeMenu.add(submenu); + + /* rbMenuItemAbs = new JRadioButtonMenuItem("Abstract"); + rbMenuItemAbs.setActionCommand("Abstract"); + rbMenuItemAbs.addActionListener(myListener); + languageGroup.add(rbMenuItemAbs); + */ + + modeMenu.addSeparator(); + menuGroup = new ButtonGroup(); + rbMenuItemLong = new JRadioButtonMenuItem("long"); + rbMenuItemLong.setActionCommand("long"); + rbMenuItemLong.setSelected(true); + rbMenuItemLong.addActionListener(myListener); + menuGroup.add(rbMenuItemLong); + modeMenu.add(rbMenuItemLong); + rbMenuItem = new JRadioButtonMenuItem("short"); + rbMenuItem.setActionCommand("short"); + rbMenuItem.addActionListener(myListener); + menuGroup.add(rbMenuItem); + modeMenu.add(rbMenuItem); + modeMenu.addSeparator(); + + menuGroup = new ButtonGroup(); + rbMenuItem = new JRadioButtonMenuItem("typed"); + rbMenuItem.setActionCommand("typed"); + rbMenuItem.addActionListener(myListener); + rbMenuItem.setSelected(false); + menuGroup.add(rbMenuItem); + modeMenu.add(rbMenuItem); + rbMenuItemUnTyped = new JRadioButtonMenuItem("untyped"); + rbMenuItemUnTyped.setSelected(true); + rbMenuItemUnTyped.setActionCommand("untyped"); + rbMenuItemUnTyped.addActionListener(myListener); + menuGroup.add(rbMenuItemUnTyped); + modeMenu.add(rbMenuItemUnTyped); + + cp = getContentPane(); + cp.setLayout(new BorderLayout()); + output.setToolTipText("Linearizations' display area"); + output.setEditable(false); + output.setLineWrap(true); + output.setWrapStyleWord(true); +// output.setSelectionColor(Color.green); + output.setSelectionColor(Color.white); +// output.setFont(new Font("Arial Unicode MS", Font.PLAIN, 17)); + output.setFont(new Font(null, Font.PLAIN, 17)); +// System.out.println(output.getFont().getFontName()); + gfCommand.setToolTipText("Sending a command to GF"); + read.setToolTipText("Refining with term or linearization from typed string or file"); + modify.setToolTipText("Choosing a linearization method"); + alpha.setToolTipText("Performing alpha-conversion"); + random.setToolTipText("Generating random refinement"); + undo.setToolTipText("Going back to the previous state"); + downPanel.add(gfCommand); + //downPanel.add(parse); + //downPanel.add(term); + downPanel.add(read); + downPanel.add(modify); + downPanel.add(alpha); + downPanel.add(random); + downPanel.add(undo); + + leftMeta.setToolTipText("Moving the focus to the previous metavariable"); + rightMeta.setToolTipText("Moving the focus to the next metavariable"); + left.setToolTipText("Moving the focus to the previous term"); + right.setToolTipText("Moving the focus to the next term"); + top.setToolTipText("Moving the focus to the top term"); + middlePanelUp.add(leftMeta); + middlePanelUp.add(left); + middlePanelUp.add(top); + middlePanelUp.add(right); + middlePanelUp.add(rightMeta); + middlePanelDown.add(new JLabel("Select Action on Subterm")); + middlePanel.setLayout(new BorderLayout()); + middlePanel.add(middlePanelUp, BorderLayout.NORTH); + middlePanel.add(middlePanelDown, BorderLayout.CENTER); + + menu.setToolTipText("The list of available categories to start editing"); + open.setToolTipText("Reading both a new environment and an editing object from file. Current editing will be discarded"); + save.setToolTipText("Writing the current editing object to file in the term or text format"); + grammar.setToolTipText("Current Topic"); + newTopic.setToolTipText("Reading a new environment from file. Current editing will be discarded."); + upPanel.add(grammar); + upPanel.add(menu); + upPanel.add(open); + upPanel.add(save); + upPanel.add(newTopic); + + filter.setToolTipText("Choosing the linearization representation format"); + modeMenu.setToolTipText("Choosing the refinement options' representation"); + statusLabel.setToolTipText("The current focus type"); + list.setToolTipText("The list of current refinment options"); + tree.setToolTipText("The abstract syntax tree representation of the current editing object"); + upPanel.add(filter); + //upPanel.add(mode); + populateTree(tree); + outputPanelUp.setLayout(new BorderLayout()); + outputPanelUp.add(outputPanelCenter, BorderLayout.CENTER); + outputPanelUp.add(statusPanel, BorderLayout.SOUTH); + statusPanel.setLayout(new GridLayout(1,1)); + statusPanel.add(statusLabel); + treePanel = new JSplitPane(JSplitPane.HORIZONTAL_SPLIT, + tree, outputPanelUp); + treePanel.setDividerSize(5); + treePanel.setDividerLocation(100); + centerPanel2.setLayout(new BorderLayout()); + gui2.setSize(350,150); + gui2.setTitle("Select Action on Subterm"); + gui2.setLocationRelativeTo(treePanel); + centerPanelDown.setLayout(new BorderLayout()); + centerPanel = new JSplitPane(JSplitPane.VERTICAL_SPLIT, + treePanel, centerPanelDown); + centerPanel.addKeyListener(tree); + centerPanel.setOneTouchExpandable(true); + centerPanelDown.add(middlePanel, BorderLayout.NORTH); + centerPanelDown.add(outputPanelDown, BorderLayout.CENTER); + cp.add(centerPanel, BorderLayout.CENTER); + cp.add(upPanel, BorderLayout.NORTH); + cp.add(downPanel, BorderLayout.SOUTH); + + list.setSelectionMode(ListSelectionModel.SINGLE_SELECTION); + + MouseListener mouseListener = new MouseAdapter() { + public void mouseClicked(MouseEvent e) { + if (e.getClickCount() == 2) { + listAction(list.locationToIndex(e.getPoint())); + } + } + }; + list.addMouseListener(mouseListener); + list.addKeyListener(this); + menu.addActionListener(this); + save.addActionListener(this); + open.addActionListener(this); + newTopic.addActionListener(this); + gfCommand.addActionListener(this); + + filter.addActionListener(this); + filter.setMaximumRowCount(9); + leftMeta.addActionListener(this); + left.addActionListener(this); + + menu.setFocusable(false); + save.setFocusable(false); + save.setActionCommand("save"); + open.setFocusable(false); + open.setActionCommand("open"); + newTopic.setFocusable(false); + newTopic.setActionCommand("newTopic"); + gfCommand.setFocusable(false); + + filter.setFocusable(false); + leftMeta.setFocusable(false); + left.setFocusable(false); + + top.addActionListener(this); + right.addActionListener(this); + rightMeta.addActionListener(this); + //parse.addActionListener(this); + //term.addActionListener(this); + read.addActionListener(this); + modify.addActionListener(this); + //mode.addActionListener(this); + alpha.addActionListener(this); + random.addActionListener(this); + undo.addActionListener(this); + + top.setFocusable(false); + right.setFocusable(false); + rightMeta.setFocusable(false); + //parse.setFocusable(false); + //term.setFocusable(false); + read.setFocusable(false); + modify.setFocusable(false); + //mode.setFocusable(false); + alpha.setFocusable(false); + random.setFocusable(false); + undo.setFocusable(false); + + output.addKeyListener(tree); + setSize(800,730); + outputPanelUp.setPreferredSize(new Dimension(500,300)); + treePanel.setDividerLocation(0.3); + nodeTable.put(new TreePath(DynamicTree.rootNode.getPath()), new Integer(0)); + setVisible(true); + + JRadioButton termButton = new JRadioButton("Term"); + termButton.setActionCommand("term"); + termButton.setSelected(true); + JRadioButton linButton = new JRadioButton("Text"); + linButton.setActionCommand("lin"); + // Group the radio buttons. + group.add(linButton); + group.add(termButton); + JPanel buttonPanel = new JPanel(); + buttonPanel.setPreferredSize(new Dimension(70, 70)); + buttonPanel.add(new JLabel("Format:")); + buttonPanel.add(linButton); + buttonPanel.add(termButton); + fc1.setAccessory(buttonPanel); + + termReadButton.setActionCommand("term"); + stringReadButton.setSelected(true); + stringReadButton.setActionCommand("lin"); + // Group the radio buttons. + readGroup.add(stringReadButton); + readGroup.add(termReadButton); + JPanel readButtonPanel = new JPanel(); + readButtonPanel.setLayout(new GridLayout(3,1)); + readButtonPanel.setPreferredSize(new Dimension(70, 70)); + readButtonPanel.add(new JLabel("Format:")); + readButtonPanel.add(stringReadButton); + readButtonPanel.add(termReadButton); + dialog= new JDialog(this, "Input"); + dialog.setLocationRelativeTo(this); + dialog.getContentPane().add(inputPanel); + inputPanel.setLayout(new BorderLayout(10,10)); + inputPanel3.setLayout(new GridLayout(2,1,5,5)); + inputPanel3.add(inputLabel); + inputPanel3.add(inputField); + ok.addActionListener(this); + browse.addActionListener(this); + cancel.addActionListener(this); + inputField.setPreferredSize(new Dimension(300,23)); + inputPanel.add(inputPanel3, BorderLayout.CENTER); + inputPanel.add(new JLabel(" "), BorderLayout.WEST); + inputPanel.add(readButtonPanel, BorderLayout.EAST); + inputPanel.add(inputPanel2, BorderLayout.SOUTH); + inputPanel2.add(ok); + inputPanel2.add(cancel); + inputPanel2.add(browse); + dialog.setSize(350,135); + + try { + result = fromProc.readLine(); + while(result != null) { + finished = false; + if (debug) System.out.println("1 "+result); + while (result.indexOf("gf")==-1){ + outputString +=result+"\n"; + result = fromProc.readLine(); + if (debug) System.out.println("1 "+result); + } + output.append(outputString); + while ((result.indexOf("newcat")==-1)&&(result.indexOf("8) + s+=result.trim(); + else + s+=result; + } + } +// if (s.charAt(0)!='d') +// listModel.addElement("Refine " + s); +// else + listModel.addElement(s); + s=""; + //read /show + //read send + result = fromProc.readLine(); + if (debug) System.out.println("8 "+result); + result = fromProc.readLine(); + if (debug) System.out.println("8 "+result); + saveCommand(); + // read /item + result = fromProc.readLine(); + if (debug) System.out.println("8 "+result); + result = fromProc.readLine(); + if (debug) System.out.println("8 "+result); + } + } catch(IOException e){ } + } + + public static void saveCommand(){ + if (newObject) commands.add(result); + try { + result = fromProc.readLine(); + if (debug) System.out.println("9 "+result); + } catch(IOException e){ } + } + + public void readLin(){ + try { + linearization=""; + linearization += result+"\n"; + result = fromProc.readLine(); + if (debug) System.out.println("6 "+result); + while (result.indexOf("/linearization")==-1){ + linearization += result+"\n"; + result = fromProc.readLine(); + if (debug) System.out.println("6 "+result); + } + if (newObject) formLin(); + result = fromProc.readLine(); + if (debug) System.out.println("6 "+result); + } catch(IOException e){ } + } + + public static void readTree(){ + try { + result = fromProc.readLine(); + if (debug) System.out.println("6 "+result); + while (result.indexOf("/tree")==-1){ + treeString += result+"\n"; + result = fromProc.readLine(); + if (debug) System.out.println("6 "+result); + } + if (treeChanged && (newObject)) { + formTree(tree); + treeChanged = false; + } + treeString=""; + result = fromProc.readLine(); + if (debug) System.out.println("6 "+result); + } catch(IOException e){ } + } + + public static void readMessage(){ + String s =""; + try { + result = fromProc.readLine(); + if (debug) System.out.println("7 "+result); + while (result.indexOf("/message")==-1){ + s += result+"\n"; + result = fromProc.readLine(); + if (debug) System.out.println("7 "+result); + } + if (s.length()>1) + output.append("-------------"+'\n'+s); + result = fromProc.readLine(); + if (debug) System.out.println("7 "+result); + } catch(IOException e){ } + } + + public void formNewMenu () { + boolean more = true; + try { + result = fromProc.readLine(); + if (debug) System.out.println("2 "+result); + + while (more){ + if (result.indexOf("language")==-1) { + menu.addItem(result.substring(6)); + } + else + more = false; + result = fromProc.readLine(); + if (debug) System.out.println("2 "+result); + result = fromProc.readLine(); + if (debug) System.out.println("3 "+result); + if (result.indexOf("language")!=-1) + more = false; + result = fromProc.readLine(); + if (debug) System.out.println("4 "+result); + } + + more = true; + while (more){ + if ((result.indexOf("/gf")==-1)&&(result.indexOf("lin")==-1)) { + //form lang and Menu menu: + cbMenuItem = new JCheckBoxMenuItem(result.substring(4)); + if (debug) System.out.println ("menu item: "+result.substring(4)); + cbMenuItem.setSelected(true); + cbMenuItem.setActionCommand("lang"); + cbMenuItem.addActionListener(myListener); + langMenu.add(cbMenuItem); +/* if ((result.substring(4)).equals("Abstract")) + { + submenu.add(rbMenuItemAbs); + if (selectedMenuLanguage.equals("Abstract")) + rbMenuItemAbs.setSelected(true); + languageGroup.add(rbMenuItemAbs); + } + else + { +*/ + rbMenuItem = new JRadioButtonMenuItem(result.substring(4)); + rbMenuItem.setActionCommand(result.substring(4)); + rbMenuItem.addActionListener(myListener); + languageGroup.add(rbMenuItem); + if ((result.substring(4)).equals(selectedMenuLanguage)) + { + System.out.println("Selecting "+selectedMenuLanguage); + rbMenuItem.setSelected(true); + } + + submenu.add(rbMenuItem); +// } + } + else + more = false; + // read + result = fromProc.readLine(); + if (debug) System.out.println("2 "+result); + // read or + result = fromProc.readLine(); + if (debug) System.out.println("3 "+result); + if ((result.indexOf("/gf")!=-1)||(result.indexOf("lin")!=-1)) + more = false; + if (result.indexOf("/gf")!=-1) + finished = true; + // registering the file name: + if (result.indexOf("language")!=-1) { + String path = result.substring(result.indexOf('=')+1, + result.indexOf('>')); + path =path.substring(path.lastIndexOf('/')+1); + if (debug) System.out.println("name: "+path); + fileString +="--" + path +"\n"; + if (path.lastIndexOf('.')!=path.indexOf('.')) + grammar.setText(path.substring(0, + path.indexOf('.')).toUpperCase()+" "); + } + result = fromProc.readLine(); + if (debug) System.out.println("4 "+result); + } + System.out.println("languageGroupElement formed"+ + languageGroup.getButtonCount()); + langMenu.addSeparator(); + fileMenuItem = new JMenuItem("Add..."); + fileMenuItem.setActionCommand("import"); + fileMenuItem.addActionListener(this); + langMenu.add(fileMenuItem); + // in order to get back in main in the beggining of while: + result = fromProc.readLine(); + } catch(IOException e){ } + } + + public void outputAppend(){ + int i, j, k, l, l2, m; + i=result.indexOf("type="); + j=result.indexOf('>',i); + l = result.indexOf(" + result= result.substring(0,l)+result.substring(j+1); + i=result.indexOf("/f",l); +System.out.println("/ is at the position"+i); + j=result.indexOf('>',i); + k=result.length()-j; + if (debug) System.out.println("form Lin2: "+result); + m = output.getText().length(); + + //cutting + // in case focus tag is cut into two lines: + if (debug) + System.out.println("char at the previous position"+result.charAt(i-1)); + if (result.charAt(i-1)!='<') + result= result.substring(0,i-8)+result.substring(j+1); + else + result= result.substring(0,i-1)+result.substring(j+1); + j= result.indexOf("'); + String s = result.substring(ind+1,ind2); + result = lin.substring(0,lin.indexOf("")); + lin = lin.substring(lin.indexOf("")); + while (lin.length()>1) { + //check if the language is on + if (!visible) visible = true; + // in the list? + for (int i=0; i + lin = lin.substring(lin.indexOf('\n')+1); + // read lin or 'end' + if (lin.length()<1) break; + + result = lin.substring(0,lin.indexOf('\n')); + lin = lin.substring(lin.indexOf('\n')+1); + if (result.indexOf("'); + s = result.substring(ind+1,ind2); + result = lin.substring(0,lin.indexOf("")); + lin = lin.substring(lin.indexOf("")); + } + } + } + + public void actionPerformed(ActionEvent ae) + { + boolean abs = true; + Object obj = ae.getSource(); + if ( obj == menu ) { + if (!menu.getSelectedItem().equals("New")) + { + treeChanged = true; + send("n " + menu.getSelectedItem()); + newObject = true; + menu.setSelectedIndex(0); + } + } + if ( obj == filter ) { + if (!filter.getSelectedItem().equals("Filter")) + { + send("f " + filter.getSelectedItem()); + filter.setSelectedIndex(0); + } + } + if ( obj == modify ) { + if (!modify.getSelectedItem().equals("Modify")) + { + treeChanged = true; + send("c " + modify.getSelectedItem()); + modify.setSelectedIndex(0); + } + } +/* if ( obj == mode ) { + if (!mode.getSelectedItem().equals("Menus")) + { + send("o " + mode.getSelectedItem()); + mode.setSelectedIndex(0); + } + } +*/ + // buttons and menu items: + try { + if (Class.forName("javax.swing.AbstractButton").isInstance(obj)) { + String name =((AbstractButton)obj).getActionCommand(); + + if ( name.equals("quit")) { + endProgram(); + } + + if ( name.equals("save") ) { + + if (fc1.getChoosableFileFilters().length<2) + fc1.addChoosableFileFilter(new GrammarFilter()); + int returnVal = fc1.showSaveDialog(GFEditor.this); + if (returnVal == JFileChooser.APPROVE_OPTION) { + File file = fc1.getSelectedFile(); + if (debug) System.out.println("saving ... "); + + // checking if the abstract syntax is on: + for (int i=0; i0) + { + for (Enumeration e = languageGroup.getElements(); + e.hasMoreElements() ;) + { + ab = (AbstractButton)e.nextElement(); + System.out.println("more to remove ! "+ab.getText()); + languageGroup.remove(ab); + } + System.out.println("languageGroupElement after import removal "+ + languageGroup.getButtonCount()); + } + submenu.removeAll(); + + File file = fc1.getSelectedFile(); + // opening the file for editing : + if (debug) System.out.println("opening: "+ file.getPath().replace('\\','/')); + if (group.getSelection().getActionCommand().equals("term")) { + if (debug) System.out.println(" opening as a term "); + send("open "+ file.getPath().replace('\\','/')); + } + else { + if (debug) System.out.println(" opening as a linearization "); + send("openstring "+ file.getPath().replace('\\','/')); + } + + fileString =""; + grammar.setText("No Topic "); + } + } + + if ( name.equals("import") ) { + if (fc.getChoosableFileFilters().length<2) + fc.addChoosableFileFilter(new GrammarFilter()); + int returnVal = fc.showOpenDialog(GFEditor.this); + if (returnVal == JFileChooser.APPROVE_OPTION) { + File file = fc.getSelectedFile(); + // importing a new language : + if (debug) System.out.println("importing: "+ file.getPath()); + + langMenu.removeAll(); + + AbstractButton ab = null; + + while (languageGroup.getButtonCount()>0) + { + for (Enumeration e = languageGroup.getElements(); + e.hasMoreElements() ;) + { + ab = (AbstractButton)e.nextElement(); + System.out.println("more to remove ! "+ab.getText()); + languageGroup.remove(ab); + } + System.out.println("languageGroupElement after import removal "+ + languageGroup.getButtonCount()); + } + + submenu.removeAll(); + + menu.removeAllItems(); + menu.addItem("New"); + fileString =""; + send("i "+ file.getPath().replace('\\','/')); + + } + } + if ( name.equals("newTopic") ) { + if (fc.getChoosableFileFilters().length<2) + fc.addChoosableFileFilter(new GrammarFilter()); + int returnVal = fc.showOpenDialog(GFEditor.this); + if (returnVal == JFileChooser.APPROVE_OPTION) { + int n = JOptionPane.showConfirmDialog(this, + "This will dismiss the previous editing. Would you like to continue?", + "Starting a new topic", JOptionPane.YES_NO_OPTION); + if (n == JOptionPane.YES_OPTION){ + File file = fc.getSelectedFile(); + // importing a new grammar : + newObject = false; + statusLabel.setText(status); + listModel.clear(); + tree.clear(); + populateTree(tree); + menu.removeAllItems(); + menu.addItem("New"); + langMenu.removeAll(); + + AbstractButton ab = null; + + while (languageGroup.getButtonCount()>0) + { + for (Enumeration e = languageGroup.getElements(); + e.hasMoreElements() ;) + { + ab = (AbstractButton)e.nextElement(); + System.out.println("more to remove ! "+ab.getText()); + languageGroup.remove(ab); + } + System.out.println("languageGroupElement after import removal "+ + languageGroup.getButtonCount()); + } + + selectedMenuLanguage = "Abstract"; + rbMenuItemLong.setSelected(true); + rbMenuItemUnTyped.setSelected(true); + submenu.removeAll(); + + fileString=""; + grammar.setText("No Topic "); + send("e "+ file.getPath().replace('\\','/')); + } + } + } + + if ( obj == gfCommand ){ + String s = JOptionPane.showInputDialog("Command:", parseInput); + if (s!=null) { + parseInput = s; + s = "gf "+s; + //treeChanged = true; + send(s); + } + } + + if ( name.equals("reset") ) { + newObject = false; + statusLabel.setText(status); + listModel.clear(); + tree.clear(); + populateTree(tree); + menu.removeAllItems(); + menu.addItem("New"); + langMenu.removeAll(); + + AbstractButton ab = null; + + while (languageGroup.getButtonCount()>0) + { + for (Enumeration e = languageGroup.getElements(); + e.hasMoreElements() ;) + { + ab = (AbstractButton)e.nextElement(); + System.out.println("more to remove ! "+ab.getText()); + languageGroup.remove(ab); + } + System.out.println("languageGroupElement after import removal "+ + languageGroup.getButtonCount()); + } + + selectedMenuLanguage = "Abstract"; + + submenu.removeAll(); + rbMenuItemLong.setSelected(true); + rbMenuItemUnTyped.setSelected(true); + + fileString=""; + grammar.setText("No Topic "); + send("e"); + } + + if ( obj == leftMeta ) { + treeChanged = true; + send("<<"); + } + if ( obj == left ) { + treeChanged = true; + send("<"); + } + if ( obj == top ) { + treeChanged = true; + send("'"); + } + if ( obj == right ) { + treeChanged = true; + send(">"); + } + if ( obj == rightMeta ) { + treeChanged = true; + send(">>"); + } + + if ( obj == cancel ) { + dialog.hide(); + } + + if ( obj == browse ) { + if (fc.getChoosableFileFilters().length<2) + fc.addChoosableFileFilter(new GrammarFilter()); + int returnVal = fc.showOpenDialog(GFEditor.this); + if (returnVal == JFileChooser.APPROVE_OPTION) { + File file = fc.getSelectedFile(); + inputField.setText(file.getPath().replace('\\','/')); + } + } + + if ( obj == ok ) { + treeChanged = true; + if (termReadButton.isSelected()) { + termInput = inputField.getText(); + if (termInput.indexOf('/')==-1){ + send("g "+termInput); + System.out.println("sending term string"); + } + else { + send("tfile "+termInput); + System.out.println("sending file term: "+termInput); + } + } + else { + parseInput = inputField.getText(); + if (parseInput.indexOf('/')==-1){ + send("p "+parseInput); + System.out.println("sending parse string"+parseInput); + } + else { + send("pfile "+parseInput); + System.out.println("sending file parse string: "+parseInput); + } + } + dialog.hide(); + } + + if ( obj == read ) { + if (stringReadButton.isSelected()) + inputField.setText(parseInput); + else + inputField.setText(termInput); + dialog.show(); + } + +/* if ( obj == term ) { + inputLabel.setText("Term:"); + inputField.setText(termInput); + dialog.show(); + } + if ( obj == parse ) { + inputLabel.setText("Parse:"); + inputField.setText(parseInput); + dialog.show(); + } +*/ + if ( obj == alpha){ + String s = JOptionPane.showInputDialog("Type string:", alphaInput); + if (s!=null) { + alphaInput = s; + treeChanged = true; + send("x "+s); + } + } + if ( obj == random){ + treeChanged = true; + send("a"); + } + if ( obj == undo){ + treeChanged = true; + send("u"); + } + } + } catch (Exception e){} + } + static void writeOutput(String str, String fileName) { + + try { + FileOutputStream fos = new FileOutputStream(fileName); + Writer out = new OutputStreamWriter(fos, "UTF8"); + out.write(str); + out.close(); + } catch (IOException e) { + JOptionPane.showMessageDialog(null, + "Document is empty!","Error", JOptionPane.ERROR_MESSAGE); + } + } + public static void populateTree(DynamicTree treePanel) { + String p1Name = new String("Root"); + DefaultMutableTreeNode p1; + p1 = treePanel.addObject(null, p1Name); + } + + public static void formTree(DynamicTree treePanel) { + Hashtable table = new Hashtable(); + TreePath path=null; + boolean treeStarted = false, selected = false; + String s = treeString; + String name =""; + treePanel.clear(); + int j, shift=0, star=0, index = 0; + DefaultMutableTreeNode p2=null, p1=null; + if (debug) System.out.print("treeString: "+ s); + if (s.indexOf('*')!=-1) star = 1; + while (s.length()>0) { + while ((s.length()>0) && ((s.charAt(0)=='*')||(s.charAt(0)==' '))){ + if (s.charAt(0) == '*') selected = true; + s = s.substring(1); + shift++; + } + if (s.length()>0) { + j = s.indexOf("\n"); + name = s.substring(0, j); + index++; + s = s.substring(j+1); + shift = (shift - star)/2; + + p1 = (DefaultMutableTreeNode)table.get(new Integer(shift)); + p2 = treePanel.addObject(p1, name); + table.put(new Integer(shift+1), p2); + path = new TreePath(p2.getPath()); + nodeTable.put(path, new Integer(index)); + if (selected) { + treePanel.tree.setSelectionPath(path); + treePanel.oldSelection = index; + if (debug) System.out.println("new selected index "+ index); + selected = false; + } + treeStarted=true; + } + shift = 0; + } + if ((p2!=null)) { + treePanel.tree.makeVisible(path); + gui2.toFront(); + index = 0; + } + } + + /** Listens to the radio buttons. */ + class RadioListener implements ActionListener { + public void actionPerformed(ActionEvent e) { + String action = e.getActionCommand(); + if (action.equals("split") ) { + cp.remove(centerPanel); + centerPanel2.add(middlePanelUp, BorderLayout.SOUTH); + if (((JCheckBoxMenuItem)viewMenu.getItem(0)).isSelected()) { + centerPanel2.add(treePanel, BorderLayout.CENTER); + } + else { + centerPanel2.add(outputPanelUp, BorderLayout.CENTER); + } + cp.add(centerPanel2, BorderLayout.CENTER); + gui2.getContentPane().add(outputPanelDown); + gui2.setVisible(true); + pack(); + repaint(); + } + if (action.equals("combine") ) { + cp.remove(centerPanel2); + middlePanel.add(middlePanelUp, BorderLayout.NORTH); + if (((JCheckBoxMenuItem)viewMenu.getItem(0)).isSelected()) { gui2.setVisible(false); + centerPanel.setLeftComponent(treePanel); + } + else { + centerPanel.setLeftComponent(outputPanelUp); + gui2.setVisible(false); + } + cp.add(centerPanel, BorderLayout.CENTER); + centerPanelDown.add(outputPanelDown, BorderLayout.CENTER); + pack(); + repaint(); + } + if (action.equals("showTree") ) { + if (!((JCheckBoxMenuItem)e.getSource()).isSelected()){ + if (debug) System.out.println("was selected"); + cbMenuItem.setSelected(false); + if (((JRadioButtonMenuItem)viewMenu.getItem(2)).isSelected()) { + centerPanel.remove(treePanel); + centerPanel.setLeftComponent(outputPanelUp); + } + else { + centerPanel2.remove(treePanel); + centerPanel2.add(outputPanelUp, BorderLayout.CENTER); + } + } + else { + if (debug) System.out.println("was not selected"); + cbMenuItem.setSelected(true); + if (((JRadioButtonMenuItem)viewMenu.getItem(2)).isSelected()) { + centerPanel.remove(outputPanelUp); + treePanel.setRightComponent(outputPanelUp); + centerPanel.setLeftComponent(treePanel); + } + else { + centerPanel2.remove(outputPanelUp); + treePanel.setRightComponent(outputPanelUp); + centerPanel2.add(treePanel, BorderLayout.CENTER); + } + } + pack(); + repaint(); + } + if (action.equals("lang")) { + if (newObject) { + output.setText(""); + formLin(); + } + if (debug) + System.out.println("language option has changed "+((JCheckBoxMenuItem)e.getSource()).getText()); + if (((JCheckBoxMenuItem)e.getSource()).isSelected()){ + System.out.println("turning on"); + send("on "+((JCheckBoxMenuItem)e.getSource()).getText()); + } + else{ + System.out.println("turning off"); + send("off "+((JCheckBoxMenuItem)e.getSource()).getText()); + } + } + //modeMenus actions: + else { + if ((action.equals("long")) || (action.equals("short"))) + { + send("ms " + action); + } + else + if ((action.equals("typed")) || (action.equals("untyped"))) + { + send("mt " + action); + } + else + { + selectedMenuLanguage = action; + if (action.equals("Abstract")) + { + send("ml Abs"); + } + else + { + System.out.println("sending "+action); + send("ml " + action); + } + } + } + } + } + + /** Handle the key pressed event. */ + public void keyPressed(KeyEvent e) { + int keyCode = e.getKeyCode(); + if (keyCode == 10) { + listAction(list.getSelectedIndex()); + } + } + /** Handle the key typed event. */ + public void keyTyped(KeyEvent e) { + } + /** Handle the key released event. */ + public void keyReleased(KeyEvent e) { + } + + public void listAction(int index) { + if (index == -1) + {if (debug) System.out.println("no selection");} + else { + treeChanged = true; + send((String)commands.elementAt(list.getSelectedIndex())); + } + } +} diff --git a/src/JavaGUI/GrammarFilter.java b/src/JavaGUI/GrammarFilter.java new file mode 100644 index 000000000..514da3fa8 --- /dev/null +++ b/src/JavaGUI/GrammarFilter.java @@ -0,0 +1,30 @@ +import java.io.File; +import javax.swing.*; +import javax.swing.filechooser.*; + +public class GrammarFilter extends FileFilter { + + // Accept all directories and all gf, gfm files. + public boolean accept(File f) { + if (f.isDirectory()) { + return true; + } + + String extension = Utils.getExtension(f); + if (extension != null) { + if (extension.equals(Utils.gf) || + extension.equals(Utils.gfm)) { + return true; + } else { + return false; + } + } + + return false; + } + + // The description of this filter + public String getDescription() { + return "Just Grammars"; + } +} diff --git a/src/JavaGUI/Utils.java b/src/JavaGUI/Utils.java new file mode 100644 index 000000000..f7c6f5b93 --- /dev/null +++ b/src/JavaGUI/Utils.java @@ -0,0 +1,22 @@ + +import java.io.File; + +public class Utils { + + public final static String gf = "gf"; + public final static String gfm = "gfm"; + + /* + * Get the extension of a file. + */ + public static String getExtension(File f) { + String ext = null; + String s = f.getName(); + int i = s.lastIndexOf('.'); + + if (i > 0 && i < s.length() - 1) { + ext = s.substring(i+1).toLowerCase(); + } + return ext; + } +} diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 000000000..2a9019c03 --- /dev/null +++ b/src/Makefile @@ -0,0 +1,23 @@ +GHMAKE=ghc +GHCFLAGS=-package lang -package util +GHCFUDFLAG=-package Fudgets +GHCINCLUDE=-iapi -icompile -igrammar -iinfra -ishell -isource -icanonical -iuseGrammar -icf -ifor-ghc + +all: + make today ; make ghc +ghc: + $(GHMAKE) $(GHCFLAGS) $(GHCINCLUDE) $(GHCFUDFLAG) --make GF.hs -o gf2+ ; strip gf2+ ; mv gf2+ ../bin/ +batch: + $(GHMAKE) $(GHCFLAGS) $(GHCINCLUDE) --make GF2.hs -o gf2 ; strip gf2 +api: + $(GHMAKE) $(GHCFLAGS) $(GHCINCLUDE) --make API.hs +shell: + $(GHMAKE) $(GHCFLAGS) $(GHCINCLUDE) --make Shell.hs +clean: + rm -rf */*.o */*.hi *.o *.hi */*.ghi *.ghi *~ */*~ +hugs: + hugs -P.:for-hugs:api:source:canonical:cf:grammar:infra:shell:useGrammar:compile: GF +today: + runhugs util/MkToday +javac: + cd java ; javac GFEditor.java ; cd .. diff --git a/src/Today.hs b/src/Today.hs new file mode 100644 index 000000000..9bb6712ee --- /dev/null +++ b/src/Today.hs @@ -0,0 +1 @@ +module Today where today = "Mon Sep 22 15:54:44 CEST 2003" diff --git a/src/tools/GFDoc.hs b/src/tools/GFDoc.hs new file mode 100644 index 000000000..0c5f943d9 --- /dev/null +++ b/src/tools/GFDoc.hs @@ -0,0 +1,255 @@ +module Main where + +import List +import System +import Char + +-- produce a HTML document from a list of GF grammar files. AR 6/10/2002 + +-- to read files and write a file + +main :: IO () +main = do + xx <- getArgs + let + (typ,format,name) = case xx of + "+latex" : x: [] -> (True,doc2latex,x) + x:[] -> (False,doc2html,x) + _ -> (True,doc2html, "unknown.txt") --- + if null xx + then do + putStrLn welcome + putStrLn help + else do + ss <- readFile name + let outfile = fileFormat typ name + writeFile outfile $ format $ pDoc $ ss + +welcome = unlines [ + "", + "gfdoc - a rudimentary GF document generator.", + "(c) Aarne Ranta (aarne@cs.chalmers.se) 2002 under GNU GPL." + ] + +help = unlines $ [ + "", + "Usage: gfdoc (+latex) file", + "", + "The program operates with lines in GF code, treating them into LaTeX", + "(flag +latex) or to HTML (by default). The output is written in a file", + "whose name is formed from the input file name by replacing its suffix", + "with html or tex.", + "", + "The translation is line by line", + "depending as follows on how the line begins", + "", + " --[Int] heading of level Int", + " -- new paragraph", + " --. end of document", +--- " --- ignore this comment line in document", +--- " {---} ignore this code line in document", + " --[Text] Text belongs to text paragraph", + " [Text] Text belongs to code paragraph", + "", + "Within a text paragraph, text enclosed between certain characters", + "is treated specially:", + "", + " *[Text]* emphasized (boldface)", + " \"[Text]\" example string (italics)", + " $[Text]$ example code (courier)" + ] + +fileFormat isLatex x = body ++ if isLatex then "tex" else "html" where + body = reverse $ dropWhile (/='.') $ reverse x + +-- the document datatype + +data Doc = Doc Title [Paragraph] + +type Title = [TextItem] + +data Paragraph = + Text [TextItem] -- text line starting with -- + | List [[TextItem]] -- + | Code String -- other text line + | New -- new paragraph: line consisting of -- + | Heading Int [TextItem] -- text line starting with --n where n = 1,2,3,4 + +data TextItem = + Str String + | Emp String -- emphasized, *...* + | Lit String -- string literal, "..." + | Inl String -- inlined code, '...' + + +-- parse document + +pDoc :: String -> Doc +pDoc s = case lines s of + ('-':'-':'1':title) : paras -> Doc (pItems title) (map pPara (grp paras)) + paras -> Doc [] (map pPara (grp paras)) + where + grp ss = case ss of + s : rest --- | ignore s -> grp rest + | isEnd s -> [] + | begComment s -> let (s1,s2) = getComment (drop 2 s : rest) + in map ("-- " ++) s1 ++ grp s2 + | isComment s -> s : grp rest + | all isSpace s -> grp rest + [] -> [] + _ -> unlines code : grp rest where (code,rest) = span (not . isComment) ss + pPara s = case s of + '-':'-':d:text | isDigit d -> Heading (read [d]) (pItems text) + '-':'-':[] -> New + '-':'-':text -> Text (pItems (dropWhile isSpace text)) + _ -> Code s + pItems s = case s of + '*' : cs -> get 1 Emp (=='*') cs + '"' : cs -> get 1 Lit (=='"') cs + '$' : cs -> get 1 Inl (=='$') cs + [] -> [] + _ -> get 0 Str (flip elem "*\"$") s + + get _ _ _ [] = [] + get k con isEnd cs = con beg : pItems (drop k rest) + where (beg,rest) = span (not . isEnd) cs + + ignore s = case s of + '-':'-':'-':_ -> True + '{':'-':'-':'-':'}':_ -> True + _ -> False + + isEnd s = case s of + '-':'-':'.':_ -> True + _ -> False + + +-- render in html + +doc2html :: Doc -> String +doc2html (Doc title paras) = unlines $ + tagXML "html" $ + tagXML "body" $ + unwords (tagXML "i" ["Produced by " ++ welcome]) : + mkTagXML "p" : + concat (tagXML "h1" [concat (map item2html title)]) : + empty : + map para2html paras + +para2html :: Paragraph -> String +para2html p = case p of + Text its -> concat (map item2html its) + Code s -> unlines $ tagXML "pre" $ map (indent 2) $ + remEmptyLines $ lines $ spec s + New -> mkTagXML "p" + Heading i its -> concat $ tagXML ('h':show i) [concat (map item2html its)] + +item2html :: TextItem -> String +item2html i = case i of + Str s -> spec s + Emp s -> concat $ tagXML "b" [spec s] + Lit s -> concat $ tagXML "i" [spec s] + Inl s -> concat $ tagXML "tt" [spec s] + +mkTagXML t = '<':t ++ ">" +mkEndTagXML t = mkTagXML ('/':t) +tagXML t ss = mkTagXML t : ss ++ [mkEndTagXML t] + +spec = elimLt + +elimLt s = case s of + '<':cs -> "<" ++ elimLt cs + c :cs -> c : elimLt cs + _ -> s + + +-- render in latex + +doc2latex :: Doc -> String +doc2latex (Doc title paras) = unlines $ + preludeLatex : + funLatex "title" [concat (map item2latex title)] : + funLatex "author" [fontLatex "footnotesize" (welcome)] : + envLatex "document" ( + funLatex "maketitle" [] : + map para2latex paras) + +para2latex :: Paragraph -> String +para2latex p = case p of + Text its -> concat (map item2latex its) + Code s -> unlines $ envLatex "verbatim" $ map (indent 2) $ + remEmptyLines $ lines $ s + New -> "\n" + Heading i its -> headingLatex i (concat (map item2latex its)) + +item2latex :: TextItem -> String +item2latex i = case i of + Str s -> specl s + Emp s -> fontLatex "bf" (specl s) + Lit s -> fontLatex "it" (specl s) + Inl s -> fontLatex "tt" (specl s) + +funLatex :: String -> [String] -> String +funLatex f xs = "\\" ++ f ++ concat ["{" ++ x ++ "}" | x <- xs] + +envLatex :: String -> [String] -> [String] +envLatex e ss = + funLatex "begin" [e] : + ss ++ + [funLatex "end" [e]] + +headingLatex :: Int -> String -> String +-- for slides +-- headingLatex _ s = funLatex "newone" [] ++ "\n" ++ funLatex "heading" [s] +headingLatex i s = funLatex t [s] where + t = case i of + 2 -> "section" + 3 -> "subsection" + _ -> "subsubsection" + +fontLatex :: String -> String -> String +fontLatex f s = "{\\" ++ f ++ " " ++ s ++ "}" + +specl = eliml + +eliml s = case s of + '|':cs -> mmath "mid" ++ elimLt cs + '{':cs -> mmath "\\{" ++ elimLt cs + '}':cs -> mmath "\\}" ++ elimLt cs + _ -> s + +mmath s = funLatex "mbox" ["$" ++ s ++ "$"] + +preludeLatex = unlines $ [ + "\\documentclass[12pt]{article}", + "\\usepackage{isolatin1}", + "\\setlength{\\oddsidemargin}{0mm}", + "\\setlength{\\evensidemargin}{-2mm}", + "\\setlength{\\topmargin}{-16mm}", + "\\setlength{\\textheight}{240mm}", + "\\setlength{\\textwidth}{158mm}", + "\\setlength{\\parskip}{2mm}", + "\\setlength{\\parindent}{0mm}" + ] + +-- auxiliaries + +empty = "" + +isComment = (== "--") . take 2 + +begComment = (== "{-") . take 2 + +getComment ss = case ss of + "-}":ls -> ([],ls) + l:ls -> (l : s1, s2) where (s1,s2) = getComment ls + _ -> ([],[]) + +indent n = (replicate n ' ' ++) + +remEmptyLines = rem False where + rem prevGood ls = case span empty ls of + (_ :_, ss@(_ : _)) -> (if prevGood then ("":) else id) $ rem False ss + (_, []) -> [] + (_, s:ss) -> s : rem True ss + empty = all isSpace diff --git a/src/tools/MkHelpFile.hs b/src/tools/MkHelpFile.hs new file mode 100644 index 000000000..9355a688e --- /dev/null +++ b/src/tools/MkHelpFile.hs @@ -0,0 +1,20 @@ +module Main where + +main = do + s <- readFile "HelpFile" + let s' = mkHsFile (lines s) + writeFile "HelpFile.hs" s' + +mkHsFile ss = + "module HelpFile where\n\n" ++ + "txtHelpFile =\n" ++ + unlines (map mkOne ss) ++ + " []" + +mkOne s = " \"" ++ pref s ++ (escs s) ++ "\" ++" + where + pref (' ':_) = "\\n" + pref _ = "\\n" --- + escs [] = [] + escs (c:cs) | elem c "\"\\" = '\\':c:escs cs + escs (c:cs) = c:escs cs diff --git a/src/tools/MkToday.hs b/src/tools/MkToday.hs new file mode 100644 index 000000000..1a15de2b5 --- /dev/null +++ b/src/tools/MkToday.hs @@ -0,0 +1,15 @@ +module Main where + +import System + +main :: IO () +main = do + system "date >foo.tmp" + d0 <- readFile "foo.tmp" + let d = head $ lines d0 + writeFile "Today.hs" $ mkToday d + system "rm foo.tmp" + return () + +mkToday d = "module Today where today = \"" ++ d ++ "\"\n" + diff --git a/src/tools/WriteF.hs b/src/tools/WriteF.hs new file mode 100644 index 000000000..fd491b4e5 --- /dev/null +++ b/src/tools/WriteF.hs @@ -0,0 +1,57 @@ +module Main where +import Fudgets +import System + +import Operations + +import Greek (mkGreek) +import Arabic (mkArabic) +import Hebrew (mkHebrew) +import Russian (mkRussian) + +-- AR 12/4/2000 + +main = do + xx <- getArgs + (case xx of + "HELP" : _ -> putStrLn usageWriteF + "FILE" : file : _ -> do + str <- readFileIf file + fudlogueWrite (Just str) + w:_ -> fudlogueWrite (Just (unwords xx)) + _ -> fudlogueWrite Nothing) + +usageWriteF = + "Usage: WriteF [-H20Mg -A5M] [FILE | | HELP]" ++++ + "Without arguments, an interactive display is opened." ++++ + "Prefix your string with / for Greek, - for Arabic, + for Hebrew, _ for Russian." + +fudlogueWrite mbstr = + fudlogue $ + shellF "Unicode Output" (writeF mbstr >+< quitButtonF) + +writeF Nothing = writeOutputF >==< writeInputF +writeF (Just str) = startupF [str] writeOutputF + +displaySizeP = placerF (spacerP (sizeS (Point 440 500)) verticalP) + +writeOutputF = + displaySizeP (moreF' (setFont myFont)) +--- displaySizeP (scrollF (displayF' (setFont myFont))) +--- >=^< +--- vboxD' 0 . map g + >==< + mapF (map mkUnicode . lines) + +writeInputF = stringInputF' (setShowString mkUnicode . setFont myFont) + +mkUnicode s = case s of + '/':cs -> mkGreek cs + '+':cs -> mkHebrew cs + '-':cs -> mkArabic cs + '_':cs -> mkRussian cs + _ -> s + +myFont = "-mutt-clearlyu-medium-r-normal--17-120-100-100-p-101-iso10646-1" +--- myFont = "-arabic-newspaper-medium-r-normal--32-246-100-100-p-137-iso10646-1" +--- myFont = "-misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-iso10646-1"