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

use ByteString internally in Ident, CId and Label

Browse Source
This commit is contained in:
kr.angelov
2008-05-21 13:10:54 +00:00
parent e8bbd458cb
commit 314f5cc5e7
65 changed files with 6275 additions and 6432 deletions
Download Patch File Download Diff File Expand all files Collapse all files

21
src-3.0/GF/GFCC/API.hs
View File

@@ -84,12 +84,12 @@ file2gfcc f = do
g <- parseGrammar s
return $ toGFCC g
linearize mgr lang = GF.GFCC.Linearize.linearize (gfcc mgr) (CId lang)
linearize mgr lang = GF.GFCC.Linearize.linearize (gfcc mgr) (mkCId lang)
parse mgr lang cat s =
case lookParser (gfcc mgr) (CId lang) of
case lookParser (gfcc mgr) (mkCId lang) of
Nothing -> error "no parser"
Just pinfo -> case parseFCF "bottomup" pinfo (CId cat) (words s) of
Just pinfo -> case parseFCF "bottomup" pinfo (mkCId cat) (words s) of
Ok x -> x
Bad s -> error s
@@ -104,23 +104,20 @@ parseAllLang mgr cat s =
generateRandom mgr cat = do
gen <- newStdGen
return $ genRandom gen (gfcc mgr) (CId cat)
return $ genRandom gen (gfcc mgr) (mkCId cat)
generateAll mgr cat = generate (gfcc mgr) (CId cat) Nothing
generateAllDepth mgr cat = generate (gfcc mgr) (CId cat)
generateAll mgr cat = generate (gfcc mgr) (mkCId cat) Nothing
generateAllDepth mgr cat = generate (gfcc mgr) (mkCId cat)
readTree _ = pTree
showTree = prExp
prIdent :: CId -> String
prIdent (CId s) = s
abstractName mgr = prCId (absname (gfcc mgr))
abstractName mgr = prIdent (absname (gfcc mgr))
languages mgr = [prCId l | l <- cncnames (gfcc mgr)]
languages mgr = [l | CId l <- cncnames (gfcc mgr)]
categories mgr = [c | CId c <- Map.keys (cats (abstract (gfcc mgr)))]
categories mgr = [prCId c | c <- Map.keys (cats (abstract (gfcc mgr)))]
startCat mgr = lookStartCat (gfcc mgr)

23
src-3.0/GF/GFCC/CId.hs
View File

@@ -1,14 +1,15 @@
module GF.GFCC.CId (
module GF.GFCC.Raw.AbsGFCCRaw,
prCId,
cId
) where
module GF.GFCC.CId (CId(..), wildCId, mkCId, prCId) where
import GF.GFCC.Raw.AbsGFCCRaw (CId(CId))
import GF.Infra.PrintClass
import Data.ByteString.Char8 as BS
newtype CId = CId BS.ByteString deriving (Eq,Ord,Show)
wildCId :: CId
wildCId = CId (BS.singleton '_')
mkCId :: String -> CId
mkCId s = CId (BS.pack s)
prCId :: CId -> String
prCId (CId s) = s
cId :: String -> CId
cId = CId
prCId (CId x) = BS.unpack x

4
src-3.0/GF/GFCC/CheckGFCC.hs
View File

@@ -45,7 +45,7 @@ labelBoolErr ms iob = do
checkConcrete :: GFCC -> (CId,Concr) -> Err ((CId,Concr),Bool)
checkConcrete gfcc (lang,cnc) =
labelBoolErr ("happened in language " ++ printCId lang) $ do
labelBoolErr ("happened in language " ++ prCId lang) $ do
(rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip
return ((lang,cnc{lins = Map.fromAscList rs}),and bs)
where
@@ -53,7 +53,7 @@ checkConcrete gfcc (lang,cnc) =
checkLin :: GFCC -> CId -> (CId,Term) -> Err ((CId,Term),Bool)
checkLin gfcc lang (f,t) =
labelBoolErr ("happened in function " ++ printCId f) $ do
labelBoolErr ("happened in function " ++ prCId f) $ do
(t',b) <- checkTerm (lintype gfcc lang f) t --- $ inline gfcc lang t
return ((f,t'),b)

17
src-3.0/GF/GFCC/DataGFCC.hs
View File

@@ -1,6 +1,7 @@
module GF.GFCC.DataGFCC where
import GF.GFCC.CId
import GF.Infra.PrintClass(prt)
import GF.Infra.CompactPrint
import GF.Text.UTF8
import GF.Formalism.FCFG
@@ -90,21 +91,17 @@ data Equation =
statGFCC :: GFCC -> String
statGFCC gfcc = unlines [
"Abstract\t" ++ pr (absname gfcc),
"Concretes\t" ++ unwords (lmap pr (cncnames gfcc)),
"Categories\t" ++ unwords (lmap pr (keys (cats (abstract gfcc))))
"Abstract\t" ++ prt (absname gfcc),
"Concretes\t" ++ unwords (lmap prt (cncnames gfcc)),
"Categories\t" ++ unwords (lmap prt (keys (cats (abstract gfcc))))
]
where pr (CId s) = s
printCId :: CId -> String
printCId (CId s) = s
-- merge two GFCCs; fails is differens absnames; priority to second arg
unionGFCC :: GFCC -> GFCC -> GFCC
unionGFCC one two = case absname one of
CId "" -> two -- extending empty grammar
n | n == absname two -> one { -- extending grammar with same abstract
n | n == wildCId -> two -- extending empty grammar
| n == absname two -> one { -- extending grammar with same abstract
concretes = Data.Map.union (concretes two) (concretes one),
cncnames = Data.List.union (cncnames two) (cncnames one)
}
@@ -112,7 +109,7 @@ unionGFCC one two = case absname one of
emptyGFCC :: GFCC
emptyGFCC = GFCC {
absname = CId "",
absname = wildCId,
cncnames = [] ,
gflags = empty,
abstract = error "empty grammar, no abstract",

4
src-3.0/GF/GFCC/Generate.hs
View File

@@ -36,8 +36,8 @@ genRandom gen gfcc cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where
(genTrees ds2 cat) -- else (drop k ds)
genTree rs = gett rs where
gett ds (CId "String") = (tree (AS "foo") [], 1)
gett ds (CId "Int") = (tree (AI 12345) [], 1)
gett ds cid | cid == mkCId "String" = (tree (AS "foo") [], 1)
gett ds cid | cid == mkCId "Int" = (tree (AI 12345) [], 1)
gett [] _ = (tree (AS "TIMEOUT") [], 1) ----
gett ds cat = case fns cat of
[] -> (tree (AM 0) [],1)

7
src-3.0/GF/GFCC/Linearize.hs
View File

@@ -3,6 +3,7 @@ module GF.GFCC.Linearize where
import GF.GFCC.Macros
import GF.GFCC.DataGFCC
import GF.GFCC.CId
import GF.Infra.PrintClass
import Data.Map
import Data.List
@@ -35,7 +36,7 @@ linExp mcfg lang tree@(DTr xs at trees) =
--- [C lst, kks (show i), C size] where
--- lst = mod (fromInteger i) 10 ; size = if i < 10 then 0 else 1
AF d -> R [kks (show d)]
AV x -> TM (prCId x)
AV x -> TM (prt x)
AM i -> TM (show i)
where
lin = linExp mcfg lang
@@ -44,8 +45,8 @@ linExp mcfg lang tree@(DTr xs at trees) =
addB t
| Data.List.null xs = t
| otherwise = case t of
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
TM s -> R $ t : (Data.List.map (kks . prCId) xs)
R ts -> R $ ts ++ (Data.List.map (kks . prt) xs)
TM s -> R $ t : (Data.List.map (kks . prt) xs)
compute :: GFCC -> CId -> [Term] -> Term -> Term
compute mcfg lang args = comp where

12
src-3.0/GF/GFCC/Macros.hs
View File

@@ -4,7 +4,7 @@ import GF.GFCC.CId
import GF.GFCC.DataGFCC
import GF.Formalism.FCFG (FGrammar)
import GF.Parsing.FCFG.PInfo (FCFPInfo, fcfPInfoToFGrammar)
----import GF.GFCC.PrintGFCC
import GF.Infra.PrintClass
import Control.Monad
import Data.Map
import Data.Maybe
@@ -39,7 +39,7 @@ lookFCFG :: GFCC -> CId -> Maybe FGrammar
lookFCFG gfcc lang = fmap fcfPInfoToFGrammar $ lookParser gfcc lang
lookStartCat :: GFCC -> String
lookStartCat gfcc = fromMaybe "S" $ msum $ Data.List.map (Data.Map.lookup (CId "startcat"))
lookStartCat gfcc = fromMaybe "S" $ msum $ Data.List.map (Data.Map.lookup (mkCId "startcat"))
[gflags gfcc, aflags (abstract gfcc)]
lookGlobalFlag :: GFCC -> CId -> String
@@ -87,12 +87,6 @@ contextLength :: Type -> Int
contextLength ty = case ty of
DTyp hyps _ _ -> length hyps
cid :: String -> CId
cid = CId
wildCId :: CId
wildCId = cid "_"
exp0 :: Exp
exp0 = tree (AM 0) []
@@ -100,7 +94,7 @@ primNotion :: Exp
primNotion = EEq []
term0 :: CId -> Term
term0 = TM . prCId
term0 = TM . prt
tm0 :: Term
tm0 = TM "?"

2
src-3.0/GF/GFCC/OptimizeGFCC.hs
View File

@@ -75,7 +75,7 @@ addSubexpConsts tree cnc = cnc {
W s t -> W s (recomp f t)
P t p -> P (recomp f t) (recomp f p)
_ -> t
fid n = CId $ "_" ++ show n
fid n = mkCId $ "_" ++ show n
rec field = Map.fromAscList [(f,recomp f trm) | (f,trm) <- Map.assocs (field cnc)]

5
src-3.0/GF/GFCC/Raw/AbsGFCCRaw.hs
View File

@@ -1,14 +1,11 @@
module GF.GFCC.Raw.AbsGFCCRaw where
-- Haskell module generated by the BNF converter
newtype CId = CId String deriving (Eq,Ord,Show)
data Grammar =
Grm [RExp]
deriving (Eq,Ord,Show)
data RExp =
App CId [RExp]
App String [RExp]
| AInt Integer
| AStr String
| AFlt Double

197
src-3.0/GF/GFCC/Raw/ConvertGFCC.hs
View File

@@ -1,8 +1,10 @@
module GF.GFCC.Raw.ConvertGFCC (toGFCC,fromGFCC) where
import GF.GFCC.CId
import GF.GFCC.DataGFCC
import GF.GFCC.Raw.AbsGFCCRaw
import GF.Infra.PrintClass
import GF.Data.Assoc
import GF.Formalism.FCFG
import GF.Formalism.Utilities (NameProfile(..), Profile(..), SyntaxForest(..))
@@ -18,29 +20,29 @@ pgfMajorVersion, pgfMinorVersion :: Integer
toGFCC :: Grammar -> GFCC
toGFCC (Grm [
App (CId "pgf") (AInt v1 : AInt v2 : App a []:cs),
App (CId "flags") gfs,
App "pgf" (AInt v1 : AInt v2 : App a []:cs),
App "flags" gfs,
ab@(
App (CId "abstract") [
App (CId "fun") fs,
App (CId "cat") cts
App "abstract" [
App "fun" fs,
App "cat" cts
]),
App (CId "concrete") ccs
App "concrete" ccs
]) = GFCC {
absname = a,
cncnames = [c | App c [] <- cs],
gflags = fromAscList [(f,v) | App f [AStr v] <- gfs],
absname = mkCId a,
cncnames = [mkCId c | App c [] <- cs],
gflags = fromAscList [(mkCId f,v) | App f [AStr v] <- gfs],
abstract =
let
aflags = fromAscList [(f,v) | App f [AStr v] <- gfs]
lfuns = [(f,(toType typ,toExp def)) | App f [typ, def] <- fs]
aflags = fromAscList [(mkCId f,v) | App f [AStr v] <- gfs]
lfuns = [(mkCId f,(toType typ,toExp def)) | App f [typ, def] <- fs]
funs = fromAscList lfuns
lcats = [(c, Prelude.map toHypo hyps) | App c hyps <- cts]
lcats = [(mkCId 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 [(lang, toConcr ts) | App lang ts <- ccs]
concretes = fromAscList [(mkCId lang, toConcr ts) | App lang ts <- ccs]
}
where
@@ -57,71 +59,71 @@ toConcr = foldl add (Concr {
})
where
add :: Concr -> RExp -> Concr
add cnc (App (CId "flags") ts) = cnc { cflags = fromAscList [(f,v) | App f [AStr v] <- ts] }
add cnc (App (CId "lin") ts) = cnc { lins = mkTermMap ts }
add cnc (App (CId "oper") ts) = cnc { opers = mkTermMap ts }
add cnc (App (CId "lincat") ts) = cnc { lincats = mkTermMap ts }
add cnc (App (CId "lindef") ts) = cnc { lindefs = mkTermMap ts }
add cnc (App (CId "printname") ts) = cnc { printnames = mkTermMap ts }
add cnc (App (CId "param") ts) = cnc { paramlincats = mkTermMap ts }
add cnc (App (CId "parser") ts) = cnc { parser = Just (toPInfo ts) }
add cnc (App "flags" ts) = cnc { cflags = fromAscList [(mkCId f,v) | App f [AStr v] <- ts] }
add cnc (App "lin" ts) = cnc { lins = mkTermMap ts }
add cnc (App "oper" ts) = cnc { opers = mkTermMap ts }
add cnc (App "lincat" ts) = cnc { lincats = mkTermMap ts }
add cnc (App "lindef" ts) = cnc { lindefs = mkTermMap ts }
add cnc (App "printname" ts) = cnc { printnames = mkTermMap ts }
add cnc (App "param" ts) = cnc { paramlincats = mkTermMap ts }
add cnc (App "parser" ts) = cnc { parser = Just (toPInfo ts) }
toPInfo :: [RExp] -> FCFPInfo
toPInfo [App (CId "rules") rs, App (CId "startupcats") cs] = buildFCFPInfo (rules, cats)
toPInfo [App "rules" rs, App "startupcats" cs] = buildFCFPInfo (rules, cats)
where
rules = lmap toFRule rs
cats = fromList [(c, lmap expToInt fs) | App c fs <- cs]
cats = fromList [(mkCId c, lmap expToInt fs) | App c fs <- cs]
toFRule :: RExp -> FRule
toFRule (App (CId "rule")
toFRule (App "rule"
[n,
App (CId "cats") (rt:at),
App (CId "R") ls]) = FRule name args res lins
App "cats" (rt:at),
App "R" ls]) = FRule name args res lins
where
name = toFName n
args = lmap expToInt at
res = expToInt rt
lins = mkArray [mkArray [toSymbol s | s <- l] | App (CId "S") l <- ls]
lins = mkArray [mkArray [toSymbol s | s <- l] | App "S" l <- ls]
toFName :: RExp -> FName
toFName (App (CId "_A") [x]) = Name (CId "_") [Unify [expToInt x]]
toFName (App f ts) = Name f (lmap toProfile ts)
toFName (App "_A" [x]) = Name wildCId [Unify [expToInt x]]
toFName (App f ts) = Name (mkCId f) (lmap toProfile ts)
where
toProfile :: RExp -> Profile (SyntaxForest CId)
toProfile AMet = Unify []
toProfile (App (CId "_A") [t]) = Unify [expToInt t]
toProfile (App (CId "_U") ts) = Unify [expToInt t | App (CId "_A") [t] <- ts]
toProfile (App "_A" [t]) = Unify [expToInt t]
toProfile (App "_U" ts) = Unify [expToInt t | App "_A" [t] <- ts]
toProfile t = Constant (toSyntaxForest t)
toSyntaxForest :: RExp -> SyntaxForest CId
toSyntaxForest AMet = FMeta
toSyntaxForest (App n ts) = FNode n [lmap toSyntaxForest ts]
toSyntaxForest (App n ts) = FNode (mkCId n) [lmap toSyntaxForest ts]
toSyntaxForest (AStr s) = FString s
toSyntaxForest (AInt i) = FInt i
toSyntaxForest (AFlt f) = FFloat f
toSymbol :: RExp -> FSymbol
toSymbol (App (CId "P") [c,n,l]) = FSymCat (expToInt c) (expToInt l) (expToInt n)
toSymbol (App "P" [c,n,l]) = FSymCat (expToInt c) (expToInt l) (expToInt n)
toSymbol (AStr t) = FSymTok t
toType :: RExp -> Type
toType e = case e of
App cat [App (CId "H") hypos, App (CId "X") exps] ->
DTyp (lmap toHypo hypos) cat (lmap toExp exps)
App cat [App "H" hypos, App "X" exps] ->
DTyp (lmap toHypo hypos) (mkCId cat) (lmap toExp exps)
_ -> error $ "type " ++ show e
toHypo :: RExp -> Hypo
toHypo e = case e of
App x [typ] -> Hyp x (toType typ)
App x [typ] -> Hyp (mkCId x) (toType typ)
_ -> error $ "hypo " ++ show e
toExp :: RExp -> Exp
toExp e = case e of
App (CId "App") [App fun [], App (CId "B") xs, App (CId "X") exps] ->
DTr [x | App x [] <- xs] (AC fun) (lmap toExp exps)
App (CId "Eq") eqs ->
EEq [Equ (lmap toExp ps) (toExp v) | App (CId "E") (v:ps) <- eqs]
App (CId "Var") [App i []] -> DTr [] (AV i) []
App "App" [App fun [], App "B" xs, App "X" exps] ->
DTr [mkCId x | App x [] <- xs] (AC (mkCId fun)) (lmap toExp exps)
App "Eq" eqs ->
EEq [Equ (lmap toExp ps) (toExp v) | App "E" (v:ps) <- eqs]
App "Var" [App i []] -> DTr [] (AV (mkCId i)) []
AMet -> DTr [] (AM 0) []
AInt i -> DTr [] (AI i) []
AFlt i -> DTr [] (AF i) []
@@ -130,14 +132,14 @@ toExp e = case e of
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)
App (CId "A") [AInt i] -> V (fromInteger i)
App f [] -> F f
App "R" es -> R (lmap toTerm es)
App "S" es -> S (lmap toTerm es)
App "FV" es -> FV (lmap toTerm es)
App "P" [e,v] -> P (toTerm e) (toTerm v)
App "RP" [e,v] -> RP (toTerm e) (toTerm v) ----
App "W" [AStr s,v] -> W s (toTerm v)
App "A" [AInt i] -> V (fromInteger i)
App f [] -> F (mkCId f)
AInt i -> C (fromInteger i)
AMet -> TM "?"
AStr s -> K (KS s) ----
@@ -149,129 +151,124 @@ toTerm e = case e of
fromGFCC :: GFCC -> Grammar
fromGFCC gfcc0 = Grm [
app "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion
: App (absname gfcc) [] : lmap (flip App []) (cncnames gfcc)),
app "flags" [App f [AStr v] | (f,v) <- toList (gflags gfcc `union` aflags agfcc)],
app "abstract" [
app "fun" [App f [fromType t,fromExp d] | (f,(t,d)) <- toList (funs agfcc)],
app "cat" [App f (lmap fromHypo hs) | (f,hs) <- toList (cats agfcc)]
App "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion
: App (prCId (absname gfcc)) [] : lmap (flip App [] . prCId) (cncnames gfcc)),
App "flags" [App (prCId f) [AStr v] | (f,v) <- toList (gflags gfcc `union` aflags agfcc)],
App "abstract" [
App "fun" [App (prCId f) [fromType t,fromExp d] | (f,(t,d)) <- toList (funs agfcc)],
App "cat" [App (prCId f) (lmap fromHypo hs) | (f,hs) <- toList (cats agfcc)]
],
app "concrete" [App lang (fromConcrete c) | (lang,c) <- toList (concretes gfcc)]
App "concrete" [App (prCId lang) (fromConcrete c) | (lang,c) <- toList (concretes gfcc)]
]
where
gfcc = utf8GFCC gfcc0
app s = App (CId s)
agfcc = abstract gfcc
fromConcrete cnc = [
app "flags" [App f [AStr v] | (f,v) <- toList (cflags cnc)],
app "lin" [App f [fromTerm v] | (f,v) <- toList (lins cnc)],
app "oper" [App f [fromTerm v] | (f,v) <- toList (opers cnc)],
app "lincat" [App f [fromTerm v] | (f,v) <- toList (lincats cnc)],
app "lindef" [App f [fromTerm v] | (f,v) <- toList (lindefs cnc)],
app "printname" [App f [fromTerm v] | (f,v) <- toList (printnames cnc)],
app "param" [App f [fromTerm v] | (f,v) <- toList (paramlincats cnc)]
App "flags" [App (prCId f) [AStr v] | (f,v) <- toList (cflags cnc)],
App "lin" [App (prCId f) [fromTerm v] | (f,v) <- toList (lins cnc)],
App "oper" [App (prCId f) [fromTerm v] | (f,v) <- toList (opers cnc)],
App "lincat" [App (prCId f) [fromTerm v] | (f,v) <- toList (lincats cnc)],
App "lindef" [App (prCId f) [fromTerm v] | (f,v) <- toList (lindefs cnc)],
App "printname" [App (prCId f) [fromTerm v] | (f,v) <- toList (printnames cnc)],
App "param" [App (prCId f) [fromTerm v] | (f,v) <- toList (paramlincats cnc)]
] ++ maybe [] (\p -> [fromPInfo p]) (parser cnc)
fromType :: Type -> RExp
fromType e = case e of
DTyp hypos cat exps ->
App cat [
App (CId "H") (lmap fromHypo hypos),
App (CId "X") (lmap fromExp exps)]
App (prCId cat) [
App "H" (lmap fromHypo hypos),
App "X" (lmap fromExp exps)]
fromHypo :: Hypo -> RExp
fromHypo e = case e of
Hyp x typ -> App x [fromType typ]
Hyp x typ -> App (prCId x) [fromType typ]
fromExp :: Exp -> RExp
fromExp e = case e of
DTr xs (AC fun) exps ->
App (CId "App") [App fun [], App (CId "B") (lmap (flip App []) xs), App (CId "X") (lmap fromExp exps)]
DTr [] (AV x) [] -> App (CId "Var") [App x []]
App "App" [App (prCId fun) [], App "B" (lmap (flip App [] . prCId) xs), App "X" (lmap fromExp exps)]
DTr [] (AV x) [] -> App "Var" [App (prCId x) []]
DTr [] (AS s) [] -> AStr s
DTr [] (AF d) [] -> AFlt d
DTr [] (AI i) [] -> AInt (toInteger i)
DTr [] (AM _) [] -> AMet ----
EEq eqs ->
App (CId "Eq") [App (CId "E") (lmap fromExp (v:ps)) | Equ ps v <- eqs]
App "Eq" [App "E" (lmap fromExp (v:ps)) | Equ ps v <- eqs]
_ -> error $ "exp " ++ show e
fromTerm :: Term -> RExp
fromTerm e = case e of
R es -> app "R" (lmap fromTerm es)
S es -> app "S" (lmap fromTerm es)
FV es -> app "FV" (lmap fromTerm es)
P e v -> app "P" [fromTerm e, fromTerm v]
RP e v -> app "RP" [fromTerm e, fromTerm v] ----
W s v -> app "W" [AStr s, fromTerm v]
R es -> App "R" (lmap fromTerm es)
S es -> App "S" (lmap fromTerm es)
FV es -> App "FV" (lmap fromTerm es)
P e v -> App "P" [fromTerm e, fromTerm v]
RP e v -> App "RP" [fromTerm e, fromTerm v] ----
W s v -> App "W" [AStr s, fromTerm v]
C i -> AInt (toInteger i)
TM _ -> AMet
F f -> App f []
V i -> App (CId "A") [AInt (toInteger i)]
F f -> App (prCId f) []
V i -> App "A" [AInt (toInteger i)]
K (KS s) -> AStr s ----
K (KP d vs) -> app "FV" (str d : [str v | Var v _ <- vs]) ----
K (KP d vs) -> App "FV" (str d : [str v | Var v _ <- vs]) ----
where
app = App . CId
str v = app "S" (lmap AStr v)
str v = App "S" (lmap AStr v)
-- ** Parsing info
fromPInfo :: FCFPInfo -> RExp
fromPInfo p = app "parser" [
app "rules" [fromFRule rule | rule <- Array.elems (allRules p)],
app "startupcats" [App f (lmap intToExp cs) | (f,cs) <- toList (startupCats p)]
fromPInfo p = App "parser" [
App "rules" [fromFRule rule | rule <- Array.elems (allRules p)],
App "startupcats" [App (prCId f) (lmap intToExp cs) | (f,cs) <- toList (startupCats p)]
]
fromFRule :: FRule -> RExp
fromFRule (FRule n args res lins) =
app "rule" [fromFName n,
app "cats" (intToExp res:lmap intToExp args),
app "R" [app "S" [fromSymbol s | s <- Array.elems l] | l <- Array.elems lins]
App "rule" [fromFName n,
App "cats" (intToExp res:lmap intToExp args),
App "R" [App "S" [fromSymbol s | s <- Array.elems l] | l <- Array.elems lins]
]
fromFName :: FName -> RExp
fromFName n = case n of
Name (CId "_") [p] -> fromProfile p
Name f ps -> App f (lmap fromProfile ps)
Name f ps | f == wildCId -> fromProfile (head ps)
| otherwise -> App (prCId f) (lmap fromProfile ps)
where
fromProfile :: Profile (SyntaxForest CId) -> RExp
fromProfile (Unify []) = AMet
fromProfile (Unify [x]) = daughter x
fromProfile (Unify args) = app "_U" (lmap daughter args)
fromProfile (Unify args) = App "_U" (lmap daughter args)
fromProfile (Constant forest) = fromSyntaxForest forest
daughter n = app "_A" [intToExp n]
daughter n = App "_A" [intToExp n]
fromSyntaxForest :: SyntaxForest CId -> RExp
fromSyntaxForest FMeta = AMet
-- FIXME: is there always just one element here?
fromSyntaxForest (FNode n [args]) = App n (lmap fromSyntaxForest args)
fromSyntaxForest (FNode n [args]) = App (prCId n) (lmap fromSyntaxForest args)
fromSyntaxForest (FString s) = AStr s
fromSyntaxForest (FInt i) = AInt i
fromSyntaxForest (FFloat f) = AFlt f
fromSymbol :: FSymbol -> RExp
fromSymbol (FSymCat c l n) = app "P" [intToExp c, intToExp n, intToExp l]
fromSymbol (FSymCat c l n) = App "P" [intToExp c, intToExp n, intToExp l]
fromSymbol (FSymTok t) = AStr t
-- ** Utilities
mkTermMap :: [RExp] -> Map CId Term
mkTermMap ts = fromAscList [(f,toTerm v) | App f [v] <- ts]
app :: String -> [RExp] -> RExp
app = App . CId
mkTermMap ts = fromAscList [(mkCId f,toTerm v) | App f [v] <- ts]
mkArray :: [a] -> Array.Array Int a
mkArray xs = Array.listArray (0, length xs - 1) xs
expToInt :: Integral a => RExp -> a
expToInt (App (CId "neg") [AInt i]) = fromIntegral (negate i)
expToInt (App "neg" [AInt i]) = fromIntegral (negate i)
expToInt (AInt i) = fromIntegral i
expToStr :: RExp -> String
expToStr (AStr s) = s
intToExp :: Integral a => a -> RExp
intToExp x | x < 0 = App (CId "neg") [AInt (fromIntegral (negate x))]
intToExp x | x < 0 = App "neg" [AInt (fromIntegral (negate x))]
| otherwise = AInt (fromIntegral x)

4
src-3.0/GF/GFCC/Raw/ParGFCCRaw.hs
View File

@@ -1,9 +1,11 @@
module GF.GFCC.Raw.ParGFCCRaw (parseGrammar) where
import GF.GFCC.CId
import GF.GFCC.Raw.AbsGFCCRaw
import Control.Monad
import Data.Char
import qualified Data.ByteString.Char8 as BS
parseGrammar :: String -> IO Grammar
parseGrammar s = case runP pGrammar s of
@@ -27,7 +29,7 @@ pTerm n = skipSpaces >> (pParen <++ pApp <++ pNum <++ pStr <++ pMeta)
<++
return (AInt (read x)))
pMeta = char '?' >> return AMet
pIdent = liftM CId $ liftM2 (:) (satisfy isIdentFirst) (munch isIdentRest)
pIdent = liftM2 (:) (satisfy isIdentFirst) (munch isIdentRest)
isIdentFirst c = c == '_' || isAlpha c
isIdentRest c = c == '_' || c == '\'' || isAlphaNum c

9
src-3.0/GF/GFCC/Raw/PrintGFCCRaw.hs
View File

@@ -1,9 +1,11 @@
module GF.GFCC.Raw.PrintGFCCRaw (printTree) where
import GF.GFCC.CId
import GF.GFCC.Raw.AbsGFCCRaw
import Data.List (intersperse)
import Numeric (showFFloat)
import qualified Data.ByteString.Char8 as BS
printTree :: Grammar -> String
printTree g = prGrammar g ""
@@ -12,8 +14,8 @@ prGrammar :: Grammar -> ShowS
prGrammar (Grm xs) = prRExpList xs
prRExp :: Int -> RExp -> ShowS
prRExp _ (App x []) = prCId x
prRExp n (App x xs) = p (prCId x . showChar ' ' . prRExpList xs)
prRExp _ (App x []) = showString x
prRExp n (App x xs) = p (showString x . showChar ' ' . prRExpList xs)
where p s = if n == 0 then s else showChar '(' . s . showChar ')'
prRExp _ (AInt x) = shows x
prRExp _ (AStr x) = showChar '"' . concatS (map mkEsc x) . showChar '"'
@@ -29,8 +31,5 @@ mkEsc s = case s of
prRExpList :: [RExp] -> ShowS
prRExpList = concatS . intersperse (showChar ' ') . map (prRExp 1)
prCId :: CId -> ShowS
prCId (CId x) = showString x
concatS :: [ShowS] -> ShowS
concatS = foldr (.) id