msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

new constructs in gfcc, removed lambda

Browse Source
This commit is contained in:
aarne
2006-09-29 10:55:36 +00:00
parent f6856c65e3
commit 1dd70a285e
12 changed files with 550 additions and 399 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
src/GF/Canon/GFCC/AbsGFCC.hs
View File

@@ -21,10 +21,12 @@ data Concrete =
data AbsDef =
Fun CId Type Exp
| AFl CId String
deriving (Eq,Ord,Show)
data CncDef =
Lin CId Term
| CFl CId String
deriving (Eq,Ord,Show)
data Type =
@@ -39,6 +41,8 @@ data Atom =
AC CId
| AS String
| AI Integer
| AF Double
| AM
deriving (Eq,Ord,Show)
data Term =
@@ -49,10 +53,9 @@ data Term =
| V Integer
| C Integer
| F CId
| L CId
| A CId Term
| FV [Term]
| W String Term
| RP Term Term
deriving (Eq,Ord,Show)
data Tokn =

60
src/GF/Canon/GFCC/DataGFCC.hs
View File

@@ -50,8 +50,10 @@ linExp :: GFCC -> CId -> Exp -> Term
linExp mcfg lang tree@(Tr at trees) =
case at of
AC fun -> comp (Prelude.map lin trees) $ look fun
AS s -> R [kks s] ---- quoted
AS s -> R [kks (show s)] -- quoted
AI i -> R [kks (show i)]
AF d -> R [kks (show d)]
AM -> R [kks "?"]
where
lin = linExp mcfg lang
comp = compute mcfg lang
@@ -66,14 +68,17 @@ term0 = kks "UNKNOWN_ID"
kks :: String -> Term
kks = K . KS
compute :: GFCC -> CId -> [Term] -> Term -> Term
compute mcfg lang args = compg [] where
compg g trm = case trm of
P r (FV ts) -> FV $ Prelude.map (comp . P r) ts
-- for the abstraction optimization
P (A x t) p -> compg ((x,comp p):g) t
L x -> maybe (error (show x)) id $ Prelude.lookup x g
-- P (A x t) p -> compg ((x,comp p):g) t
-- L x -> maybe (error (show x)) id $ Prelude.lookup x g
P r p -> case (comp r, comp p) of
@@ -84,10 +89,19 @@ compute mcfg lang args = compg [] where
R ss -> case comp $ idx ss (fromInteger i) of
K (KS u) -> kks (s ++ u) -- the only case where W occurs
(R [C _ , R rs], C i) -> comp $ idx rs (fromInteger i)
----TODO: this is only needed because of some GFCC compilation bug
-- (R [C _ , R rs], C i) -> comp $ idx rs (fromInteger i)
(R rs, R (C i : _)) -> comp $ idx rs (fromInteger i)
-- parameter record
(RP _ (R rs), C i) -> comp $ idx rs (fromInteger i)
(R rs, RP t _) -> case comp t of
C i -> comp $ idx rs (fromInteger i)
RP (C i) _ -> comp $ idx rs (fromInteger i) ---- why?
(R rs, C i) -> comp $ idx rs (fromInteger i)
(r',p') -> P r' p'
RP i t -> RP (comp i) (comp t)
W s t -> W s (comp t)
R ts -> R $ Prelude.map comp ts
V i -> idx args (fromInteger i) -- already computed
@@ -103,6 +117,44 @@ compute mcfg lang args = compg [] where
then K (KS ("ERROR" ++ show xs ++ " !! " ++ show i)) else
xs !! i
{-
compute :: GFCC -> CId -> [Term] -> Term -> Term
compute mcfg lang args = comp where
comp trm = case trm of
P r (FV ts) -> FV $ Prelude.map (comp . P r) ts
P r p -> case (comp r, comp p) of
-- suffix optimization
(W s t, R (C i : _)) -> comp $ P (W s t) (C i)
(W s t, C i) -> case comp t of
R ss -> case comp $ idx ss (fromInteger i) of
K (KS u) -> kks (s ++ u) -- the only case where W occurs
-- parameter record
(RP _ (R rs), C i) -> comp $ idx rs (fromInteger i)
(R rs, RP i _) -> comp $ idx rs (fromInteger i)
-- normal case
(R rs, C i) -> comp $ idx rs (fromInteger i)
(r',p') -> P r' p'
W s t -> W s (comp t)
R ts -> R $ Prelude.map comp ts
RP i t -> RP i $ comp t
V i -> idx args (fromInteger i) -- already computed
S ts -> S $ Prelude.filter (/= S []) $ Prelude.map comp ts
F c -> comp $ look c -- global const: not comp'd (if contains argvar)
FV ts -> FV $ Prelude.map comp ts
_ -> trm
look = lookLin mcfg lang
idx xs i =
if length xs <= i ---- debug
then K (KS ("ERROR" ++ show xs ++ " !! " ++ show i)) else
xs !! i
-}
mkGFCC :: Grammar -> GFCC
mkGFCC (Grm (Hdr a cs) ab@(Abs funs) ccs) = GFCC {
absname = a,

2
src/GF/Canon/GFCC/ErrM.hs
View File

@@ -2,7 +2,7 @@
-- Copyright (C) 2004 Author: Aarne Ranta
-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
module ErrM where
module GF.Canon.GFCC.ErrM where
-- the Error monad: like Maybe type with error msgs

10
src/GF/Canon/GFCC/GFCC.cf
View File

@@ -1,19 +1,20 @@
Grm. Grammar ::= Header ";" Abstract ";" [Concrete] ";" ;
Hdr. Header ::= "grammar" CId "(" [CId] ")" ;
Abs. Abstract ::= "abstract" "{" [AbsDef] "}" ";" ;
Cnc. Concrete ::= "concrete" CId "{" [CncDef] "}" ;
Fun. AbsDef ::= CId ":" Type "=" Exp ;
AFl. AbsDef ::= "%" CId "=" String ; -- flag
Lin. CncDef ::= CId "=" Term ;
CFl. CncDef ::= "%" CId "=" String ; -- flag
Typ. Type ::= [CId] "->" CId ;
Tr. Exp ::= "(" Atom [Exp] ")" ;
AC. Atom ::= CId ;
AS. Atom ::= String ;
AI. Atom ::= Integer ;
AF. Atom ::= Double ;
AM. Atom ::= "?" ;
trA. Exp ::= Atom ;
define trA a = Tr a [] ;
@@ -24,10 +25,9 @@ K. Term ::= Tokn ; -- token
V. Term ::= "$" Integer ; -- argument
C. Term ::= Integer ; -- parameter value/label
F. Term ::= CId ; -- global constant
L. Term ::= "$" CId ; -- local (bound) variable
A. Term ::= "(" CId "->" Term ")" ; -- lambda abstraction (compressed table)
FV. Term ::= "[|" [Term] "|]" ; -- free variation
W. Term ::= "(" String "+" Term ")" ; -- prefix + suffix table
RP. Term ::= "(" Term "@" Term ")"; -- record parameter alias
KS. Tokn ::= String ;
KP. Tokn ::= "[" "pre" [String] "[" [Variant] "]" "]" ;

22
src/GF/Canon/GFCC/LexGFCC.hs
View File

File diff suppressed because one or more lines are too long

742
src/GF/Canon/GFCC/ParGFCC.hs
View File

File diff suppressed because it is too large Load Diff

9
src/GF/Canon/GFCC/PrintGFCC.hs
View File

@@ -4,7 +4,7 @@ module GF.Canon.GFCC.PrintGFCC where
-- pretty-printer generated by the BNF converter
import GF.Canon.GFCC.AbsGFCC
import Data.Char
import Char
-- the top-level printing method
printTree :: Print a => a -> String
@@ -112,6 +112,7 @@ instance Print Concrete where
instance Print AbsDef where
prt i e = case e of
Fun cid type' exp -> prPrec i 0 (concatD [prt 0 cid , doc (showString ":") , prt 0 type' , doc (showString "=") , prt 0 exp])
AFl cid str -> prPrec i 0 (concatD [doc (showString "%") , prt 0 cid , doc (showString "=") , prt 0 str])
prtList es = case es of
[] -> (concatD [])
@@ -120,6 +121,7 @@ instance Print AbsDef where
instance Print CncDef where
prt i e = case e of
Lin cid term -> prPrec i 0 (concatD [prt 0 cid , doc (showString "=") , prt 0 term])
CFl cid str -> prPrec i 0 (concatD [doc (showString "%") , prt 0 cid , doc (showString "=") , prt 0 str])
prtList es = case es of
[] -> (concatD [])
@@ -143,6 +145,8 @@ instance Print Atom where
AC cid -> prPrec i 0 (concatD [prt 0 cid])
AS str -> prPrec i 0 (concatD [prt 0 str])
AI n -> prPrec i 0 (concatD [prt 0 n])
AF d -> prPrec i 0 (concatD [prt 0 d])
AM -> prPrec i 0 (concatD [doc (showString "?")])
instance Print Term where
@@ -154,10 +158,9 @@ instance Print Term where
V n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n])
C n -> prPrec i 0 (concatD [prt 0 n])
F cid -> prPrec i 0 (concatD [prt 0 cid])
L cid -> prPrec i 0 (concatD [doc (showString "$") , prt 0 cid])
A cid term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 cid , doc (showString "->") , prt 0 term , doc (showString ")")])
FV terms -> prPrec i 0 (concatD [doc (showString "[|") , prt 0 terms , doc (showString "|]")])
W str term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 str , doc (showString "+") , prt 0 term , doc (showString ")")])
RP term0 term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "@") , prt 0 term , doc (showString ")")])
prtList es = case es of
[] -> (concatD [])

9
src/GF/Canon/GFCC/RunGFCC.hs
View File

@@ -5,7 +5,8 @@ import GF.Canon.GFCC.DataGFCC
import GF.Canon.GFCC.AbsGFCC
import GF.Canon.GFCC.ParGFCC
import GF.Canon.GFCC.PrintGFCC
import GF.Data.Operations
import GF.Canon.GFCC.ErrM
--import GF.Data.Operations
import Data.Map
import System.Random (newStdGen)
import System
@@ -56,7 +57,11 @@ file2gfcc f =
readFile f >>= err (error "no parse") (return . mkGFCC) . pGrammar . myLexer
readExp :: String -> Exp
readExp = errVal exp0 . (pExp . myLexer)
readExp = err (const exp0) id . (pExp . myLexer)
err f g ex = case ex of
Ok x -> g x
Bad s -> f s
{-

11
src/GF/Canon/GFCC/SkelGFCC.hs
View File

@@ -1,9 +1,9 @@
module SkelGFCC where
module GF.Canon.GFCC.SkelGFCC where
-- Haskell module generated by the BNF converter
import AbsGFCC
import ErrM
import GF.Canon.GFCC.AbsGFCC
import GF.Canon.GFCC.ErrM
type Result = Err String
failure :: Show a => a -> Result
@@ -37,11 +37,13 @@ transConcrete x = case x of
transAbsDef :: AbsDef -> Result
transAbsDef x = case x of
Fun cid type' exp -> failure x
AFl cid str -> failure x
transCncDef :: CncDef -> Result
transCncDef x = case x of
Lin cid term -> failure x
CFl cid str -> failure x
transType :: Type -> Result
@@ -59,6 +61,8 @@ transAtom x = case x of
AC cid -> failure x
AS str -> failure x
AI n -> failure x
AF d -> failure x
AM -> failure x
transTerm :: Term -> Result
@@ -72,6 +76,7 @@ transTerm x = case x of
F cid -> failure x
FV terms -> failure x
W str term -> failure x
RP term0 term -> failure x
transTokn :: Tokn -> Result

12
src/GF/Canon/GFCC/TestGFCC.hs
View File

@@ -5,16 +5,16 @@ module Main where
import IO ( stdin, hGetContents )
import System ( getArgs, getProgName )
import LexGFCC
import ParGFCC
import SkelGFCC
import PrintGFCC
import AbsGFCC
import GF.Canon.GFCC.LexGFCC
import GF.Canon.GFCC.ParGFCC
import GF.Canon.GFCC.SkelGFCC
import GF.Canon.GFCC.PrintGFCC
import GF.Canon.GFCC.AbsGFCC
import ErrM
import GF.Canon.GFCC.ErrM
type ParseFun a = [Token] -> Err a