forked from GitHub/gf-core
removed gfcc via gfc everywhere; workaround for russian in present
This commit is contained in:
aarne
@@ -1,422 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : CanonToGFCC
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/06/17 14:15:17 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.15 $
|
||||
--
|
||||
-- GFC to GFCC compiler. AR Aug-Oct 2006
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Canon.CanonToGFCC (
|
||||
prCanon2gfcc, mkCanon2gfcc, mkCanon2gfccNoUTF8) where
|
||||
|
||||
import GF.Canon.AbsGFC
|
||||
import qualified GF.Canon.GFC as GFC
|
||||
import qualified GF.Canon.Look as Look
|
||||
import qualified GF.Canon.Subexpressions as Sub
|
||||
|
||||
import qualified GF.GFCC.Macros as CM
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import qualified GF.GFCC.DataGFCC as C
|
||||
import qualified GF.GFCC.DataGFCC as D
|
||||
import GF.Devel.PrintGFCC
|
||||
import GF.GFCC.OptimizeGFCC
|
||||
|
||||
import GF.Canon.GFC
|
||||
import GF.Canon.Share
|
||||
import qualified GF.Grammar.Abstract as A
|
||||
import qualified GF.Grammar.Macros as GM
|
||||
import GF.Canon.MkGFC
|
||||
import GF.Canon.CMacros
|
||||
import qualified GF.Infra.Modules as M
|
||||
import qualified GF.Infra.Option as O
|
||||
import GF.UseGrammar.Linear (expandLinTables, unoptimizeCanon)
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Data.Operations
|
||||
import GF.Text.UTF8
|
||||
|
||||
import Data.List
|
||||
import qualified Data.Map as Map
|
||||
import Debug.Trace ----
|
||||
|
||||
-- the main function: generate GFCC from GFCM.
|
||||
|
||||
prCanon2gfcc :: CanonGrammar -> String
|
||||
prCanon2gfcc = printGFCC . mkCanon2gfcc
|
||||
|
||||
-- this variant makes utf8 conversion; used in back ends
|
||||
mkCanon2gfcc :: CanonGrammar -> D.GFCC
|
||||
mkCanon2gfcc =
|
||||
-- canon2gfcc . reorder abs . utf8Conv . canon2canon abs
|
||||
optGFCC . canon2gfcc . reorder . utf8Conv . canon2canon . normalize
|
||||
|
||||
-- this variant makes no utf8 conversion; used in ShellState
|
||||
mkCanon2gfccNoUTF8 :: CanonGrammar -> D.GFCC
|
||||
mkCanon2gfccNoUTF8 = optGFCC . canon2gfcc . reorder . canon2canon . normalize
|
||||
|
||||
-- This is needed to reorganize the grammar.
|
||||
-- GFCC has its own back-end optimization.
|
||||
-- But we need to have the canonical order in tables, created by valOpt
|
||||
normalize :: CanonGrammar -> CanonGrammar
|
||||
normalize = share . unoptimizeCanon . Sub.unSubelimCanon where
|
||||
share = M.MGrammar . map (shareModule valOpt) . M.modules --- allOpt
|
||||
|
||||
-- Generate GFCC from GFCM.
|
||||
-- this assumes a grammar normalized and transformed by canon2canon
|
||||
|
||||
canon2gfcc :: CanonGrammar -> D.GFCC
|
||||
canon2gfcc cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
|
||||
D.GFCC an cns Map.empty abs cncs
|
||||
where
|
||||
an = (i2i a)
|
||||
cns = map (i2i . fst) cms
|
||||
abs = D.Abstr aflags funs cats catfuns
|
||||
aflags = Map.fromAscList [] ---- flags
|
||||
lfuns = [(f', (mkType ty,CM.primNotion)) | ---- defs
|
||||
(f,GFC.AbsFun ty _) <- tree2list (M.jments abm), let f' = i2i f]
|
||||
funs = Map.fromAscList lfuns
|
||||
lcats = [(i2i c,[]) | ---- context
|
||||
(c,GFC.AbsCat _ _) <- tree2list (M.jments abm)]
|
||||
cats = Map.fromAscList lcats
|
||||
catfuns = Map.fromAscList
|
||||
[(cat,[f | (f, (C.DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
|
||||
|
||||
cncs = Map.fromList [mkConcr (i2i lang) mo | (lang,M.ModMod mo) <- cms]
|
||||
mkConcr lang mo = (lang,D.Concr flags lins opers lincats lindefs printnames params)
|
||||
where
|
||||
flags = Map.fromAscList [] ---- flags
|
||||
opers = Map.fromAscList [] -- opers will be created as optimization
|
||||
lins = Map.fromAscList
|
||||
[(i2i f, mkTerm tr) | (f,GFC.CncFun _ _ tr _) <- tree2list (M.jments mo)]
|
||||
lincats = Map.fromAscList
|
||||
[(i2i c, mkCType ty) | (c,GFC.CncCat ty _ _) <- tree2list (M.jments mo)]
|
||||
lindefs = Map.fromAscList
|
||||
[(i2i c, mkTerm tr) | (c,GFC.CncCat _ tr _) <- tree2list (M.jments mo)]
|
||||
printnames = Map.fromAscList [] ---- printnames
|
||||
params = Map.fromAscList [] ---- params
|
||||
|
||||
i2i :: Ident -> CId
|
||||
i2i (IC c) = CId c
|
||||
|
||||
mkType :: A.Type -> C.Type
|
||||
mkType t = case GM.catSkeleton t of
|
||||
Ok (cs,c) -> CM.cftype (map (i2i . snd) cs) (i2i $ snd c)
|
||||
|
||||
mkCType :: CType -> C.Term
|
||||
mkCType t = case t of
|
||||
TInts i -> C.C $ fromInteger i
|
||||
-- record parameter alias - created in gfc preprocessing
|
||||
RecType [Lbg (L (IC "_")) i, Lbg (L (IC "__")) t] -> C.RP (mkCType i) (mkCType t)
|
||||
RecType rs -> C.R [mkCType t | Lbg _ t <- rs]
|
||||
Table pt vt -> C.R $ replicate (getI (mkCType pt)) $ mkCType vt
|
||||
TStr -> C.S []
|
||||
where
|
||||
getI pt = case pt of
|
||||
C.C i -> i + 1
|
||||
C.RP i _ -> getI i
|
||||
|
||||
mkTerm :: Term -> C.Term
|
||||
mkTerm tr = case tr of
|
||||
Arg (A _ i) -> C.V $ fromInteger i
|
||||
EInt i -> C.C $ fromInteger 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 _ 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]]
|
||||
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 ---- 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) :: Int
|
||||
_ -> prtTrace tr $ 66663
|
||||
|
||||
-- return just one module per language
|
||||
|
||||
reorder :: CanonGrammar -> CanonGrammar
|
||||
reorder cg = M.MGrammar $
|
||||
(abs, M.ModMod $
|
||||
M.Module M.MTAbstract M.MSComplete [] [] [] adefs):
|
||||
[(c, M.ModMod $
|
||||
M.Module (M.MTConcrete abs) M.MSComplete [] [] [] (sorted2tree js))
|
||||
| (c,js) <- cncs]
|
||||
where
|
||||
abs = maybe (error "no abstract") id $ M.greatestAbstract cg
|
||||
mos = M.allModMod cg
|
||||
adefs =
|
||||
sorted2tree $ sortBy (\ (f,_) (g,_) -> compare f g)
|
||||
[finfo |
|
||||
(i,mo) <- M.allModMod cg, M.isModAbs mo,
|
||||
finfo <- tree2list (M.jments mo)]
|
||||
cncs = sortBy (\ (x,_) (y,_) -> compare x y)
|
||||
[(lang, concr lang) | lang <- M.allConcretes cg abs]
|
||||
concr la = sortBy (\ (f,_) (g,_) -> compare f g)
|
||||
[finfo |
|
||||
(i,mo) <- mos, M.isModCnc mo, elem i (M.allExtends cg la),
|
||||
finfo <- tree2list (M.jments mo)]
|
||||
|
||||
-- one grammar per language - needed for symtab generation
|
||||
repartition :: CanonGrammar -> [CanonGrammar]
|
||||
repartition cg = [M.partOfGrammar cg (lang,mo) |
|
||||
let abs = maybe (error "no abstract") id $ M.greatestAbstract cg,
|
||||
let mos = M.allModMod cg,
|
||||
lang <- M.allConcretes cg abs,
|
||||
let mo = errVal
|
||||
(error ("no module found for " ++ A.prt lang)) $ M.lookupModule cg lang
|
||||
]
|
||||
|
||||
-- convert to UTF8 if not yet converted
|
||||
utf8Conv :: CanonGrammar -> CanonGrammar
|
||||
utf8Conv = M.MGrammar . map toUTF8 . M.modules where
|
||||
toUTF8 mo = case mo of
|
||||
(i, M.ModMod m)
|
||||
| hasFlagCanon (flagCanon "coding" "utf8") mo -> mo
|
||||
| otherwise -> (i, M.ModMod $
|
||||
m{ M.jments =
|
||||
mapTree (onSnd (mapInfoTerms (onTokens encodeUTF8))) (M.jments m),
|
||||
M.flags = setFlag "coding" "utf8" (M.flags m) }
|
||||
)
|
||||
_ -> mo
|
||||
|
||||
|
||||
-- translate tables and records to arrays, parameters and labels to indices
|
||||
|
||||
canon2canon :: CanonGrammar -> CanonGrammar
|
||||
canon2canon = recollect . map cl2cl . repartition where
|
||||
recollect =
|
||||
M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules
|
||||
cl2cl cg = {-tr $-} M.MGrammar $ map c2c $ M.modules cg where
|
||||
c2c (c,m) = case m of
|
||||
M.ModMod mo@(M.Module _ _ _ _ _ js) ->
|
||||
(c, M.ModMod $ M.replaceJudgements mo $ mapTree j2j js)
|
||||
_ -> (c,m)
|
||||
j2j (f,j) = case j of
|
||||
GFC.CncFun x y tr z -> (f,GFC.CncFun x y (t2t tr) z)
|
||||
GFC.CncCat ty x y -> (f,GFC.CncCat (ty2ty ty) (t2t x) y)
|
||||
_ -> (f,j)
|
||||
t2t = term2term cg pv
|
||||
ty2ty = type2type cg pv
|
||||
pv@(labels,untyps,typs) = paramValues cg
|
||||
tr = trace $
|
||||
(unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i |
|
||||
((c,l),i) <- Map.toList labels]) ++
|
||||
(unlines [A.prt t +++ "=" +++ show i |
|
||||
(t,i) <- Map.toList untyps]) ++
|
||||
(unlines [A.prt t |
|
||||
(t,_) <- Map.toList typs])
|
||||
|
||||
type ParamEnv =
|
||||
(Map.Map (Ident,[Label]) (CType,Integer), -- numbered labels
|
||||
Map.Map Term Integer, -- untyped terms to values
|
||||
Map.Map CType (Map.Map Term Integer)) -- types to their terms to values
|
||||
|
||||
--- gathers those param types that are actually used in lincats and in lin terms
|
||||
paramValues :: CanonGrammar -> ParamEnv
|
||||
paramValues cgr = (labels,untyps,typs) where
|
||||
params = [(ty, errVal [] $ Look.allParamValues cgr ty) | ty <- partyps]
|
||||
partyps = nub $ [ty |
|
||||
(_,(_,CncCat (RecType ls) _ _)) <- jments,
|
||||
ty0 <- [ty | Lbg _ ty <- unlockTyp ls],
|
||||
ty <- typsFrom ty0
|
||||
] ++ [
|
||||
Cn (CIQ m ty) |
|
||||
(m,(ty,ResPar _)) <- jments
|
||||
] ++ [ty |
|
||||
(_,(_,CncFun _ _ tr _)) <- jments,
|
||||
ty <- err (const []) snd $ appSTM (typsFromTrm tr) []
|
||||
]
|
||||
typsFrom ty = case ty of
|
||||
Table p t -> typsFrom p ++ typsFrom t
|
||||
RecType ls -> RecType (unlockTyp ls) : concat [typsFrom t | Lbg _ t <- ls]
|
||||
_ -> [ty]
|
||||
|
||||
typsFromTrm :: Term -> STM [CType] Term
|
||||
typsFromTrm tr = case tr of
|
||||
V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr
|
||||
T ty cs -> updateSTM (ty:) >> mapM_ typsFromTrm [t | Cas _ t <- cs] >> return tr
|
||||
_ -> composOp typsFromTrm tr
|
||||
|
||||
|
||||
jments = [(m,j) | (m,mo) <- M.allModMod cgr, j <- tree2list $ M.jments mo]
|
||||
typs = Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params]
|
||||
untyps = Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs]
|
||||
lincats =
|
||||
[(IC cat,[Lbg (L (IC "s")) TStr]) | cat <- ["Int", "Float", "String"]] ++
|
||||
[(cat,(unlockTyp ls)) | (_,(cat,CncCat (RecType ls) _ _)) <- jments]
|
||||
labels = Map.fromList $ concat
|
||||
[((cat,[lab]),(typ,i)):
|
||||
[((cat,[lab,lab2]),(ty,j)) |
|
||||
rs <- getRec typ, (Lbg lab2 ty,j) <- zip rs [0..]]
|
||||
|
|
||||
(cat,ls) <- lincats, (Lbg lab typ,i) <- zip ls [0..]]
|
||||
-- go to tables recursively
|
||||
---- TODO: even go to deeper records
|
||||
where
|
||||
getRec typ = case typ of
|
||||
RecType rs -> [rs]
|
||||
Table _ t -> getRec t
|
||||
_ -> []
|
||||
|
||||
type2type :: CanonGrammar -> ParamEnv -> CType -> CType
|
||||
type2type cgr env@(labels,untyps,typs) ty = case ty of
|
||||
RecType rs ->
|
||||
let
|
||||
rs' = [Lbg (mkLab i) (t2t t) |
|
||||
(i,Lbg l t) <- zip [0..] (unlockTyp rs)]
|
||||
in if (any isStrType [t | Lbg _ t <- rs])
|
||||
then RecType rs'
|
||||
else RecType [Lbg (L (IC "_")) (look ty), Lbg (L (IC "__")) (RecType rs')]
|
||||
|
||||
Table pt vt -> Table (t2t pt) (t2t vt)
|
||||
Cn _ -> look ty
|
||||
_ -> ty
|
||||
where
|
||||
t2t = type2type cgr env
|
||||
look ty = TInts $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of
|
||||
Just vs -> length $ Map.assocs vs
|
||||
_ -> trace ("unknown partype " ++ show ty) 1 ---- 66669
|
||||
|
||||
term2term :: CanonGrammar -> ParamEnv -> Term -> Term
|
||||
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..] (unlock rs)]
|
||||
in if (any (isStr . trmAss) rs)
|
||||
then R rs'
|
||||
else R [Ass (L (IC "_")) (mkValCase tr), Ass (L (IC "__")) (R rs')]
|
||||
P t l -> r2r tr
|
||||
|
||||
T ti [Cas ps@[PV _] t] -> T ti [Cas ps (t2t t)]
|
||||
|
||||
T _ cs0 -> case expandLinTables cgr tr of -- normalize order of cases
|
||||
Ok (T ty cs) -> checkCases 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 (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v
|
||||
|
||||
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
|
||||
_ -> K (KS (A.prt tr +++ prtTrace tr "66665"))
|
||||
|
||||
-- this goes recursively into tables (ignored) and records (accumulated)
|
||||
getLab tr = case tr of
|
||||
Arg (A cat _) -> return (cat,[])
|
||||
P p lab2 -> do
|
||||
(cat,labs) <- getLab p
|
||||
return (cat,labs++[lab2])
|
||||
S p _ -> getLab p
|
||||
_ -> Bad "getLab"
|
||||
|
||||
doVar :: Term -> STM [((CType,[Term]),(Term,Term))] Term
|
||||
doVar tr = case getLab tr of
|
||||
Ok (cat, lab) -> do
|
||||
k <- readSTM >>= return . length
|
||||
let tr' = LI $ identC $ show k
|
||||
|
||||
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)])
|
||||
_ -> error $ A.prt ty
|
||||
_ -> error $ A.prt tr
|
||||
updateSTM ((tyvs, (tr', tr)):)
|
||||
return tr'
|
||||
_ -> composOp doVar tr
|
||||
|
||||
mkValCase tr = case appSTM (doVar tr) [] of
|
||||
Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st
|
||||
_ -> valNum tr
|
||||
|
||||
mkCase ((ty,vs),(x,p)) tr =
|
||||
S (V ty [mkBranch x v tr | v <- vs]) p
|
||||
mkBranch x t tr = case tr of
|
||||
_ | tr == x -> t
|
||||
_ -> composSafeOp (mkBranch x t) tr
|
||||
|
||||
valNum tr = maybe (tryPerm tr) EInt $ Map.lookup tr untyps
|
||||
where
|
||||
tryPerm tr = case tr of
|
||||
R rs -> case Map.lookup (R rs) untyps of
|
||||
Just v -> EInt v
|
||||
_ -> valNumFV $ tryVar tr
|
||||
_ -> valNumFV $ tryVar tr
|
||||
tryVar tr = case tr of
|
||||
Par c ts -> [Par c ts' | ts' <- combinations (map tryVar ts)]
|
||||
FV ts -> ts
|
||||
_ -> [tr]
|
||||
valNumFV ts = case ts of
|
||||
[tr] -> EInt 66667 ----K (KS (A.prt tr +++ prtTrace tr "66667"))
|
||||
_ -> FV $ map valNum ts
|
||||
isStr tr = case tr of
|
||||
Par _ _ -> False
|
||||
EInt _ -> False
|
||||
R rs -> any (isStr . trmAss) rs
|
||||
FV ts -> any isStr ts
|
||||
S t _ -> isStr t
|
||||
E -> True
|
||||
T _ cs -> any isStr [v | Cas _ v <- cs]
|
||||
V _ ts -> any isStr ts
|
||||
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 ----
|
||||
trmAss (Ass _ t) = t
|
||||
|
||||
--- this is mainly needed for parameter record projections
|
||||
comp t = errVal t $ Look.ccompute cgr [] t
|
||||
|
||||
isStrType ty = case ty of
|
||||
TStr -> True
|
||||
RecType ts -> any isStrType [t | Lbg _ t <- ts]
|
||||
Table _ t -> isStrType t
|
||||
_ -> False
|
||||
|
||||
mkLab k = L (IC ("_" ++ show k))
|
||||
|
||||
-- remove lock fields; in fact, any empty records and record types
|
||||
unlock = filter notlock where
|
||||
notlock (Ass l t) = case t of --- need not look at l
|
||||
R [] -> False
|
||||
_ -> True
|
||||
unlockTyp = filter notlock where
|
||||
notlock (Lbg l t) = case t of --- need not look at l
|
||||
RecType [] -> False
|
||||
_ -> True
|
||||
|
||||
|
||||
prtTrace tr n = n ----trace ("-- ERROR" +++ A.prt tr +++ show n +++ show tr) n
|
||||
prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n
|
||||
|
||||
@@ -1,95 +0,0 @@
|
||||
module GF.Canon.CanonToJS (prCanon2js) where
|
||||
|
||||
import GF.Canon.GFC
|
||||
import GF.Canon.CanonToGFCC
|
||||
import GF.Canon.Look
|
||||
import GF.Data.ErrM
|
||||
import GF.Infra.Option
|
||||
import qualified GF.GFCC.Macros as M
|
||||
import qualified GF.GFCC.DataGFCC as D
|
||||
import qualified GF.GFCC.DataGFCC as C
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId(CId))
|
||||
import qualified GF.JavaScript.AbsJS as JS
|
||||
import qualified GF.JavaScript.PrintJS as JS
|
||||
|
||||
|
||||
import Control.Monad (mplus)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
prCanon2js :: Options -> CanonGrammar -> String
|
||||
prCanon2js opts gr = gfcc2js start $ mkCanon2gfcc gr
|
||||
where
|
||||
start = fromMaybe "S" (getOptVal opts gStartCat
|
||||
`mplus` getOptVal grOpts gStartCat)
|
||||
grOpts = errVal noOptions $ lookupOptionsCan gr
|
||||
|
||||
gfcc2js :: String -> D.GFCC -> String
|
||||
gfcc2js start gfcc =
|
||||
JS.printTree $ JS.Program $ abstract2js start n as ++
|
||||
concatMap (concrete2js n) cs
|
||||
where
|
||||
n = D.absname gfcc
|
||||
as = D.abstract gfcc
|
||||
cs = Map.assocs (D.concretes gfcc)
|
||||
|
||||
abstract2js :: String -> CId -> D.Abstr -> [JS.Element]
|
||||
abstract2js start (CId n) ds =
|
||||
[JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit a (new "Abstract" [JS.EStr start])]]
|
||||
++ concatMap (absdef2js a) (Map.assocs (D.funs ds))
|
||||
where a = JS.Ident n
|
||||
|
||||
absdef2js :: JS.Ident -> (CId,(C.Type,C.Exp)) -> [JS.Element]
|
||||
absdef2js a (CId f,(typ,_)) =
|
||||
let (args,CId cat) = M.catSkeleton typ in
|
||||
[JS.ElStmt $ JS.SDeclOrExpr $ JS.DExpr $ JS.ECall (JS.EMember (JS.EVar a) (JS.Ident "addType"))
|
||||
[JS.EStr f, JS.EArray [JS.EStr x | CId x <- args], JS.EStr cat]]
|
||||
|
||||
concrete2js :: CId -> (CId,D.Concr) -> [JS.Element]
|
||||
concrete2js (CId a) (CId c, cnc) =
|
||||
[JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit l (new "Concrete" [JS.EVar (JS.Ident a)])]]
|
||||
++ concatMap (cncdef2js l) ds
|
||||
where
|
||||
l = JS.Ident c
|
||||
ds = concatMap Map.assocs [D.lins cnc, D.opers cnc, D.lindefs cnc]
|
||||
|
||||
cncdef2js :: JS.Ident -> (CId,C.Term) -> [JS.Element]
|
||||
cncdef2js l (CId f, t) =
|
||||
[JS.ElStmt $ JS.SDeclOrExpr $ JS.DExpr $ JS.ECall (JS.EMember (JS.EVar l) (JS.Ident "addRule")) [JS.EStr f, JS.EFun [children] [JS.SReturn (term2js l t)]]]
|
||||
|
||||
term2js :: JS.Ident -> C.Term -> JS.Expr
|
||||
term2js l t = f t
|
||||
where
|
||||
f t =
|
||||
case t of
|
||||
C.R xs -> new "Arr" (map f xs)
|
||||
C.P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y]
|
||||
C.S xs -> mkSeq (map f xs)
|
||||
C.K t -> tokn2js t
|
||||
C.V i -> JS.EIndex (JS.EVar children) (JS.EInt i)
|
||||
C.C i -> new "Int" [JS.EInt i]
|
||||
C.F (CId f) -> JS.ECall (JS.EMember (JS.EVar l) (JS.Ident "rule")) [JS.EStr f, JS.EVar children]
|
||||
C.FV xs -> new "Variants" (map f xs)
|
||||
C.W str x -> new "Suffix" [JS.EStr str, f x]
|
||||
C.RP x y -> new "Rp" [f x, f y]
|
||||
C.TM -> new "Meta" []
|
||||
|
||||
tokn2js :: C.Tokn -> JS.Expr
|
||||
tokn2js (C.KS s) = mkStr s
|
||||
tokn2js (C.KP ss vs) = mkSeq (map mkStr ss) -- FIXME
|
||||
|
||||
mkStr :: String -> JS.Expr
|
||||
mkStr s = new "Str" [JS.EStr s]
|
||||
|
||||
mkSeq :: [JS.Expr] -> JS.Expr
|
||||
mkSeq [x] = x
|
||||
mkSeq xs = new "Seq" xs
|
||||
|
||||
argIdent :: Integer -> JS.Ident
|
||||
argIdent n = JS.Ident ("x" ++ show n)
|
||||
|
||||
children :: JS.Ident
|
||||
children = JS.Ident "cs"
|
||||
|
||||
new :: String -> [JS.Expr] -> JS.Expr
|
||||
new f xs = JS.ENew (JS.Ident f) xs
|
||||
@@ -15,10 +15,11 @@ import GF.Devel.Grammar.PrGF
|
||||
--import GF.Devel.ModDeps
|
||||
import GF.Infra.Ident
|
||||
|
||||
import GF.Devel.PrintGFCC
|
||||
import qualified GF.GFCC.Macros as CM
|
||||
import qualified GF.GFCC.AbsGFCC as C
|
||||
import qualified GF.GFCC.DataGFCC as C
|
||||
import qualified GF.GFCC.DataGFCC as D
|
||||
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import GF.Infra.Option ----
|
||||
import GF.Data.Operations
|
||||
import GF.Text.UTF8
|
||||
@@ -31,7 +32,7 @@ import Debug.Trace ----
|
||||
-- the main function: generate GFCC from GF.
|
||||
|
||||
prGrammar2gfcc :: Options -> String -> GF -> (String,String)
|
||||
prGrammar2gfcc opts cnc gr = (abs, D.printGFCC gc) where
|
||||
prGrammar2gfcc opts cnc gr = (abs, printGFCC gc) where
|
||||
(abs,gc) = mkCanon2gfcc opts cnc gr
|
||||
|
||||
mkCanon2gfcc :: Options -> String -> GF -> (String,D.GFCC)
|
||||
@@ -57,9 +58,9 @@ canon2gfcc opts pars cgr =
|
||||
an = (i2i a)
|
||||
cns = map (i2i . fst) cms
|
||||
abs = D.Abstr aflags funs cats catfuns
|
||||
gflags = Map.fromList [(C.CId fg,x) | Just x <- [getOptVal opts (aOpt fg)]]
|
||||
gflags = Map.fromList [(CId fg,x) | Just x <- [getOptVal opts (aOpt fg)]]
|
||||
where fg = "firstlang"
|
||||
aflags = Map.fromList [(C.CId f,x) | (IC f,x) <- Map.toList (M.mflags abm)]
|
||||
aflags = Map.fromList [(CId f,x) | (IC f,x) <- Map.toList (M.mflags abm)]
|
||||
mkDef pty = case pty of
|
||||
Meta _ -> CM.primNotion
|
||||
t -> mkExp t
|
||||
@@ -80,7 +81,7 @@ canon2gfcc opts pars cgr =
|
||||
(lang,D.Concr flags lins opers lincats lindefs printnames params)
|
||||
where
|
||||
js = listJudgements mo
|
||||
flags = Map.fromList [(C.CId f,x) | (IC f,x) <- Map.toList (M.mflags mo)]
|
||||
flags = Map.fromList [(CId f,x) | (IC f,x) <- Map.toList (M.mflags mo)]
|
||||
opers = Map.fromAscList [] -- opers will be created as optimization
|
||||
utf = if elem (IC "coding","utf8") (Map.assocs (M.mflags mo)) ----
|
||||
then D.convertStringsInTerm decodeUTF8 else id
|
||||
@@ -96,8 +97,8 @@ canon2gfcc opts pars cgr =
|
||||
params = Map.fromAscList
|
||||
[(i2i c, pars lang0 c) | (c,ju) <- js, jform ju == JLincat] ---- c ??
|
||||
|
||||
i2i :: Ident -> C.CId
|
||||
i2i = C.CId . prIdent
|
||||
i2i :: Ident -> CId
|
||||
i2i = CId . prIdent
|
||||
|
||||
mkType :: A.Type -> C.Type
|
||||
mkType t = case GM.typeForm t of
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
module GF.GFCC.CheckGFCC (checkGFCC, checkGFCCio) where
|
||||
module GF.GFCC.CheckGFCC (checkGFCC, checkGFCCio, checkGFCCmaybe) where
|
||||
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import GF.GFCC.Macros
|
||||
@@ -18,6 +18,12 @@ checkGFCCio gfcc = case checkGFCC gfcc of
|
||||
putStrLn s
|
||||
error "building GFCC failed"
|
||||
|
||||
---- needed in old Custom
|
||||
checkGFCCmaybe :: GFCC -> Maybe GFCC
|
||||
checkGFCCmaybe gfcc = case checkGFCC gfcc of
|
||||
Ok (gc,b) -> return gc
|
||||
Bad s -> Nothing
|
||||
|
||||
checkGFCC :: GFCC -> Err (GFCC,Bool)
|
||||
checkGFCC gfcc = do
|
||||
(cs,bs) <- mapM (checkConcrete gfcc)
|
||||
|
||||
@@ -34,10 +34,19 @@ import GF.Grammar.Values
|
||||
import qualified GF.Grammar.Grammar as G
|
||||
import qualified GF.Canon.AbsGFC as A
|
||||
import qualified GF.Canon.GFC as C
|
||||
import qualified GF.Canon.CanonToGFCC as GFCC
|
||||
|
||||
import qualified GF.Devel.GrammarToGFCC as GFCC
|
||||
import qualified GF.Devel.GFCCtoHaskell as CCH
|
||||
import qualified GF.GFCC.DataGFCC as DataGFCC
|
||||
import qualified GF.Canon.CanonToJS as JS (prCanon2js)
|
||||
import GF.Devel.PrintGFCC
|
||||
import qualified GF.Devel.GFCCtoJS as JS
|
||||
import GF.GFCC.CheckGFCC (checkGFCCmaybe)
|
||||
import GF.GFCC.OptimizeGFCC
|
||||
|
||||
--import qualified GF.Canon.CanonToGFCC as GFCC
|
||||
--import qualified GF.Devel.GFCCtoHaskell as CCH
|
||||
--import qualified GF.GFCC.DataGFCC as DataGFCC
|
||||
--import qualified GF.Canon.CanonToJS as JS (prCanon2js)
|
||||
|
||||
import qualified GF.Source.AbsGF as GF
|
||||
import qualified GF.Grammar.MMacros as MM
|
||||
import GF.Grammar.AbsCompute
|
||||
@@ -106,6 +115,7 @@ import GF.Visualization.VisualizeGrammar (visualizeCanonGrammar, visualizeSource
|
||||
|
||||
import GF.API.MyParser
|
||||
|
||||
import qualified GF.Infra.Modules as M
|
||||
import GF.Infra.UseIO
|
||||
|
||||
import Control.Monad
|
||||
@@ -274,8 +284,8 @@ customGrammarPrinter =
|
||||
,(strCI "bnf", \_ -> prBNF False)
|
||||
,(strCI "absbnf", \_ -> abstract2bnf . stateGrammarST)
|
||||
,(strCI "haskell", \_ -> grammar2haskell . stateGrammarST)
|
||||
,(strCI "gfcc_haskell", \_ -> CCH.grammar2haskell .
|
||||
GFCC.mkCanon2gfcc . stateGrammarST)
|
||||
,(strCI "gfcc_haskell", \opts -> CCH.grammar2haskell .
|
||||
canon2gfcc opts . stateGrammarST)
|
||||
,(strCI "haskell_gadt", \_ -> grammar2haskellGADT . stateGrammarST)
|
||||
,(strCI "transfer", \_ -> grammar2transfer . stateGrammarST)
|
||||
,(strCI "morpho", \_ -> prMorpho . stateMorpho)
|
||||
@@ -328,8 +338,8 @@ customMultiGrammarPrinter =
|
||||
customData "Printers for multiple grammars, selected by option -printer=x" $
|
||||
[
|
||||
(strCI "gfcm", const MC.prCanon)
|
||||
,(strCI "gfcc", const GFCC.prCanon2gfcc)
|
||||
,(strCI "js", JS.prCanon2js)
|
||||
,(strCI "gfcc", canon2gfccPr)
|
||||
,(strCI "js", \opts -> JS.gfcc2js . canon2gfcc opts)
|
||||
,(strCI "header", const (MC.prCanonMGr . unoptimizeCanon))
|
||||
,(strCI "cfgm", prCanonAsCFGM)
|
||||
,(strCI "graph", visualizeCanonGrammar)
|
||||
@@ -341,6 +351,21 @@ customMultiGrammarPrinter =
|
||||
,(strCI "cfg-prolog", CnvProlog.prtCMulti)
|
||||
]
|
||||
|
||||
---Options -> CanonGrammar -> String
|
||||
canon2gfccPr opts = printGFCC . canon2gfcc opts
|
||||
canon2gfcc opts = source2gfcc opts . canon2source ----
|
||||
canon2source = err error id . canon2sourceGrammar . unSubelimCanon
|
||||
|
||||
source2gfcc opts gf =
|
||||
let
|
||||
(abs,gfcc) = GFCC.mkCanon2gfcc opts (gfcabs gf) gf
|
||||
gfcc1 = maybe undefined id $ checkGFCCmaybe gfcc
|
||||
in if oElem (iOpt "noopt") opts then gfcc1 else optGFCC gfcc1
|
||||
|
||||
gfcabs gfc =
|
||||
prt $ head $ M.allConcretes gfc $ maybe (error "no abstract") id $
|
||||
M.greatestAbstract gfc
|
||||
|
||||
|
||||
customSyntaxPrinter =
|
||||
customData "Syntax printers, selected by option -printer=x" $
|
||||
|
||||
Reference in New Issue
Block a user