mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-23 19:42:50 -06:00
removed gfcc via gfc everywhere; workaround for russian in present
This commit is contained in:
aarne
@@ -196,7 +196,10 @@ oper
|
|||||||
case t of { Present => VPresent p ; PastRus => VPast; Future => VFuture p } ;
|
case t of { Present => VPresent p ; PastRus => VPast; Future => VFuture p } ;
|
||||||
|
|
||||||
getTense : Tense -> RusTense= \t ->
|
getTense : Tense -> RusTense= \t ->
|
||||||
case t of { Pres => Present ; Fut => Future; _ => PastRus} ;
|
case t of { Pres => Present
|
||||||
|
; Fut => Future --# notpresent
|
||||||
|
; _ => PastRus --# notpresent
|
||||||
|
} ;
|
||||||
|
|
||||||
|
|
||||||
getVoice: VerbForm -> Voice = \vf ->
|
getVoice: VerbForm -> Voice = \vf ->
|
||||||
|
|||||||
@@ -84,19 +84,23 @@ concrete SentenceRus of Sentence = CatRus ** open Prelude, ResRus in {
|
|||||||
|
|
||||||
UseCl t a p cl = {s = case t.t of {
|
UseCl t a p cl = {s = case t.t of {
|
||||||
Cond => cl.s! p.p ! ClCondit ; --# notpresent
|
Cond => cl.s! p.p ! ClCondit ; --# notpresent
|
||||||
|
Pres => cl.s! p.p ! ClIndic Present a.a ; ---- AR work-around 13/12/2007
|
||||||
_ => cl.s! p.p ! ClIndic (getTense t.t) a.a}};
|
_ => cl.s! p.p ! ClIndic (getTense t.t) a.a}};
|
||||||
|
|
||||||
UseQCl t a p qcl= {s = case t.t of {
|
UseQCl t a p qcl= {s = case t.t of {
|
||||||
Cond => qcl.s! p.p ! ClCondit ; --# notpresent
|
Cond => qcl.s! p.p ! ClCondit ; --# notpresent
|
||||||
|
Pres => qcl.s! p.p ! ClIndic Present a.a ;
|
||||||
_ => qcl.s!p.p! ClIndic (getTense t.t) a.a }};
|
_ => qcl.s!p.p! ClIndic (getTense t.t) a.a }};
|
||||||
|
|
||||||
UseRCl t a p rcl ={s = \\gn,c,anim => case t.t of {
|
UseRCl t a p rcl ={s = \\gn,c,anim => case t.t of {
|
||||||
Cond => [", "] ++ rcl.s! p.p ! ClCondit ! gn !c !anim ; --# notpresent
|
Cond => [", "] ++ rcl.s! p.p ! ClCondit ! gn !c !anim ; --# notpresent
|
||||||
|
Pres => [", "] ++ rcl.s! p.p ! ClIndic Present a.a !gn !c !anim;
|
||||||
_ => [", "] ++ rcl.s! p.p ! ClIndic (getTense t.t) a.a !gn !c !anim}};
|
_ => [", "] ++ rcl.s! p.p ! ClIndic (getTense t.t) a.a !gn !c !anim}};
|
||||||
|
|
||||||
UseSlash t a p cl = {
|
UseSlash t a p cl = {
|
||||||
s = case t.t of {
|
s = case t.t of {
|
||||||
Cond => cl.s! p.p ! ClCondit ; --# notpresent
|
Cond => cl.s! p.p ! ClCondit ; --# notpresent
|
||||||
|
Pres => cl.s! p.p ! ClIndic Present a.a ;
|
||||||
_ => cl.s! p.p ! ClIndic (getTense t.t) a.a
|
_ => cl.s! p.p ! ClIndic (getTense t.t) a.a
|
||||||
} ;
|
} ;
|
||||||
s2 = cl.s2 ;
|
s2 = cl.s2 ;
|
||||||
|
|||||||
@@ -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.Devel.ModDeps
|
||||||
import GF.Infra.Ident
|
import GF.Infra.Ident
|
||||||
|
|
||||||
|
import GF.Devel.PrintGFCC
|
||||||
import qualified GF.GFCC.Macros as CM
|
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 qualified GF.GFCC.DataGFCC as D
|
||||||
|
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||||
import GF.Infra.Option ----
|
import GF.Infra.Option ----
|
||||||
import GF.Data.Operations
|
import GF.Data.Operations
|
||||||
import GF.Text.UTF8
|
import GF.Text.UTF8
|
||||||
@@ -31,7 +32,7 @@ import Debug.Trace ----
|
|||||||
-- the main function: generate GFCC from GF.
|
-- the main function: generate GFCC from GF.
|
||||||
|
|
||||||
prGrammar2gfcc :: Options -> String -> GF -> (String,String)
|
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
|
(abs,gc) = mkCanon2gfcc opts cnc gr
|
||||||
|
|
||||||
mkCanon2gfcc :: Options -> String -> GF -> (String,D.GFCC)
|
mkCanon2gfcc :: Options -> String -> GF -> (String,D.GFCC)
|
||||||
@@ -57,9 +58,9 @@ canon2gfcc opts pars cgr =
|
|||||||
an = (i2i a)
|
an = (i2i a)
|
||||||
cns = map (i2i . fst) cms
|
cns = map (i2i . fst) cms
|
||||||
abs = D.Abstr aflags funs cats catfuns
|
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"
|
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
|
mkDef pty = case pty of
|
||||||
Meta _ -> CM.primNotion
|
Meta _ -> CM.primNotion
|
||||||
t -> mkExp t
|
t -> mkExp t
|
||||||
@@ -80,7 +81,7 @@ canon2gfcc opts pars cgr =
|
|||||||
(lang,D.Concr flags lins opers lincats lindefs printnames params)
|
(lang,D.Concr flags lins opers lincats lindefs printnames params)
|
||||||
where
|
where
|
||||||
js = listJudgements mo
|
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
|
opers = Map.fromAscList [] -- opers will be created as optimization
|
||||||
utf = if elem (IC "coding","utf8") (Map.assocs (M.mflags mo)) ----
|
utf = if elem (IC "coding","utf8") (Map.assocs (M.mflags mo)) ----
|
||||||
then D.convertStringsInTerm decodeUTF8 else id
|
then D.convertStringsInTerm decodeUTF8 else id
|
||||||
@@ -96,8 +97,8 @@ canon2gfcc opts pars cgr =
|
|||||||
params = Map.fromAscList
|
params = Map.fromAscList
|
||||||
[(i2i c, pars lang0 c) | (c,ju) <- js, jform ju == JLincat] ---- c ??
|
[(i2i c, pars lang0 c) | (c,ju) <- js, jform ju == JLincat] ---- c ??
|
||||||
|
|
||||||
i2i :: Ident -> C.CId
|
i2i :: Ident -> CId
|
||||||
i2i = C.CId . prIdent
|
i2i = CId . prIdent
|
||||||
|
|
||||||
mkType :: A.Type -> C.Type
|
mkType :: A.Type -> C.Type
|
||||||
mkType t = case GM.typeForm t of
|
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.Raw.AbsGFCCRaw (CId (..))
|
||||||
import GF.GFCC.Macros
|
import GF.GFCC.Macros
|
||||||
@@ -18,6 +18,12 @@ checkGFCCio gfcc = case checkGFCC gfcc of
|
|||||||
putStrLn s
|
putStrLn s
|
||||||
error "building GFCC failed"
|
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 -> Err (GFCC,Bool)
|
||||||
checkGFCC gfcc = do
|
checkGFCC gfcc = do
|
||||||
(cs,bs) <- mapM (checkConcrete gfcc)
|
(cs,bs) <- mapM (checkConcrete gfcc)
|
||||||
|
|||||||
@@ -34,10 +34,19 @@ import GF.Grammar.Values
|
|||||||
import qualified GF.Grammar.Grammar as G
|
import qualified GF.Grammar.Grammar as G
|
||||||
import qualified GF.Canon.AbsGFC as A
|
import qualified GF.Canon.AbsGFC as A
|
||||||
import qualified GF.Canon.GFC as C
|
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.Devel.GFCCtoHaskell as CCH
|
||||||
import qualified GF.GFCC.DataGFCC as DataGFCC
|
import GF.Devel.PrintGFCC
|
||||||
import qualified GF.Canon.CanonToJS as JS (prCanon2js)
|
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.Source.AbsGF as GF
|
||||||
import qualified GF.Grammar.MMacros as MM
|
import qualified GF.Grammar.MMacros as MM
|
||||||
import GF.Grammar.AbsCompute
|
import GF.Grammar.AbsCompute
|
||||||
@@ -106,6 +115,7 @@ import GF.Visualization.VisualizeGrammar (visualizeCanonGrammar, visualizeSource
|
|||||||
|
|
||||||
import GF.API.MyParser
|
import GF.API.MyParser
|
||||||
|
|
||||||
|
import qualified GF.Infra.Modules as M
|
||||||
import GF.Infra.UseIO
|
import GF.Infra.UseIO
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
@@ -274,8 +284,8 @@ customGrammarPrinter =
|
|||||||
,(strCI "bnf", \_ -> prBNF False)
|
,(strCI "bnf", \_ -> prBNF False)
|
||||||
,(strCI "absbnf", \_ -> abstract2bnf . stateGrammarST)
|
,(strCI "absbnf", \_ -> abstract2bnf . stateGrammarST)
|
||||||
,(strCI "haskell", \_ -> grammar2haskell . stateGrammarST)
|
,(strCI "haskell", \_ -> grammar2haskell . stateGrammarST)
|
||||||
,(strCI "gfcc_haskell", \_ -> CCH.grammar2haskell .
|
,(strCI "gfcc_haskell", \opts -> CCH.grammar2haskell .
|
||||||
GFCC.mkCanon2gfcc . stateGrammarST)
|
canon2gfcc opts . stateGrammarST)
|
||||||
,(strCI "haskell_gadt", \_ -> grammar2haskellGADT . stateGrammarST)
|
,(strCI "haskell_gadt", \_ -> grammar2haskellGADT . stateGrammarST)
|
||||||
,(strCI "transfer", \_ -> grammar2transfer . stateGrammarST)
|
,(strCI "transfer", \_ -> grammar2transfer . stateGrammarST)
|
||||||
,(strCI "morpho", \_ -> prMorpho . stateMorpho)
|
,(strCI "morpho", \_ -> prMorpho . stateMorpho)
|
||||||
@@ -328,8 +338,8 @@ customMultiGrammarPrinter =
|
|||||||
customData "Printers for multiple grammars, selected by option -printer=x" $
|
customData "Printers for multiple grammars, selected by option -printer=x" $
|
||||||
[
|
[
|
||||||
(strCI "gfcm", const MC.prCanon)
|
(strCI "gfcm", const MC.prCanon)
|
||||||
,(strCI "gfcc", const GFCC.prCanon2gfcc)
|
,(strCI "gfcc", canon2gfccPr)
|
||||||
,(strCI "js", JS.prCanon2js)
|
,(strCI "js", \opts -> JS.gfcc2js . canon2gfcc opts)
|
||||||
,(strCI "header", const (MC.prCanonMGr . unoptimizeCanon))
|
,(strCI "header", const (MC.prCanonMGr . unoptimizeCanon))
|
||||||
,(strCI "cfgm", prCanonAsCFGM)
|
,(strCI "cfgm", prCanonAsCFGM)
|
||||||
,(strCI "graph", visualizeCanonGrammar)
|
,(strCI "graph", visualizeCanonGrammar)
|
||||||
@@ -341,6 +351,21 @@ customMultiGrammarPrinter =
|
|||||||
,(strCI "cfg-prolog", CnvProlog.prtCMulti)
|
,(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 =
|
customSyntaxPrinter =
|
||||||
customData "Syntax printers, selected by option -printer=x" $
|
customData "Syntax printers, selected by option -printer=x" $
|
||||||
|
|||||||
Reference in New Issue
Block a user