From 8de623d11e9d4e495499c4fd2e29cc9699a6b046 Mon Sep 17 00:00:00 2001 From: aarne Date: Thu, 13 Dec 2007 16:36:32 +0000 Subject: [PATCH] lisp-like GFCC syntax; doesn't quite work yet in gf3 --- lib/resource/Makefile | 7 ++ lib/resource/russian/ResRus.gf | 2 +- src/GF/GFCC/DataGFCC.hs | 111 +++++++++++++++---------------- src/GF/GFCC/Raw/ConvertGFCC.hs | 118 +++++++++++++++++++++++++++++++++ src/GF/GFCC/Raw/GFCCRaw.cf | 110 ++++++++++++++++++++++++++++++ 5 files changed, 289 insertions(+), 59 deletions(-) create mode 100644 src/GF/GFCC/Raw/ConvertGFCC.hs create mode 100644 src/GF/GFCC/Raw/GFCCRaw.cf diff --git a/lib/resource/Makefile b/lib/resource/Makefile index 03b923ceb..54f56d73d 100644 --- a/lib/resource/Makefile +++ b/lib/resource/Makefile @@ -207,6 +207,13 @@ gf3present: # mv api/toplevel/Over*.gfc api/Try*.gf? ../present +gf3langs: + mv ../present/LangSpa.gfo tmpLangSpa.gfo + $(GFNew) -path=present:prelude -target=langs --make ../present/Lang???.gfo $(RTSS) + mv langs.gfcc ../present + mv tmpLangSpa.gfo ../present/LangSpa.gfo + + clean: -rm -f */*.gfc */*.gfr */*.gf~ ../*/*.gfc ../*/*.gfr ../*/*.gf~ ../*/langs.gfcm ../compiled.tgz diff --git a/lib/resource/russian/ResRus.gf b/lib/resource/russian/ResRus.gf index 7a901a597..ee5990fe5 100644 --- a/lib/resource/russian/ResRus.gf +++ b/lib/resource/russian/ResRus.gf @@ -104,7 +104,7 @@ param PronGen = PGen Gender | PNoGen ; oper pgen2gen : PronGen -> Gender = \p -> case p of { PGen g => g ; - PNoGen => variants {Masc ; Fem} --- the best we can do for ya, tu + PNoGen => Masc ---- variants {Masc ; Fem} --- the best we can do for ya, tu } ; diff --git a/src/GF/GFCC/DataGFCC.hs b/src/GF/GFCC/DataGFCC.hs index 69c9a8eb2..dce0fa4d4 100644 --- a/src/GF/GFCC/DataGFCC.hs +++ b/src/GF/GFCC/DataGFCC.hs @@ -1,6 +1,6 @@ module GF.GFCC.DataGFCC where -import GF.GFCC.AbsGFCC +import GF.GFCC.Raw.AbsGFCCRaw (CId (..)) import GF.GFCC.PrintGFCC import GF.Infra.CompactPrint import GF.Text.UTF8 @@ -35,6 +35,57 @@ data Concr = Concr { paramlincats :: Map CId Term -- lin type of cat, with printable param names } +data Type = + DTyp [Hypo] CId [Exp] + deriving (Eq,Ord,Show) + +data Exp = + DTr [CId] Atom [Exp] + | EEq [Equation] + deriving (Eq,Ord,Show) + +data Atom = + AC CId + | AS String + | AI Integer + | AF Double + | AM Integer + | AV CId + deriving (Eq,Ord,Show) + +data Term = + R [Term] + | P Term Term + | S [Term] + | K Tokn + | V Int + | C Int + | F CId + | FV [Term] + | W String Term + | TM + | RP Term Term + deriving (Eq,Ord,Show) + +data Tokn = + KS String + | KP [String] [Variant] + deriving (Eq,Ord,Show) + +data Variant = + Var [String] [String] + deriving (Eq,Ord,Show) + +data Hypo = + Hyp CId Type + deriving (Eq,Ord,Show) + +data Equation = + Equ [Exp] Exp + deriving (Eq,Ord,Show) + +-- print statistics + statGFCC :: GFCC -> String statGFCC gfcc = unlines [ "Abstract\t" ++ pr (absname gfcc), @@ -43,64 +94,8 @@ statGFCC gfcc = unlines [ ] where pr (CId s) = s --- convert parsed grammar to internal GFCC - -mkGFCC :: Grammar -> GFCC -mkGFCC (Grm a cs gfs ab@(Abs afls fs cts) ccs) = GFCC { - absname = a, - cncnames = cs, - gflags = fromAscList [(f,v) | Flg f v <- gfs], - abstract = - let - aflags = fromAscList [(f,v) | Flg f v <- afls] - lfuns = [(fun,(typ,def)) | Fun fun typ def <- fs] - funs = fromAscList lfuns - lcats = [(c,hyps) | Cat c hyps <- cts] - cats = fromAscList lcats - catfuns = fromAscList - [(cat,[f | (f, (DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] - in Abstr aflags funs cats catfuns, - concretes = fromAscList (lmap mkCnc ccs) - } - where - mkCnc (Cnc lang fls ls ops lincs linds prns params) = (lang, - Concr { - cflags = fromAscList [(f,v) | Flg f v <- fls], - lins = fromAscList [(f,v) | Lin f v <- ls], - opers = fromAscList [(f,v) | Lin f v <- ops], - lincats = fromAscList [(f,v) | Lin f v <- lincs], - lindefs = fromAscList [(f,v) | Lin f v <- linds], - printnames = fromAscList [(f,v) | Lin f v <- prns], - paramlincats = fromAscList [(f,v) | Lin f v <- params] - } - ) - --- convert internal GFCC and pretty-print it - -printGFCC :: GFCC -> String -printGFCC gfcc0 = compactPrintGFCC $ printTree $ Grm - (absname gfcc) - (cncnames gfcc) - [Flg f v | (f,v) <- assocs (gflags gfcc)] - (Abs - [Flg f v | (f,v) <- assocs (aflags (abstract gfcc))] - [Fun f ty df | (f,(ty,df)) <- assocs (funs (abstract gfcc))] - [Cat f v | (f,v) <- assocs (cats (abstract gfcc))] - ) - [fromCnc lang cnc | (lang,cnc) <- assocs (concretes gfcc)] - where - fromCnc lang cnc = Cnc lang - [Flg f v | (f,v) <- assocs (cflags cnc)] - [Lin f v | (f,v) <- assocs (lins cnc)] - [Lin f v | (f,v) <- assocs (opers cnc)] - [Lin f v | (f,v) <- assocs (lincats cnc)] - [Lin f v | (f,v) <- assocs (lindefs cnc)] - [Lin f v | (f,v) <- assocs (printnames cnc)] - [Lin f v | (f,v) <- assocs (paramlincats cnc)] - gfcc = utf8GFCC gfcc0 - printCId :: CId -> String -printCId = printTree +printCId (CId s) = s -- merge two GFCCs; fails is differens absnames; priority to second arg diff --git a/src/GF/GFCC/Raw/ConvertGFCC.hs b/src/GF/GFCC/Raw/ConvertGFCC.hs new file mode 100644 index 000000000..18ac742c4 --- /dev/null +++ b/src/GF/GFCC/Raw/ConvertGFCC.hs @@ -0,0 +1,118 @@ +module GF.GFCC.Raw.ConvertGFCC where + +import GF.GFCC.DataGFCC +import GF.GFCC.Raw.AbsGFCCRaw + +import Data.Map + +-- convert parsed grammar to internal GFCC + +mkGFCC :: Grammar -> GFCC +mkGFCC (Grm [ + App (CId "abstract") [AId a], + App (CId "concrete") cs, + App (CId "flags") gfs, + ab@( + App (CId "abstract") [ + App (CId "flags") afls, + App (CId "fun") fs, + App (CId "cat") cts + ]), + App (CId "concrete") ccs + ]) = GFCC { + absname = a, + cncnames = [c | AId c <- cs], + gflags = fromAscList [(f,v) | App f [AStr v] <- gfs], + abstract = + let + aflags = fromAscList [(f,v) | App f [AStr v] <- afls] + lfuns = [(f,(toType typ,toExp def)) | App f [typ, def] <- fs] + funs = fromAscList lfuns + lcats = [(c, Prelude.map toHypo hyps) | App c hyps <- cts] + cats = fromAscList lcats + catfuns = fromAscList + [(cat,[f | (f, (DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] + in Abstr aflags funs cats catfuns, + concretes = fromAscList (lmap mkCnc ccs) + } + where + mkCnc ( + App (CId "concrete") [ + AId lang, + App (CId "flags") fls, + App (CId "lin") ls, + App (CId "oper") ops, + App (CId "lincat") lincs, + App (CId "lindef") linds, + App (CId "printname") prns, + App (CId "param") params + ]) = (lang, + Concr { + cflags = fromAscList [(f,v) | App f [AStr v] <- afls], + lins = fromAscList [(f,toTerm v) | App f [v] <- ls], + opers = fromAscList [(f,toTerm v) | App f [v] <- ops], + lincats = fromAscList [(f,toTerm v) | App f [v] <- lincs], + lindefs = fromAscList [(f,toTerm v) | App f [v] <- linds], + printnames = fromAscList [(f,toTerm v) | App f [v] <- prns], + paramlincats = fromAscList [(f,toTerm v) | App f [v] <- params] + } + ) + +toType :: RExp -> Type +toType e = case e of + App cat [App (CId "hypo") hypos, App (CId "arg") exps] -> + DTyp (lmap toHypo hypos) cat (lmap toExp exps) + _ -> error $ "type " ++ show e + +toHypo :: RExp -> Hypo +toHypo e = case e of + App x [typ] -> Hyp x (toType typ) + _ -> error $ "hypo " ++ show e + +toExp :: RExp -> Exp +toExp e = case e of + App fun [App (CId "abs") xs, App (CId "arg") exps] -> + DTr [x | AId x <- xs] (AC fun) (lmap toExp exps) + _ -> error $ "exp " ++ show e + +toTerm :: RExp -> Term +toTerm e = case e of + App (CId "R") es -> R (lmap toTerm es) + App (CId "S") es -> S (lmap toTerm es) + App (CId "FV") es -> FV (lmap toTerm es) + App (CId "P") [e,v] -> P (toTerm e) (toTerm v) + App (CId "RP") [e,v] -> RP (toTerm e) (toTerm v) ---- + App (CId "W") [AStr s,v] -> W s (toTerm v) + AInt i -> C (fromInteger i) + AMet -> TM + AId f -> F f + App (CId "A") [AInt i] -> V (fromInteger i) + AStr s -> K (KS s) ---- + _ -> error $ "term " ++ show e + + +{- +-- convert internal GFCC and pretty-print it + +printGFCC :: GFCC -> String +printGFCC gfcc0 = compactPrintGFCC $ printTree $ Grm + (absname gfcc) + (cncnames gfcc) + [Flg f v | (f,v) <- assocs (gflags gfcc)] + (Abs + [Flg f v | (f,v) <- assocs (aflags (abstract gfcc))] + [Fun f ty df | (f,(ty,df)) <- assocs (funs (abstract gfcc))] + [Cat f v | (f,v) <- assocs (cats (abstract gfcc))] + ) + [fromCnc lang cnc | (lang,cnc) <- assocs (concretes gfcc)] + where + fromCnc lang cnc = Cnc lang + [Flg f v | (f,v) <- assocs (cflags cnc)] + [Lin f v | (f,v) <- assocs (lins cnc)] + [Lin f v | (f,v) <- assocs (opers cnc)] + [Lin f v | (f,v) <- assocs (lincats cnc)] + [Lin f v | (f,v) <- assocs (lindefs cnc)] + [Lin f v | (f,v) <- assocs (printnames cnc)] + [Lin f v | (f,v) <- assocs (paramlincats cnc)] + gfcc = utf8GFCC gfcc0 +-} diff --git a/src/GF/GFCC/Raw/GFCCRaw.cf b/src/GF/GFCC/Raw/GFCCRaw.cf new file mode 100644 index 000000000..2ec3fac52 --- /dev/null +++ b/src/GF/GFCC/Raw/GFCCRaw.cf @@ -0,0 +1,110 @@ +Grm. Grammar ::= [RExp] ; + +App. RExp ::= "(" CId [RExp] ")" ; +AId. RExp ::= CId ; +AInt. RExp ::= Integer ; +AStr. RExp ::= String ; +AFlt. RExp ::= Double ; +AMet. RExp ::= "?" ; + +terminator RExp "" ; + +token CId (('_' | letter) (letter | digit | '\'' | '_')*) ; + + + + + + + + + + + + + + + + +{- +Grm. Grammar ::= + "grammar" CId "(" [CId] ")" "(" [Flag] ")" ";" + Abstract ";" + [Concrete] ; + +Abs. Abstract ::= + "abstract" "{" + "flags" [Flag] + "fun" [FunDef] + "cat" [CatDef] + "}" ; + +Cnc. Concrete ::= + "concrete" CId "{" + "flags" [Flag] + "lin" [LinDef] + "oper" [LinDef] + "lincat" [LinDef] + "lindef" [LinDef] + "printname" [LinDef] + "param" [LinDef] -- lincats with param value names + "}" ; + +Flg. Flag ::= CId "=" String ; +Cat. CatDef ::= CId "[" [Hypo] "]" ; + +Fun. FunDef ::= CId ":" Type "=" Exp ; +Lin. LinDef ::= CId "=" Term ; + +DTyp. Type ::= "[" [Hypo] "]" CId [Exp] ; -- dependent type +DTr. Exp ::= "[" "(" [CId] ")" Atom [Exp] "]" ; -- term with bindings + +AC. Atom ::= CId ; +AS. Atom ::= String ; +AI. Atom ::= Integer ; +AF. Atom ::= Double ; +AM. Atom ::= "?" Integer ; + +R. Term ::= "[" [Term] "]" ; -- record/table +P. Term ::= "(" Term "!" Term ")" ; -- projection/selection +S. Term ::= "(" [Term] ")" ; -- concatenated sequence +K. Term ::= Tokn ; -- token +V. Term ::= "$" Integer ; -- argument +C. Term ::= Integer ; -- parameter value/label +F. Term ::= CId ; -- global constant +FV. Term ::= "[|" [Term] "|]" ; -- free variation +W. Term ::= "(" String "+" Term ")" ; -- prefix + suffix table +TM. Term ::= "?" ; -- lin of metavariable + +KS. Tokn ::= String ; +KP. Tokn ::= "[" "pre" [String] "[" [Variant] "]" "]" ; +Var. Variant ::= [String] "/" [String] ; + + +RP. Term ::= "(" Term "@" Term ")"; -- DEPRECATED: record parameter alias + +terminator Concrete ";" ; +terminator Flag ";" ; +terminator CatDef ";" ; +terminator FunDef ";" ; +terminator LinDef ";" ; +separator CId "," ; +separator Term "," ; +terminator Exp "" ; +terminator String "" ; +separator Variant "," ; + + + +-- the following are needed if dependent types or HOAS or defs are present + +Hyp. Hypo ::= CId ":" Type ; +AV. Atom ::= "$" CId ; + +EEq. Exp ::= "{" [Equation] "}" ; -- list of pattern eqs; primitive: [] +Equ. Equation ::= [Exp] "->" Exp ; -- patterns are encoded as exps + +separator Hypo "," ; +terminator Equation ";" ; + +-}