GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

Added treatment of transfer modules. Aggregation is an example.

Browse Source
This commit is contained in:
aarne
2003-10-09 15:23:32 +00:00
parent ddd103ccd7
commit 2ee936c7e2
29 changed files with 311 additions and 50 deletions
Download Patch File Download Diff File Expand all files Collapse all files

57
grammars/aggregation/Abstract.gf Normal file
View File

@@ -0,0 +1,57 @@
-- testing transfer: aggregation by def definitions. AR 12/4/2003 -- 9/10
-- p "Mary runs or John runs and John walks" | l -transfer=Aggregation
-- Mary runs or John runs and walks
-- Mary or John runs and John walks
-- The two results are due to ambiguity in parsing. Thus it is not spurious!
abstract Abstract = {
cat
S ; NP ; VP ; Conj ;
fun
Pred : NP -> VP -> S ;
ConjS : Conj -> S -> S -> S ;
ConjVP : Conj -> VP -> VP -> VP ;
ConjNP : Conj -> NP -> NP -> NP ;
John, Mary, Bill : NP ;
Walk, Run, Swim : VP ;
And, Or : Conj ;
fun aggreg : S -> S ;
def
aggreg (ConjS c (Pred Q F) B) = aggrAux c Q F B ;
aggreg (ConjS c A B) = ConjS c (aggreg A) (aggreg B) ;
aggreg A = A ;
-- this auxiliary makes pattern matching on NP to test equality
fun aggrAux : Conj -> NP -> VP -> S -> S ;
def
-- aggregate verbs with shared subject
aggrAux c John F (Pred John G) = Pred John (ConjVP c F G) ;
aggrAux c Mary F (Pred Mary G) = Pred Mary (ConjVP c F G) ;
aggrAux c Bill F (Pred Bill G) = Pred Bill (ConjVP c F G) ;
-- aggregate subjects with shared verbs
aggrAux c Q Run (Pred R Run) = Pred (ConjNP c Q R) Run ;
aggrAux c Q Walk (Pred R Walk) = Pred (ConjNP c Q R) Walk ;
aggrAux c Q Swim (Pred R Swim) = Pred (ConjNP c Q R) Swim ;
-- this case takes care of munching
aggrAux c Q F (ConjS e A B) = aggrAux c Q F (aggreg (ConjS e A B)) ;
aggrAux c Q F B = ConjS c (Pred Q F) (aggreg B) ;
-- unfortunately we cannot test string equality for Name : String -> NP ;
-- It would also be tedious to test the equality of complex
-- NPs and VPs, but not impossible.
-- have to add these, otherwise constants are not constructor patterns!
data NP = John | Mary | Bill ;
data VP = Run | Walk | Swim ;
}

5
grammars/aggregation/Aggregation.gf Normal file
View File

@@ -0,0 +1,5 @@
transfer Aggregation : Abstract -> Abstract = {
transfer S : S -> S = aggreg ;
}

18
grammars/aggregation/English.gf Normal file
View File

@@ -0,0 +1,18 @@
concrete English of Abstract = {
pattern
Pred np vp = np ++ vp ;
ConjS c A B = A ++ c ++ B ;
ConjVP c A B = A ++ c ++ B ;
ConjNP c A B = A ++ c ++ B ;
John = "John" ;
Mary = "Mary" ;
Bill = "Bill" ;
Walk = "walks" ;
Run = "runs" ;
Swim = "swims" ;
And = "and" ;
Or = "or" ;
}

75
grammars/aggregation/transfer.gf Normal file
View File

@@ -0,0 +1,75 @@
-- testing transfer: aggregation by def definitions. AR 12/4/2003
-- p "Mary runs or John runs and John walks" | wt -c aggreg | l
-- Mary runs or John runs and walks
-- Mary or John runs and John walks
-- The two results are due to ambiguity in parsing. Thus it is not spurious!
flags transfer=aggreg ;
cat
S ; NP ; VP ; Conj ;
fun
Pred : NP -> VP -> S ;
ConjS : Conj -> S -> S -> S ;
ConjVP : Conj -> VP -> VP -> VP ;
ConjNP : Conj -> NP -> NP -> NP ;
John, Mary, Bill : NP ;
Walk, Run, Swim : VP ;
And, Or : Conj ;
pattern
Pred np vp = np ++ vp ;
ConjS c A B = A ++ c ++ B ;
ConjVP c A B = A ++ c ++ B ;
ConjNP c A B = A ++ c ++ B ;
John = "John" ;
Mary = "Mary" ;
Bill = "Bill" ;
Walk = "walks" ;
Run = "runs" ;
Swim = "swims" ;
And = "and" ;
Or = "or" ;
-- aggregation transformation
fun aggreg : S -> S ;
def
aggreg (ConjS c (Pred Q F) B) = aggrAux c Q F B ;
aggreg (ConjS c A B) = ConjS c (aggreg A) (aggreg B) ;
aggreg A = A ;
-- this auxiliary makes pattern matching on NP to test equality
fun aggrAux : Conj -> NP -> VP -> S -> S ;
def
-- aggregate verbs with shared subject
aggrAux c John F (Pred John G) = Pred John (ConjVP c F G) ;
aggrAux c Mary F (Pred Mary G) = Pred Mary (ConjVP c F G) ;
aggrAux c Bill F (Pred Bill G) = Pred Bill (ConjVP c F G) ;
-- aggregate subjects with shared verbs
aggrAux c Q Run (Pred R Run) = Pred (ConjNP c Q R) Run ;
aggrAux c Q Walk (Pred R Walk) = Pred (ConjNP c Q R) Walk ;
aggrAux c Q Swim (Pred R Swim) = Pred (ConjNP c Q R) Swim ;
-- this case takes care of munching
aggrAux c Q F (ConjS e A B) = aggrAux c Q F (aggreg (ConjS e A B)) ;
aggrAux c Q F B = ConjS c (Pred Q F) (aggreg B) ;
-- unfortunately we cannot test string equality for Name : String -> NP ;
-- It would also be tedious to test the equality of complex
-- NPs and VPs, but not impossible.
-- have to add these, otherwise constants are not constructor patterns!
data NP = John | Mary | Bill ;
data VP = Run | Walk | Swim ;

3
grammars/numerals/Trans.gf Normal file
View File

@@ -0,0 +1,3 @@
transfer Trans : Nat -> Nat = {
transfer Nat = nat2bin ;
}

26
grammars/prelude/Predef.gf
View File

@@ -5,21 +5,21 @@ 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 {} ; ----
-- these operations have their proper definitions in AppPredefined.hs
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 Int : Type = variants {} ; -- the type of integers
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 {} ;
oper length : Tok -> Int = variants {} ; -- length of string
oper drop : Int -> Tok -> Tok = variants {} ; -- drop prefix of length
oper take : Int -> Tok -> Tok = variants {} ; -- take prefix of length
oper tk : Int -> Tok -> Tok = variants {} ; -- drop suffix of length
oper dp : Int -> Tok -> Tok = variants {} ; -- take suffix of length
oper eqInt : Int -> Int -> PBool = variants {} ; -- test if equal integers
oper plus : Int -> Int -> Int = variants {} ; -- add integers
oper eqStr : Tok -> Tok -> PBool = variants {} ; -- test if equal strings
oper occur : Tok -> Tok -> PBool = variants {} ; -- test if occurs as substring
oper show : (P : Type) -> P -> Tok = variants {} ; -- convert param to string
oper read : (P : Type) -> Tok -> P = variants {} ; -- convert string to param
} ;

42
src/GF/API.hs
View File

@@ -17,12 +17,12 @@ import PPrCF
import CFIdent
import PGrammar
import Randomized (mkRandomTree)
import Zipper
import MMacros
import qualified Macros as M
import TypeCheck
import CMacros
import Transfer
import Option
import Custom
@@ -47,6 +47,7 @@ import Arch (myStdGen)
import UTF8
import Operations
import UseIO
import Zipper
import List (nub)
import Monad (liftM)
@@ -161,20 +162,24 @@ optLinearizeTreeVal :: Options -> GFGrammar -> Tree -> String
optLinearizeTreeVal opts gr = err id id . optLinearizeTree opts gr
optLinearizeTree :: Options -> GFGrammar -> Tree -> Err String
optLinearizeTree opts gr t = case getOptVal opts markLin of
Just mk
| mk == markOptXML -> lin markXML t
| mk == markOptJava -> lin markXMLjgf t
| mk == markOptStruct -> lin markBracket t
| mk == markOptFocus -> lin markFocus t
| otherwise -> lin noMark t
_ -> lin noMark t
optLinearizeTree opts gr t = case getOptVal opts transferFun of
Just m -> useByTransfer flin g (I.identC m) t
_ -> flin t
where
lin mk
flin = case getOptVal opts markLin of
Just mk
| mk == markOptXML -> lin markXML
| mk == markOptJava -> lin markXMLjgf
| mk == markOptStruct -> lin markBracket
| mk == markOptFocus -> lin markFocus
| otherwise -> lin noMark
_ -> lin noMark
lin mk
| oElem showRecord opts = liftM prt . linearizeNoMark g c
| otherwise = return . linTree2string mk g c
g = grammar gr
c = cncId gr
g = grammar gr
c = cncId gr
{- ----
untoksl . lin where
@@ -208,13 +213,22 @@ optLinearizeArgForm opts sgr fs ts0 = untoksl $ lin ts where
optParseArg :: Options -> GFGrammar -> String -> [Tree]
optParseArg opts gr = err (const []) id . optParseArgErr opts gr
optParseArgAny :: Options -> [GFGrammar] -> String -> [Tree]
optParseArgAny opts grs s = concat [pars gr s | gr <- grs] where
pars gr = optParseArg opts gr --- grammar options!
optParseArgErr :: Options -> GFGrammar -> String -> Err [Tree]
optParseArgErr opts gr = liftM fst . optParseArgErrMsg opts gr
optParseArgErrMsg :: Options -> GFGrammar -> String -> Err ([Tree],String)
optParseArgErrMsg opts gr s =
optParseArgErrMsg opts gr s = do
let cat = firstCatOpts opts gr
in parseStringMsg opts gr cat s
g = grammar gr
(ts,m) <- parseStringMsg opts gr cat s
ts' <- case getOptVal opts transferFun of
Just m -> mkByTransfer (const $ return ts) g (I.identC m) s
_ -> return ts
return (ts',m)
-- analyses word by word
morphoAnalyse :: Options -> GFGrammar -> String -> String

3
src/GF/Canon/AbsGFC.hs
View File

@@ -5,6 +5,7 @@ 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)
@@ -17,6 +18,7 @@ data ModType =
MTAbs Ident
| MTCnc Ident Ident
| MTRes Ident
| MTTrans Ident Ident Ident
deriving (Eq,Ord,Show)
data Extend =
@@ -36,6 +38,7 @@ data Flag =
data Def =
AbsDCat Ident [Decl] [CIdent]
| AbsDFun Ident Exp Exp
| AbsDTrans Ident Exp
| ResDPar Ident [ParDef]
| ResDOper Ident CType Term
| CncDCat Ident CType Term Term

3
src/GF/Canon/CanonToGrammar.hs
View File

@@ -29,6 +29,7 @@ canon2sourceModule (i,mi) = do
return (a', M.MTConcrete a')
M.MTAbstract -> return (i',M.MTAbstract) --- c' not needed
M.MTResource -> return (i',M.MTResource) --- c' not needed
M.MTTransfer x y -> return (i',M.MTTransfer x y) --- c' not needed
defs <- mapMTree redInfo $ M.jments m
return $ M.ModMod $ M.Module mt flags e os defs
_ -> Bad $ "cannot decompile module type"
@@ -50,6 +51,8 @@ redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do
return $ G.AbsCat (Yes cont) (Yes (map (uncurry G.Q) fs))
AbsFun typ df -> do
return $ G.AbsFun (Yes typ) (Yes df)
AbsTrans t -> do
return $ G.AbsTrans t
ResPar par -> liftM (G.ResParam . Yes) $ mapM redParam par

1
src/GF/Canon/GFC.hs
View File

@@ -27,6 +27,7 @@ type CanonAbs = M.Module Ident Option Info
data Info =
AbsCat A.Context [A.Fun]
| AbsFun A.Type A.Term
| AbsTrans A.Term
| ResPar [ParDef]
| ResOper CType Term -- global constant

8
src/GF/Canon/LexGFC.hs
View File

@@ -52,7 +52,7 @@ tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx
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)))
B "lincat" (B "data" (B "abstract" (B "Type" (B "Str" N N) N) (B "concrete" (B "cat" N N) N)) (B "in" (B "fun" (B "flags" N N) N) (B "lin" N N))) (B "pre" (B "oper" (B "open" (B "of" N N) N) (B "param" N N)) (B "transfer" (B "table" (B "resource" N N) N) (B "variants" N N)))
data BTree = N | B String BTree BTree deriving (Show)
@@ -79,13 +79,13 @@ 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__0_0 = (False,[],-1,(('\t','\255'),[('\t',1),('\n',1),('\v',1),('\f',1),('\r',1),(' ',1),('!',6),('"',8),('$',6),('(',6),(')',6),('*',3),('+',5),(',',6),('-',2),('.',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__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__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)]))

4
src/GF/Canon/MkGFC.hs
View File

@@ -21,6 +21,7 @@ canon2grammar (Gr modules) = M.MGrammar $ map mod2info modules where
MTAbs a -> (a,M.MTAbstract)
MTRes a -> (a,M.MTResource)
MTCnc a x -> (a,M.MTConcrete x)
MTTrans a x y -> (a,M.MTTransfer (M.OSimple x) (M.OSimple y))
in (a,M.ModMod (M.Module mt' flags (ee e) (oo os) defs'))
ee (Ext m) = Just m
ee _ = Nothing
@@ -37,6 +38,7 @@ info2mod m = case m of
M.MTAbstract -> MTAbs a
M.MTResource -> MTRes a
M.MTConcrete x -> MTCnc a x
M.MTTransfer (M.OSimple x) (M.OSimple y) -> MTTrans a x y
in
Mod mt' (gfcE me) (gfcO os) flags defs'
where
@@ -51,6 +53,7 @@ defs2infos = sorted2tree . map def2info
def2info d = case d of
AbsDCat c cont fs -> (c,AbsCat (trCont cont) (trFs fs))
AbsDFun c ty df -> (c,AbsFun (trExp ty) (trExp df))
AbsDTrans c t -> (c,AbsTrans (trExp t))
ResDPar c df -> (c,ResPar df)
ResDOper c ty df -> (c,ResOper ty df)
CncDCat c ty df pr -> (c, CncCat ty df pr)
@@ -95,6 +98,7 @@ infos2defs = map info2def . tree2list
info2def d = case d of
(c,AbsCat cont fs) -> AbsDCat c (rtCont cont) (rtFs fs)
(c,AbsFun ty df) -> AbsDFun c (rtExp ty) (rtExp df)
(c,AbsTrans t) -> AbsDTrans c (rtExp t)
(c,ResPar df) -> ResDPar c df
(c,ResOper ty df) -> ResDOper c ty df
(c,CncCat ty df pr) -> CncDCat c ty df pr

3
src/GF/Canon/PrintGFC.hs
View File

@@ -97,7 +97,7 @@ instance Print ModType where
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])
MTTrans id open0 open -> prPrec i 0 (concat [["transfer"] , prt 0 id , [":"] , prt 0 open0 , ["->"] , prt 0 open])
instance Print Extend where
prt i e = case e of
@@ -123,6 +123,7 @@ 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])
AbsDTrans id exp -> prPrec i 0 (concat [["transfer"] , prt 0 id , ["="] , 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])

2
src/GF/Canon/SkelGFC.hs
View File

@@ -29,6 +29,7 @@ transModType x = case x of
MTAbs id -> failure x
MTCnc id0 id -> failure x
MTRes id -> failure x
MTTrans id0 id1 id -> failure x
transExtend :: Extend -> Result
@@ -52,6 +53,7 @@ transDef :: Def -> Result
transDef x = case x of
AbsDCat id decls cidents -> failure x
AbsDFun id exp0 exp -> failure x
AbsDTrans id exp -> failure x
ResDPar id pardefs -> failure x
ResDOper id ctype term -> failure x
CncDCat id ctype term0 term -> failure x

4
src/GF/Compile/CheckGrammar.hs
View File

@@ -42,6 +42,10 @@ checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod
js' <- mapMTree (checkAbsInfo gr name) js
return $ (name, ModMod (Module mt fs me ops js')) : ms
MTTransfer a b -> 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

4
src/GF/Compile/GrammarToCanon.hs
View File

@@ -43,6 +43,7 @@ redModInfo (c,info) = do
return (a', MTConcrete a')
MTAbstract -> return (c',MTAbstract) --- c' not needed
MTResource -> return (c',MTResource) --- c' not needed
MTTransfer x y -> return (c',MTTransfer (om x) (om y)) --- 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
@@ -54,6 +55,7 @@ redModInfo (c,info) = do
_ -> return Nothing
os' <- mapM (\ (OQualif _ i) -> liftM OSimple (redIdent i)) $ opens m
return (e',os')
om = OSimple . openedModule --- normalizing away qualif
redInfo :: Ident -> (Ident,Info) -> Err [(Ident,C.Info)]
redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do
@@ -69,6 +71,8 @@ redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do
Yes t -> t
_ -> EData --- data vs. primitive
returns c' $ C.AbsFun typ df
AbsTrans t ->
returns c' $ C.AbsTrans t
ResParam (Yes ps) -> do
ps' <- mapM redParam ps

15
src/GF/Compile/Rename.hs
View File

@@ -117,7 +117,7 @@ tree2status o = case o of
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
let ops = allOpens m
mods <- mapM (lookupModule gr . openedModule) ops
let sts = map modInfo2status $ zip ops mods
return $ if isModCnc m
@@ -130,10 +130,14 @@ modInfo2status (o,i) = (o,case i of
)
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
self2status c i = mapTree (info2status (Just c)) js where -- qualify internal
js = case i of
ModMod m
| isModTrans m -> sorted2tree $ filter noTrans $ tree2list $ jments m
| otherwise -> jments m
noTrans (_,d) = case d of -- to enable other than transfer js in transfer module
AbsTrans _ -> False
_ -> True
forceQualif o = case o of
OSimple i -> OQualif i i
@@ -145,6 +149,7 @@ renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $
AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
(renPerh (mapM rent) pfs)
AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr)
AbsTrans f -> liftM AbsTrans (rent f)
ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
ResParam pp -> liftM ResParam (renPerh (mapM (renameParam status)) pp)

8
src/GF/Grammar/AppPredefined.hs
View File

@@ -26,6 +26,7 @@ appPredefined t = case t of
("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
("occur",K s, K t) -> if substring 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
@@ -49,3 +50,10 @@ str2tag s = case s of
predefTrue = Q (IC "Predef") (IC "PTrue")
predefFalse = Q (IC "Predef") (IC "PFalse")
substring :: String -> String -> Bool
substring s t = case (s,t) of
(c:cs, d:ds) -> (c == d && substring cs ds) || substring s ds
([],_) -> True
_ -> False

2
src/GF/Grammar/Grammar.hs
View File

@@ -26,7 +26,7 @@ type SourceCnc = Module Ident Option Info
data Info =
AbsCat (Perh Context) (Perh [Term]) -- constructors; must be Id or QId
| AbsFun (Perh Type) (Perh Term) -- Yes f = canonical
| AbsTrans Ident
| AbsTrans Term
-- judgements in resource
| ResParam (Perh [Param])

15
src/GF/Grammar/LookAbs.hs
View File

@@ -48,6 +48,21 @@ lookupCatContext gr m c = errIn ("looking up context of cat" +++ prt c) $ do
_ -> prtBad "unknown category" c
_ -> Bad $ prt m +++ "is not an abstract module"
-- lookup for transfer function: transfer-module-name, category name
lookupTransfer :: GFCGrammar -> Ident -> Ident -> Err Term
lookupTransfer gr m c = errIn ("looking up transfer of cat" +++ prt c) $ do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupInfo mo c
case info of
C.AbsTrans t -> return t
C.AnyInd _ n -> lookupTransfer gr n c
_ -> prtBad "cannot transfer function for" c
_ -> Bad $ prt m +++ "is not a transfer module"
---- should be revised (20/9/2003)
isPrimitiveFun :: GFCGrammar -> Fun -> Bool
isPrimitiveFun gr (m,c) = case lookupAbsDef gr m c of

8
src/GF/Infra/Modules.hs
View File

@@ -66,6 +66,10 @@ openedModule o = case o of
OSimple m -> m
OQualif _ m -> m
allOpens m = case mtype m of
MTTransfer a b -> a : b : opens m
_ -> opens m
-- initial dependency list
depPathModule :: Ord i => Module i f a -> [OpenSpec i]
depPathModule m = fors m ++ exts m ++ opens m where
@@ -176,6 +180,10 @@ isModCnc m = case mtype m of
MTConcrete _ -> True
_ -> False
isModTrans m = case mtype m of
MTTransfer _ _ -> True
_ -> False
sameMType m n = case (m,n) of
(MTConcrete _, MTConcrete _) -> True
_ -> m == n

2
src/GF/Infra/ReadFiles.hs
View File

@@ -99,7 +99,7 @@ importsOfFile =
unComm -- ignore comments before the headed line
where
term = flip elem ["{",";"]
spec = flip elem ["of", "open","in", "reuse", "=", "(", ")",",","**"]
spec = flip elem ["of", "open","in", ":", "->", "reuse", "=", "(", ")",",","**"]
unqual ws = case ws of
"(":q:ws' -> unqual ws'
w:ws' -> w:unqual ws'

3
src/GF/Source/AbsGF.hs
View File

@@ -5,6 +5,7 @@ import Ident --H
-- Haskell module generated by the BNF converter, except --H
-- newtype Ident = Ident String deriving (Eq,Ord,Show) --H
newtype LString = LString String deriving (Eq,Ord,Show)
data Grammar =
Gr [ModDef]
@@ -65,7 +66,7 @@ data TopDef =
| DefFun [FunDef]
| DefDef [Def]
| DefData [DataDef]
| DefTrans [FlagDef]
| DefTrans [Def]
| DefPar [ParDef]
| DefOper [Def]
| DefLincat [PrintDef]

10
src/GF/Source/GrammarToSource.hs
View File

@@ -20,10 +20,11 @@ trModule (i,mo) = case mo of
(map trFlag (flags m))))
where
i' = tri i
mkModule = case typeOfModule mo of
MTResource -> P.MResource
MTAbstract -> P.MAbstract
MTConcrete a -> P.MConcrete (tri a)
mkModule m = case typeOfModule mo of
MTResource -> P.MResource m
MTAbstract -> P.MAbstract m
MTConcrete a -> P.MConcrete m (tri a)
MTTransfer a b -> P.MTransfer m (trOpen a) (trOpen b)
trExtend :: Maybe Ident -> P.Extend
trExtend i = maybe P.NoExt (P.Ext . tri) i
@@ -50,6 +51,7 @@ trAnyDef (i,info) = let i' = tri i in case info of
_ -> []
AbsFun (May b) _ -> [P.DefFun [P.FunDef [i'] (P.EIndir (tri b))]]
---- don't destroy definitions!
AbsTrans f -> [P.DefTrans [P.DDef [i'] (trt f)]]
ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]]
ResParam pp -> [P.DefPar [case pp of

2
src/GF/Source/PrintGF.hs
View File

@@ -166,7 +166,7 @@ instance Print TopDef where
DefFun fundefs -> prPrec i 0 (concat [["fun"] , prt 0 fundefs])
DefDef defs -> prPrec i 0 (concat [["def"] , prt 0 defs])
DefData datadefs -> prPrec i 0 (concat [["data"] , prt 0 datadefs])
DefTrans flagdefs -> prPrec i 0 (concat [["transfer"] , prt 0 flagdefs])
DefTrans defs -> prPrec i 0 (concat [["transfer"] , prt 0 defs])
DefPar pardefs -> prPrec i 0 (concat [["param"] , prt 0 pardefs])
DefOper defs -> prPrec i 0 (concat [["oper"] , prt 0 defs])
DefLincat printdefs -> prPrec i 0 (concat [["lincat"] , prt 0 printdefs])

2
src/GF/Source/SkelGF.hs
View File

@@ -88,7 +88,7 @@ transTopDef x = case x of
DefFun fundefs -> failure x
DefDef defs -> failure x
DefData datadefs -> failure x
DefTrans flagdefs -> failure x
DefTrans defs -> failure x
DefPar pardefs -> failure x
DefOper defs -> failure x
DefLincat printdefs -> failure x

5
src/GF/Source/SourceToGrammar.hs
View File

@@ -150,9 +150,8 @@ transAbsDef x = case x of
[(c, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++
[(f, G.AbsFun nope (yes G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf]
DefTrans defs -> do
let (ids,vals) = unzip [(i,v) | FlagDef i v <- defs]
defs' <- liftM2 zip (mapM transIdent ids) (mapM transIdent vals)
returnl [(c, G.AbsTrans f) | (c,f) <- defs']
defs' <- liftM concat $ mapM getDefsGen defs
returnl [(c, G.AbsTrans f) | (c,(_,Yes f)) <- defs']
DefFlag defs -> liftM Right $ mapM transFlagDef defs
_ -> Bad $ "illegal definition in abstract module:" ++++ printTree x
where

29
src/GF/UseGrammar/Transfer.hs Normal file
View File

@@ -0,0 +1,29 @@
module Transfer where
import Grammar
import Values
import AbsCompute
import qualified GFC
import LookAbs
import MMacros
import TypeCheck
import Ident
import Operations
import Monad
-- linearize, parse, etc, by transfer. AR 9/10/2003
doTransfer :: GFC.CanonGrammar -> Ident -> Tree -> Err Tree
doTransfer gr tra t = do
cat <- liftM snd $ val2cat $ valTree t
f <- lookupTransfer gr tra cat
e <- compute gr $ App f $ tree2exp t
annotate gr e
useByTransfer :: (Tree -> Err a) -> GFC.CanonGrammar -> Ident -> (Tree -> Err a)
useByTransfer lin gr tra t = doTransfer gr tra t >>= lin
mkByTransfer :: (a -> Err [Tree]) -> GFC.CanonGrammar -> Ident -> (a -> Err [Tree])
mkByTransfer parse gr tra s = parse s >>= mapM (doTransfer gr tra)

2
src/Today.hs
View File

@@ -1 +1 @@
module Today where today = "Wed Oct 8 11:43:12 CEST 2003"
module Today where today = "Thu Oct 9 17:52:24 CEST 2003"