msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Founding the newly structured GF2.0 cvs archive.

Browse Source
This commit is contained in:
aarne
2003-09-22 13:16:55 +00:00
commit b1402e8bd6
162 changed files with 25569 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
bin/jgf2 Normal file
View File

@@ -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 $*"

63
grammars/logic/Arithm.gf Normal file
View File

@@ -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))
)
)
) ;
} ;

40
grammars/logic/ArithmEng.gf Normal file
View File

@@ -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 ."] ;
} ;

82
grammars/logic/Logic.gf Normal file
View File

@@ -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 ;
} ;

59
grammars/logic/LogicEng.gf Normal file
View File

@@ -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 ++ [". <p> Proof ."] ++ a.s ++ "."} ;
ThmWithTrivialProof A a =
{s = "Theorem" ++ "." ++ A.s ++ [". <p> 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"} ;
} ;

27
grammars/logic/LogicResEng.gf Normal file
View File

@@ -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) ;
} ;

105
grammars/prelude/Coordination.gf Normal file
View File

@@ -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 = "," ;
} ;

25
grammars/prelude/Predef.gf Normal file
View File

@@ -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 {} ;
} ;

83
grammars/prelude/Prelude.gf Normal file
View File

@@ -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
} ;
} ;

36
grammars/resource/abstract/Database.gf Normal file
View File

@@ -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 ;
} ;

4
grammars/resource/abstract/PredefAbs.gf Normal file
View File

@@ -0,0 +1,4 @@
abstract PredefAbs = {
cat String ; Int ;
} ;

266
grammars/resource/abstract/ResAbs.gf Normal file
View File

@@ -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
} ;

15
grammars/resource/abstract/Restaurant.gf Normal file
View File

@@ -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 ;
} ;

15
grammars/resource/abstract/TestAbs.gf Normal file
View File

@@ -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 ;
} ;

51
grammars/resource/english/DatabaseEng.gf Normal file
View File

@@ -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) ;
} ;

11
grammars/resource/english/DatabaseEngRes.gf Normal file
View File

@@ -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 ;
} ;

1
grammars/resource/english/English.gf Normal file
View File

@@ -0,0 +1 @@
resource English = reuse ResEng ;

150
grammars/resource/english/Morpho.gf Normal file
View File

@@ -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) ;
} ;

229
grammars/resource/english/Paradigms.gf Normal file
View File

@@ -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) ;
} ;

83
grammars/resource/english/Predication.gf Normal file
View File

@@ -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) ;
} ;

195
grammars/resource/english/ResEng.gf Normal file
View File

@@ -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." ;
} ;

25
grammars/resource/english/RestaurantEng.gf Normal file
View File

@@ -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"] ;
} ;

848
grammars/resource/english/Syntax.gf Normal file
View File

@@ -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 <m,n> of {
<Sg,Sg> => 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 ;
} ;

36
grammars/resource/english/TestEng.gf Normal file
View File

@@ -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" ;
} ;

101
grammars/resource/english/Types.gf Normal file
View File

@@ -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} ;
} ;

52
grammars/resource/german/DatabaseDeu.gf Normal file
View File

@@ -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) ;
} ;

11
grammars/resource/german/DatabaseRes.gf Normal file
View File

@@ -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 ;
} ;

1
grammars/resource/german/Deutsch.gf Normal file
View File

@@ -0,0 +1 @@
resource Deutsch = reuse ResDeu ;

23
grammars/resource/german/Logical.gf Normal file
View File

@@ -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)))) ;
} ;

399
grammars/resource/german/Morpho.gf Normal file
View File

@@ -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 <gn,c> of {
<GSg Fem,Gen> => "deren" ;
<GSg g,Gen> => "dessen" ;
<GPl,Dat> => "denen" ;
<GPl,Gen> => "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 <g,c> of {
<_,Nom> => bös+"e" ;
<Masc,Acc> => 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
} ;
-}
} ;

300
grammars/resource/german/Paradigms.gf Normal file
View File

@@ -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 ;
} ;

87
grammars/resource/german/Predication.gf Normal file
View File

@@ -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) ;
} ;

217
grammars/resource/german/ResDeu.gf Normal file
View File

@@ -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" ;
} ;

24
grammars/resource/german/RestaurantDeu.gf Normal file
View File

@@ -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"] ;
} ;

891
grammars/resource/german/Syntax.gf Normal file
View File

@@ -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 <a,c> of {
<Strong,Nom> => Strong ;
<Strong,Acc> => 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 <m,n> of {
<Sg,Sg> => 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 <p,q> of {
<P3,P3> => P3 ;
<P1,_> => 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".
} ;

39
grammars/resource/german/TestDeu.gf Normal file
View File

@@ -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" ;
} ;

98
grammars/resource/german/Types.gf Normal file
View File

@@ -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 ;
} ;

1039
grammars/resource/swedish/Morpho.gf Normal file
View File

File diff suppressed because it is too large Load Diff

196
grammars/resource/swedish/ResSwe.gf Normal file
View File

@@ -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 ."] ;
} ;

1
grammars/resource/swedish/Svenska.gf Normal file
View File

@@ -0,0 +1 @@
resource Svenska = reuse ResSwe ;

1000
grammars/resource/swedish/Syntax.gf Normal file
View File

File diff suppressed because it is too large Load Diff

35
grammars/resource/swedish/TestSwe.gf Normal file
View File

@@ -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 ;
} ;

150
grammars/resource/swedish/Types.gf Normal file
View File

@@ -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} ;
}

78
src/GF.hs Normal file
View File

@@ -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"
]

267
src/GF/API.hs Normal file
View File

@@ -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

42
src/GF/API/IOGrammar.hs Normal file
View File

@@ -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

180
src/GF/CF/CF.hs Normal file
View File

@@ -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]

151
src/GF/CF/CFIdent.hs Normal file
View File

@@ -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'

157
src/GF/CF/CanonToCF.hs Normal file
View File

@@ -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)]] ---
-}

166
src/GF/CF/ChartParser.hs Normal file
View File

@@ -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)

59
src/GF/CF/PPrCF.hs Normal file
View File

@@ -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
-}

95
src/GF/CF/Profile.hs Normal file
View File

@@ -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

160
src/GF/Canon/AbsGFC.hs Normal file
View File

@@ -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)

234
src/GF/Canon/CMacros.hs Normal file
View File

@@ -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
-}

167
src/GF/Canon/CanonToGrammar.hs Normal file
View File

@@ -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

48
src/GF/Canon/GFC.hs Normal file
View File

@@ -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
-}

22
src/GF/Canon/GetGFC.hs Normal file
View File

@@ -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

105
src/GF/Canon/LexGFC.hs Normal file
View File

@@ -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)]))

141
src/GF/Canon/Look.hs Normal file
View File

@@ -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?

121
src/GF/Canon/MkGFC.hs Normal file
View File

@@ -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 ---

36
src/GF/Canon/PrExp.hs Normal file
View File

@@ -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

319
src/GF/Canon/PrintGFC.hs Normal file
View File

@@ -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<i then parenth else id
instance Print Ident where
prt _ i = [prIdent i]
prtList es = case es of
[] -> (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])

116
src/GF/Canon/Share.hs Normal file
View File

@@ -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

199
src/GF/Canon/SkelGFC.hs Normal file
View File

@@ -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

25
src/GF/Canon/TestGFC.hs Normal file
View File

@@ -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

37
src/GF/Canon/Unlex.hs Normal file
View File

@@ -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 = (=="<p>")
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
[] -> []

665
src/GF/Compile/CheckGrammar.hs Normal file
View File

@@ -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 ()
-}

207
src/GF/Compile/Compile.hs Normal file
View File

@@ -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

77
src/GF/Compile/Extend.hs Normal file
View File

@@ -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

71
src/GF/Compile/GetGrammar.hs Normal file
View File

@@ -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

224
src/GF/Compile/GrammarToCanon.hs Normal file
View File

@@ -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

75
src/GF/Compile/MkResource.hs Normal file
View File

@@ -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
-}

88
src/GF/Compile/ModDeps.hs Normal file
View File

@@ -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

171
src/GF/Compile/Optimize.hs Normal file
View File

@@ -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

58
src/GF/Compile/PGrammar.hs Normal file
View File

@@ -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"
-}

69
src/GF/Compile/PrOld.hs Normal file
View File

@@ -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

51
src/GF/Compile/RemoveLiT.hs Normal file
View File

@@ -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"

263
src/GF/Compile/Rename.hs Normal file
View File

@@ -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
-}

338
src/GF/Compile/ShellState.hs Normal file
View File

@@ -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

98
src/GF/Compile/Update.hs Normal file
View File

@@ -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"

7
src/GF/Data/ErrM.hs Normal file
View File

@@ -0,0 +1,7 @@
module ErrM (
module Operations
) where
import Operations
-- hack for BNFC generated files. AR 21/9/2003

559
src/GF/Data/Operations.hs Normal file
View File

@@ -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 []

118
src/GF/Data/OrdMap2.hs Normal file
View File

@@ -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)

111
src/GF/Data/OrdSet.hs Normal file
View File

@@ -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

143
src/GF/Data/Parsers.hs Normal file
View File

@@ -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']

106
src/GF/Data/Str.hs Normal file
View File

@@ -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

172
src/GF/Data/Zipper.hs Normal file
View File

@@ -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)

16
src/GF/Fudgets/ArchEdit.hs Normal file
View File

@@ -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"

120
src/GF/Fudgets/CommandF.hs Normal file
View File

@@ -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 [])

36
src/GF/Fudgets/EventF.hs Normal file
View File

@@ -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))

47
src/GF/Fudgets/FudgetOps.hs Normal file
View File

@@ -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

23
src/GF/Fudgets/UnicodeF.hs Normal file
View File

@@ -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)

64
src/GF/Grammar/AbsCompute.hs Normal file
View File

@@ -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

24
src/GF/Grammar/Abstract.hs Normal file
View File

@@ -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 ---

51
src/GF/Grammar/AppPredefined.hs Normal file
View File

@@ -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")

238
src/GF/Grammar/Compute.hs Normal file
View File

@@ -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

154
src/GF/Grammar/Grammar.hs Normal file
View File

@@ -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

125
src/GF/Grammar/LookAbs.hs Normal file
View File

@@ -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"

393
src/GF/Grammar/Lookup.hs Normal file
View File

@@ -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
-}

261
src/GF/Grammar/MMacros.hs Normal file
View File

@@ -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

Some files were not shown because too many files have changed in this diff Show More