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

printing to LBNF with profiles

Browse Source
This commit is contained in:
aarne
2004-09-22 15:12:49 +00:00
parent 0ff7e33a85
commit 8cd24e0b91
4 changed files with 78 additions and 47 deletions
Download Patch File Download Diff File Expand all files Collapse all files

24
examples/gfcc/Imper.gf
View File

@@ -1,8 +1,9 @@
abstract Imper = {
abstract Imper = PredefAbs ** {
cat
Program ;
Typ ;
NumTyp ;
ListTyp ;
Fun ListTyp Typ ;
Body ListTyp ;
@@ -17,6 +18,7 @@ abstract Imper = {
Body AS -> (Fun AS V -> Program) -> Program ;
BodyNil : Stm -> Body NilTyp ;
BodyOne : (A : Typ) -> (Var A -> Stm) -> Body (ConsTyp A NilTyp) ;
BodyCons : (A : Typ) -> (AS : ListTyp) ->
(Var A -> Body AS) -> Body (ConsTyp A AS) ;
@@ -29,22 +31,20 @@ abstract Imper = {
End : Stm ;
EVar : (A : Typ) -> Var A -> Exp A ;
EInt : Int -> Exp TInt ;
EFloat : Int -> Int -> Exp TFloat ;
ELtI : Exp TInt -> Exp TInt -> Exp TInt ;
ELtF : Exp TFloat -> Exp TFloat -> Exp TInt ;
EInt : Int -> Exp (TNum TInt) ;
EFloat : Int -> Int -> Exp (TNum TFloat) ;
ELt : (n : NumTyp) -> let Ex = Exp (TNum n) in Ex -> Ex -> Exp (TNum TInt) ;
EApp : (AS : ListTyp) -> (V : Typ) -> Fun AS V -> ListExp AS -> Exp V ;
EAddI, EMulI, ESubI : Exp TInt -> Exp TInt -> Exp TInt ;
EAddF, EMulF, ESubF : Exp TFloat -> Exp TFloat -> Exp TFloat ;
TInt : Typ ;
TFloat : Typ ;
EAdd, EMul, ESub : (n : NumTyp) -> let Ex = Exp (TNum n) in Ex -> Ex -> Ex ;
TNum : NumTyp -> Typ ;
TInt, TFloat : NumTyp ;
NilTyp : ListTyp ;
ConsTyp : Typ -> ListTyp -> ListTyp ;
NilExp : ListExp NilTyp ;
OneExp : (A : Typ) -> Exp A -> ListExp (ConsTyp A NilTyp) ;
ConsExp : (A : Typ) -> (AS : ListTyp) ->
Exp A -> ListExp AS -> ListExp (ConsExp A AS) ;
Exp A -> ListExp AS -> ListExp (ConsTyp A AS) ;
}

35
examples/gfcc/ImperC.gf
View File

@@ -1,10 +1,10 @@
--# -path=.:../prelude
concrete ImperC of Imper = open ResImper in {
flags lexer=codevars ; unlexer=code ; startcat=Stm ;
lincat
Exp = PrecExp ;
Body = {s,s2 : Str ; size : Size} ;
ListExp = {s : Str ; size : Size} ;
Body = {s,s2 : Str} ;
lin
Empty = ss [] ;
@@ -12,11 +12,13 @@ concrete ImperC of Imper = open ResImper in {
val.s ++ cont.$0 ++ paren body.s2 ++ "{" ++
body.s ++ "}" ++ ";" ++ cont.s) ;
BodyNil stm = stm ** {s2 = [] ; size = Zero} ;
BodyNil stm = stm ** {s2 = []} ;
BodyOne typ stm = stm ** {
s2 = typ.s ++ stm.$0
} ;
BodyCons typ _ body = {
s = body.s ;
s2 = typ.s ++ body.$0 ++ separator "," body.size ++ body.s2 ;
size = nextSize body.size
s2 = typ.s ++ body.$0 ++ "," ++ body.s2 ;
} ;
Decl typ cont = continues (typ.s ++ cont.$0) cont ;
@@ -27,24 +29,23 @@ concrete ImperC of Imper = open ResImper in {
Block stm = continue ("{" ++ stm.s ++ "}") ;
End = ss [] ;
EVar _ x = constant x.s ;
EInt n = constant n.s ;
EFloat a b = constant (a.s ++ "." ++ b.s) ;
EMulI, EMulF = infixL P2 "*" ;
EAddI, EAddF = infixL P1 "+" ;
ESubI, ESubF = infixL P1 "-" ;
ELtI, ELtF = infixN P0 "<" ;
EVar _ x = constant x.s ;
EInt n = constant n.s ;
EFloat a b = constant (a.s ++ "." ++ b.s) ;
EMul _ = infixL P2 "*" ;
EAdd _ = infixL P1 "+" ;
ESub _ = infixL P1 "-" ;
ELt _ = infixN P0 "<" ;
EApp args val f exps = constant (f.s ++ paren exps.s) ;
TNum t = t ;
TInt = ss "int" ;
TFloat = ss "float" ;
NilTyp = ss [] ;
ConsTyp = cc2 ;
NilExp = ss [] ** {size = Zero} ;
ConsExp _ _ e es = {
s = ex e ++ separator "," es.size ++ es.s ;
size = nextSize es.size
} ;
NilExp = ss [] ;
OneExp _ e = ss (ex e) ;
ConsExp _ _ e es = ss (ex e ++ "," ++ es.s) ;
}

43
src/GF/CF/PrLBNF.hs
View File

@@ -11,14 +11,16 @@ import Char
-- Printing CF grammars generated from GF as LBNF grammar for BNFC.
-- AR 26/1/2000 -- 9/6/2003 (PPrCF) -- 8/11/2003
-- With a primitive error messaging, by rules and rule tails commented out
-- With primitive error messaging, by rules and rule tails commented out
prLBNF :: CF -> String
prLBNF = unlines . (map prCFRule) . rulesOfCF -- hiding the literal recogn function
prLBNF cf = unlines $ (map (prCFRule cs)) $ rulesOfCF cf --- no literal recogn function
where
cs = map IC ["Int","String"] ++ [catId c | (_,(c,_)) <- rulesOfCF cf]
-- a hack to hide the LBNF details
prBNF :: CF -> String
prBNF = unlines . (map (unwords . unLBNF . drop 1 . words . prCFRule)) . rulesOfCF
prBNF = unlines . (map (unwords . unLBNF . drop 1 . words)) . lines . prLBNF
where
unLBNF r = case r of
"---":ts -> ts
@@ -26,25 +28,35 @@ prBNF = unlines . (map (unwords . unLBNF . drop 1 . words . prCFRule)) . rulesOf
c:ts -> c : unLBNF ts
_ -> r
prCFRule :: CFRule -> String
prCFRule (fun,(cat,its)) =
prCFFun fun ++ "." +++ prCFCat True cat +++ "::=" +++ --- err in cat -> in syntax
unwords (map prCFItem its) +++ ";"
catId ((CFCat ((CIQ _ c),l))) = c
prCFFun :: CFFun -> String
prCFFun (CFFun (t, p)) = case t of
AC (CIQ _ x) -> prId True x
AD (CIQ _ x) -> prId True x
prCFRule :: [Ident] -> CFRule -> String
prCFRule cs (fun,(cat,its)) =
prCFFun cat fun ++ "." +++ prCFCat True cat +++ "::=" +++ --- err in cat -> in syntax
unwords (map (prCFItem cs) its) +++ ";"
prCFFun :: CFCat -> CFFun -> String
prCFFun (CFCat (_,l)) (CFFun (t, p)) = case t of
AC (CIQ _ x) -> let f = prId True x in (f ++ lab +++ f2 f +++ prP p)
AD (CIQ _ x) -> let f = prId True x in (f ++ lab +++ f2 f +++ prP p)
_ -> prErr True $ prt t
where
lab = prLab l
f2 f = if null lab then "" else f
prP = concatMap show
prId b i = case i of
IC "Int" -> "Integer"
IC "Int" -> "Integer"
IC "#Var" -> "Ident"
IC "Var" -> "Ident"
IC "id_" -> "_"
IC s@(c:_) | isUpper c -> s ++ if isDigit (last s) then "_" else ""
_ -> prErr b $ prt i
prLab i = case i of
L (IC "s") -> "" ---
_ -> "_" ++ prt i
L (IC "_") -> "" ---
_ -> let x = prt i in "_" ++ x ++ if isDigit (last x) then "_" else ""
-- just comment out the rest if you cannot interpret the function name in LBNF
-- two versions, depending on whether in the beginning of a rule or elsewhere;
@@ -55,8 +67,9 @@ prErr b s = (if b then "" else " ;") +++ "---" +++ s
prCFCat :: Bool -> CFCat -> String
prCFCat b (CFCat ((CIQ _ c),l)) = prId b c ++ prLab l ----
prCFItem (CFNonterm c) = prCFCat False c
prCFItem (CFTerm a) = prRegExp a
-- if a category does not have a production of its own, we replace it by Ident
prCFItem cs (CFNonterm c) = if elem (catId c) cs then prCFCat False c else "Ident"
prCFItem _ (CFTerm a) = prRegExp a
prRegExp (RegAlts tt) = case tt of
[t] -> prQuotedString t

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

@@ -78,15 +78,32 @@ checkAbsInfo st m (c,info) = do
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!
AbsFun (Yes typ0) md -> do
typ <- compAbsTyp [] typ0 -- to calculate let definitions
mkCheck "function" $
checkTyp st typ ++
case md of
Yes d -> checkEquation st (m,c) d
_ -> []
return $ (c,AbsFun (Yes typ) md)
_ -> return (c,info)
where
mkCheck cat ss = case ss of
[] -> return (c,info)
["[]"] -> return (c,info) ----
_ -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c
compAbsTyp g t = case t of
Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g
Let (x,(_,a)) b -> do
a' <- compAbsTyp g a
compAbsTyp ((x, a'):g) b
Prod x a b -> do
a' <- compAbsTyp g a
b' <- compAbsTyp ((x,Vr x):g) b
return $ Prod x a' b'
Abs _ _ -> return t
_ -> composOp (compAbsTyp g) t
checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check ()
checkCompleteGrammar abs cnc = mapM_ checkWarn $