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

new constructs in gfcc, removed lambda

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

62
src/GF/Canon/CanonToGFCC.hs
View File

@@ -75,20 +75,21 @@ mkTerm :: Term -> C.Term
mkTerm tr = case tr of
Arg (A _ i) -> C.V i
EInt i -> C.C i
-- record parameter alias - created in gfc preprocessing
R [Ass (L (IC "_")) i, Ass (L (IC "__")) t] -> C.RP (mkTerm i) (mkTerm t)
-- ordinary record
R rs -> C.R [mkTerm t | Ass _ t <- rs]
P t l -> C.P (mkTerm t) (C.C (mkLab l))
T _ [Cas [PV (IC x)] t] -> C.A (C.CId x) (mkTerm t) -- abstraction
T _ cs -> C.R [mkTerm t | Cas _ t <- cs] --- should not appear after values opt
T _ cs -> error $ "improper optimization for gfcc in" +++ A.prt tr
V _ cs -> C.R [mkTerm t | t <- cs]
S t p -> C.P (mkTerm t) (mkTerm p)
C s t -> C.S [mkTerm x | x <- [s,t]]
LI(IC x) -> C.L (C.CId x)
FV ts -> C.FV [mkTerm t | t <- ts]
K (KS s) -> C.K (C.KS s)
K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants
E -> C.S []
Par _ _ -> prtTrace tr $ C.C 66661 ---- just for debugging
_ -> C.S [C.K (C.KS (A.prt tr +++ "66662"))] ---- just for debugging
E -> C.S []
Par _ _ -> prtTrace tr $ C.C 66661 ---- for debugging
_ -> C.S [C.K (C.KS (A.prt tr +++ "66662"))] ---- for debugging
where
mkLab (L (IC l)) = case l of
'_':ds -> (read ds) :: Integer
@@ -210,21 +211,28 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
Par _ _ -> mkValCase tr
R rs ->
let
rs' = [Ass (mkLab i) (t2t t) | (i,Ass l t) <- zip [0..] rs, not (isLock l t)]
rs' = [Ass (mkLab i) (t2t t) |
(i,Ass l t) <- zip [0..] rs, not (isLock l t)]
in if (any (isStr . trmAss) rs)
then R rs'
else R [Ass (mkLab 0) (mkValCase tr), Ass (mkLab 1) (R rs')]
else R [Ass (L (IC "_")) (mkValCase tr), Ass (L (IC "__")) (R rs')]
P t l -> r2r tr
T i [Cas p t] -> T i [Cas p (t2t t)]
T _ _ -> case expandLinTables cgr tr of -- to normalize the order of cases
Ok (T ty cs) -> V ty [t2t t | Cas _ t <- cs]
_ -> K (KS (A.prt tr +++ prtTrace tr "66668"))
T _ cs0 -> checkCases cs0 $
case expandLinTables cgr tr of -- normalize order of cases
Ok (T ty cs) -> V ty [t2t t | Cas _ t <- cs]
_ -> K (KS (A.prt tr +++ prtTrace tr "66668"))
V ty ts -> V ty [t2t t | t <- ts]
S t p -> S (t2t t) (t2t p)
_ -> composSafeOp t2t tr
where
t2t = term2term cgr env
checkCases cs a =
if null [() | Cas (_:_:_) _ <- cs] -- no share option active
then a
else error $ "Share optimization illegal for gfcc in" +++ A.prt tr ++++
"Recompile with -optimize=(values | none | subs | all_subs)."
r2r tr@(P p _) = case getLab tr of
Ok (cat,labs) -> P (t2t p) . mkLab $ maybe (prtTrace tr $ 66664) snd $
Map.lookup (cat,labs) labels
@@ -247,7 +255,8 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
let tyvs = case Map.lookup (cat,lab) labels of
Just (ty,_) -> case Map.lookup ty typs of
Just vs -> (ty,[t |
(t,_) <- sortBy (\x y -> compare (snd x) (snd y)) (Map.assocs vs)])
(t,_) <- sortBy (\x y -> compare (snd x) (snd y))
(Map.assocs vs)])
_ -> error $ A.prt ty
_ -> error $ A.prt tr
updateSTM ((tyvs, (tr', tr)):)
@@ -266,7 +275,9 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
mkLab k = L (IC ("_" ++ show k))
valNum tr = maybe (tryPerm tr) EInt $ Map.lookup tr untyps
--- a hack needed because GFCC does not guarantee canonical order of param records
--- a hack needed because GFCC does not guarantee
--- canonical order of param records
--- complexity could be lowered by sorting the records
where
tryPerm tr = case tr of
R rs -> case [v | Just v <- [Map.lookup (R rs') untyps | rs' <- permutations rs]] of
@@ -288,8 +299,18 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
EInt _ -> False
R rs -> any (isStr . trmAss) rs
FV ts -> any isStr ts
P t r -> True ---- TODO
P t r -> case getLab tr of
Ok (cat,labs) -> case
Map.lookup (cat,labs) labels of
Just (ty,_) -> isStrType ty
_ -> True ---- TODO?
_ -> True
_ -> True
isStrType ty = case ty of
TStr -> True
RecType ts -> any isStrType [t | Lbg _ t <- ts]
Table _ t -> isStrType t
_ -> False
isLock l t = case t of --- need not look at l
R [] -> True
_ -> False
@@ -307,7 +328,8 @@ prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n
-- suffix analysis followed by common subexpression elimination
optConcrete :: [C.CncDef] -> [C.CncDef]
optConcrete defs = subex [C.Lin f (optTerm t) | C.Lin f t <- defs]
optConcrete defs = subex
[C.Lin f (optTerm t) | C.Lin f t <- defs]
-- analyse word form lists into prefix + suffixes
-- suffix sets can later be shared by subex elim
@@ -317,7 +339,7 @@ optTerm tr = case tr of
C.R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | C.K (C.KS s) <- ts]
C.R ts -> C.R $ map optTerm ts
C.P t v -> C.P (optTerm t) v
C.A x t -> C.A x (optTerm t)
-- C.A x t -> C.A x (optTerm t)
_ -> tr
where
optToks ss = prf : suffs where
@@ -357,7 +379,7 @@ addSubexpConsts tree lins =
C.S ts -> C.S $ map (recomp f) ts
C.W s t -> C.W s (recomp f t)
C.P t p -> C.P (recomp f t) (recomp f p)
C.A x t -> C.A x (recomp f t)
-- C.A x t -> C.A x (recomp f t)
_ -> t
fid n = C.CId $ "_" ++ show n
list = Map.toList tree
@@ -380,8 +402,8 @@ collectSubterms t = case t of
C.S ts -> do
mapM collectSubterms ts
add t
C.A x b -> do
collectSubterms b -- t itself can only occur once in a grammar
-- C.A x b -> do
-- collectSubterms b -- t itself can only occur once in a grammar
C.W s u -> do
collectSubterms u
add t

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

3
src/Makefile
View File

@@ -177,6 +177,9 @@ gfdoc: tools/$(GF_DOC_EXE)
tools/$(GF_DOC_EXE): tools/GFDoc.hs
$(GHMAKE) $(GHCOPTFLAGS) -o $@ $^
gfcc:
$(GHMAKE) $(GHCOPTFLAGS) -o gfcc GF/Canon/GFCC/RunGFCC.hs
#
# Distribution
#