mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
lisp-like GFCC syntax; doesn't quite work yet in gf3
This commit is contained in:
aarne
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
} ;
|
||||
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
118
src/GF/GFCC/Raw/ConvertGFCC.hs
Normal file
118
src/GF/GFCC/Raw/ConvertGFCC.hs
Normal file
@@ -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
|
||||
-}
|
||||
110
src/GF/GFCC/Raw/GFCCRaw.cf
Normal file
110
src/GF/GFCC/Raw/GFCCRaw.cf
Normal file
@@ -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 ";" ;
|
||||
|
||||
-}
|
||||
Reference in New Issue
Block a user