From 2ee936c7e23bd690b05b8362179911a2d176f150 Mon Sep 17 00:00:00 2001 From: aarne Date: Thu, 9 Oct 2003 15:23:32 +0000 Subject: [PATCH] Added treatment of transfer modules. Aggregation is an example. --- grammars/aggregation/Abstract.gf | 57 ++++++++++++++++++++++ grammars/aggregation/Aggregation.gf | 5 ++ grammars/aggregation/English.gf | 18 +++++++ grammars/aggregation/transfer.gf | 75 +++++++++++++++++++++++++++++ grammars/numerals/Trans.gf | 3 ++ grammars/prelude/Predef.gf | 26 +++++----- src/GF/API.hs | 42 ++++++++++------ src/GF/Canon/AbsGFC.hs | 3 ++ src/GF/Canon/CanonToGrammar.hs | 3 ++ src/GF/Canon/GFC.hs | 1 + src/GF/Canon/LexGFC.hs | 8 +-- src/GF/Canon/MkGFC.hs | 4 ++ src/GF/Canon/PrintGFC.hs | 3 +- src/GF/Canon/SkelGFC.hs | 2 + src/GF/Compile/CheckGrammar.hs | 4 ++ src/GF/Compile/GrammarToCanon.hs | 4 ++ src/GF/Compile/Rename.hs | 15 ++++-- src/GF/Grammar/AppPredefined.hs | 8 +++ src/GF/Grammar/Grammar.hs | 2 +- src/GF/Grammar/LookAbs.hs | 15 ++++++ src/GF/Infra/Modules.hs | 8 +++ src/GF/Infra/ReadFiles.hs | 2 +- src/GF/Source/AbsGF.hs | 3 +- src/GF/Source/GrammarToSource.hs | 10 ++-- src/GF/Source/PrintGF.hs | 2 +- src/GF/Source/SkelGF.hs | 2 +- src/GF/Source/SourceToGrammar.hs | 5 +- src/GF/UseGrammar/Transfer.hs | 29 +++++++++++ src/Today.hs | 2 +- 29 files changed, 311 insertions(+), 50 deletions(-) create mode 100644 grammars/aggregation/Abstract.gf create mode 100644 grammars/aggregation/Aggregation.gf create mode 100644 grammars/aggregation/English.gf create mode 100644 grammars/aggregation/transfer.gf create mode 100644 grammars/numerals/Trans.gf create mode 100644 src/GF/UseGrammar/Transfer.hs diff --git a/grammars/aggregation/Abstract.gf b/grammars/aggregation/Abstract.gf new file mode 100644 index 000000000..719bfe150 --- /dev/null +++ b/grammars/aggregation/Abstract.gf @@ -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 ; +} diff --git a/grammars/aggregation/Aggregation.gf b/grammars/aggregation/Aggregation.gf new file mode 100644 index 000000000..116629422 --- /dev/null +++ b/grammars/aggregation/Aggregation.gf @@ -0,0 +1,5 @@ +transfer Aggregation : Abstract -> Abstract = { + + transfer S : S -> S = aggreg ; + +} diff --git a/grammars/aggregation/English.gf b/grammars/aggregation/English.gf new file mode 100644 index 000000000..21da16b23 --- /dev/null +++ b/grammars/aggregation/English.gf @@ -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" ; +} diff --git a/grammars/aggregation/transfer.gf b/grammars/aggregation/transfer.gf new file mode 100644 index 000000000..0f4e12097 --- /dev/null +++ b/grammars/aggregation/transfer.gf @@ -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 ; + diff --git a/grammars/numerals/Trans.gf b/grammars/numerals/Trans.gf new file mode 100644 index 000000000..4d46bc7f1 --- /dev/null +++ b/grammars/numerals/Trans.gf @@ -0,0 +1,3 @@ +transfer Trans : Nat -> Nat = { + transfer Nat = nat2bin ; +} diff --git a/grammars/prelude/Predef.gf b/grammars/prelude/Predef.gf index a91681af6..ec56cbfe4 100644 --- a/grammars/prelude/Predef.gf +++ b/grammars/prelude/Predef.gf @@ -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 } ; diff --git a/src/GF/API.hs b/src/GF/API.hs index 262c65382..db2e4a066 100644 --- a/src/GF/API.hs +++ b/src/GF/API.hs @@ -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 diff --git a/src/GF/Canon/AbsGFC.hs b/src/GF/Canon/AbsGFC.hs index 56adb3b4e..a95dbce0f 100644 --- a/src/GF/Canon/AbsGFC.hs +++ b/src/GF/Canon/AbsGFC.hs @@ -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 diff --git a/src/GF/Canon/CanonToGrammar.hs b/src/GF/Canon/CanonToGrammar.hs index e42c273cb..1a677e1a9 100644 --- a/src/GF/Canon/CanonToGrammar.hs +++ b/src/GF/Canon/CanonToGrammar.hs @@ -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 diff --git a/src/GF/Canon/GFC.hs b/src/GF/Canon/GFC.hs index 63b697a35..48c77dfe3 100644 --- a/src/GF/Canon/GFC.hs +++ b/src/GF/Canon/GFC.hs @@ -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 diff --git a/src/GF/Canon/LexGFC.hs b/src/GF/Canon/LexGFC.hs index 56048dce3..a4b4de7d7 100644 --- a/src/GF/Canon/LexGFC.hs +++ b/src/GF/Canon/LexGFC.hs @@ -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)])) diff --git a/src/GF/Canon/MkGFC.hs b/src/GF/Canon/MkGFC.hs index 25feb5a47..d747634d2 100644 --- a/src/GF/Canon/MkGFC.hs +++ b/src/GF/Canon/MkGFC.hs @@ -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 diff --git a/src/GF/Canon/PrintGFC.hs b/src/GF/Canon/PrintGFC.hs index bc89ffd6f..81bea7b34 100644 --- a/src/GF/Canon/PrintGFC.hs +++ b/src/GF/Canon/PrintGFC.hs @@ -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]) diff --git a/src/GF/Canon/SkelGFC.hs b/src/GF/Canon/SkelGFC.hs index 955cc442f..2b4323356 100644 --- a/src/GF/Canon/SkelGFC.hs +++ b/src/GF/Canon/SkelGFC.hs @@ -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 diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index 544214cb9..07151d8b7 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/src/GF/Compile/CheckGrammar.hs @@ -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 diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs index 23833a3c2..07708dd3c 100644 --- a/src/GF/Compile/GrammarToCanon.hs +++ b/src/GF/Compile/GrammarToCanon.hs @@ -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 diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs index eb6f6dcb9..a4d9b9365 100644 --- a/src/GF/Compile/Rename.hs +++ b/src/GF/Compile/Rename.hs @@ -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) diff --git a/src/GF/Grammar/AppPredefined.hs b/src/GF/Grammar/AppPredefined.hs index f59c910b0..14f35a1d4 100644 --- a/src/GF/Grammar/AppPredefined.hs +++ b/src/GF/Grammar/AppPredefined.hs @@ -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 + diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs index ee018791a..a2978d6b3 100644 --- a/src/GF/Grammar/Grammar.hs +++ b/src/GF/Grammar/Grammar.hs @@ -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]) diff --git a/src/GF/Grammar/LookAbs.hs b/src/GF/Grammar/LookAbs.hs index 8400d9af5..43a8c580a 100644 --- a/src/GF/Grammar/LookAbs.hs +++ b/src/GF/Grammar/LookAbs.hs @@ -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 diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs index 01b789f8f..bae22219f 100644 --- a/src/GF/Infra/Modules.hs +++ b/src/GF/Infra/Modules.hs @@ -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 diff --git a/src/GF/Infra/ReadFiles.hs b/src/GF/Infra/ReadFiles.hs index f755397f2..5e4d2b165 100644 --- a/src/GF/Infra/ReadFiles.hs +++ b/src/GF/Infra/ReadFiles.hs @@ -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' diff --git a/src/GF/Source/AbsGF.hs b/src/GF/Source/AbsGF.hs index ce307ee17..0dd825891 100644 --- a/src/GF/Source/AbsGF.hs +++ b/src/GF/Source/AbsGF.hs @@ -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] diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs index a211605fc..73f65c85c 100644 --- a/src/GF/Source/GrammarToSource.hs +++ b/src/GF/Source/GrammarToSource.hs @@ -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 diff --git a/src/GF/Source/PrintGF.hs b/src/GF/Source/PrintGF.hs index fbb5afafa..3024d49db 100644 --- a/src/GF/Source/PrintGF.hs +++ b/src/GF/Source/PrintGF.hs @@ -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]) diff --git a/src/GF/Source/SkelGF.hs b/src/GF/Source/SkelGF.hs index f18b5bd7b..5f5c16227 100644 --- a/src/GF/Source/SkelGF.hs +++ b/src/GF/Source/SkelGF.hs @@ -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 diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs index b6c3f3a44..9e016d711 100644 --- a/src/GF/Source/SourceToGrammar.hs +++ b/src/GF/Source/SourceToGrammar.hs @@ -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 diff --git a/src/GF/UseGrammar/Transfer.hs b/src/GF/UseGrammar/Transfer.hs new file mode 100644 index 000000000..2551a039d --- /dev/null +++ b/src/GF/UseGrammar/Transfer.hs @@ -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) diff --git a/src/Today.hs b/src/Today.hs index bf8573337..923866d3b 100644 --- a/src/Today.hs +++ b/src/Today.hs @@ -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"