forked from GitHub/gf-core
411 lines
13 KiB
Haskell
411 lines
13 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : CanonToGFCC
|
|
-- Maintainer : AR
|
|
-- Stability : (stable)
|
|
-- Portability : (portable)
|
|
--
|
|
-- > CVS $Date: 2005/06/17 14:15:17 $
|
|
-- > CVS $Author: aarne $
|
|
-- > CVS $Revision: 1.15 $
|
|
--
|
|
-- a decompiler. AR 12/6/2003 -- 19/4/2004
|
|
-----------------------------------------------------------------------------
|
|
|
|
module GF.Canon.CanonToGFCC (prCanon2gfcc) where
|
|
|
|
import GF.Canon.AbsGFC
|
|
import qualified GF.Canon.GFC as GFC
|
|
import qualified GF.Canon.Look as Look
|
|
import qualified GF.Canon.GFCC.AbsGFCC as C
|
|
import qualified GF.Canon.GFCC.PrintGFCC as Pr
|
|
import GF.Canon.GFC
|
|
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 (unoptimizeCanon)
|
|
|
|
import GF.Infra.Ident
|
|
import GF.Data.Operations
|
|
|
|
import Data.List
|
|
import qualified Data.Map as Map
|
|
|
|
|
|
prCanon2gfcc :: CanonGrammar -> String
|
|
prCanon2gfcc = Pr.printTree . canon2gfcc . canon2canon . unoptimizeCanon
|
|
|
|
-- this assumes a grammar translated by canon2canon
|
|
|
|
canon2gfcc :: CanonGrammar -> C.Grammar
|
|
canon2gfcc cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
|
|
C.Grm (C.Hdr (i2i a) cs) (C.Abs adefs) cncs where
|
|
cs = map (i2i . fst) cms
|
|
adefs = [C.Fun f' (mkType ty) (C.Tr (C.AC f') []) |
|
|
(f,GFC.AbsFun ty _) <- tree2list (M.jments abm), let f' = i2i f]
|
|
cncs = [C.Cnc (i2i lang) (concr m) | (lang,M.ModMod m) <- cms]
|
|
concr mo = optConcrete
|
|
[C.Lin (i2i f) (mkTerm tr) |
|
|
(f,GFC.CncFun _ _ tr _) <- tree2list (M.jments mo)]
|
|
|
|
i2i :: Ident -> C.CId
|
|
i2i (IC c) = C.CId c
|
|
|
|
mkType :: A.Type -> C.Type
|
|
mkType t = case GM.catSkeleton t of
|
|
Ok (cs,c) -> C.Typ (map (i2i . snd) cs) (i2i $ snd c)
|
|
|
|
mkTerm :: Term -> C.Term
|
|
mkTerm tr = case tr of
|
|
Arg (A _ i) -> C.V i
|
|
EInt i -> C.C i
|
|
R rs -> C.R [mkTerm t | Ass _ t <- rs]
|
|
P t l -> C.P (mkTerm t) (C.C (mkLab l))
|
|
T _ cs -> C.R [mkTerm t | Cas _ t <- cs]
|
|
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 _ _ -> C.C 444 ---- just for debugging
|
|
---- _ -> C.S [C.K (C.KS (show tr))] ---- just for debugging
|
|
_ -> C.S [C.K (C.KS (A.prt tr))] ---- just for debugging
|
|
where
|
|
mkLab (L (IC l)) = case l of
|
|
'_':ds -> (read ds) :: Integer
|
|
_ -> 789
|
|
|
|
-- translate tables and records to arrays, return just one module per language
|
|
canon2canon :: CanonGrammar -> CanonGrammar
|
|
canon2canon cgr = reorder $ M.MGrammar $ map c2c $ M.modules cgr where
|
|
reorder cg = M.MGrammar $
|
|
(abs, M.ModMod $
|
|
M.Module M.MTAbstract M.MSComplete [] [] [] (sorted2tree adefs)):
|
|
[(c, M.ModMod $
|
|
M.Module (M.MTConcrete abs) M.MSComplete [] [] [] (sorted2tree js))
|
|
| (c,js) <- cncs cg]
|
|
abs = maybe (error "no abstract") id $ M.greatestAbstract cgr
|
|
adefs = sortBy (\ (f,_) (g,_) -> compare f g)
|
|
[finfo |
|
|
(i,mo) <- mos, M.isModAbs mo,
|
|
finfo <- tree2list (M.jments mo)]
|
|
cncs cg = sortBy (\ (x,_) (y,_) -> compare x y)
|
|
[(lang, concr lang) | lang <- M.allConcretes cg abs]
|
|
mos = M.allModMod cgr
|
|
concr la = sortBy (\ (f,_) (g,_) -> compare f g)
|
|
[finfo |
|
|
(i,mo) <- mos, M.isModCnc mo, ----- TODO: separate langs
|
|
finfo <- tree2list (M.jments mo)]
|
|
|
|
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)
|
|
_ -> (f,j)
|
|
t2t = term2term cgr (paramValues cgr)
|
|
|
|
type ParamEnv =
|
|
(Map.Map Term Integer, -- untyped terms to values
|
|
Map.Map CIdent (Map.Map Term Integer)) -- types to their terms to values
|
|
|
|
paramValues :: CanonGrammar -> ParamEnv
|
|
paramValues cgr = (untyps,typs) where
|
|
params = [(mty, errVal [] $ Look.lookupParamValues cgr mty) |
|
|
(m,mo) <- M.allModMod cgr,
|
|
(ty,ResPar _) <- tree2list $ M.jments mo,
|
|
let mty = CIQ m ty
|
|
]
|
|
typs = Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params]
|
|
untyps = Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs]
|
|
|
|
term2term :: CanonGrammar -> ParamEnv -> Term -> Term
|
|
term2term cgr env@(untyps,typs) tr = case tr of
|
|
Par c ps | any isVar ps -> mkCase c ps
|
|
Par _ _ -> EInt $ valNum tr
|
|
R rs | any (isStr . trmAss) rs -> R [Ass (r2r l) (t2t t) | Ass l t <- rs]
|
|
R rs -> EInt $ valNum tr
|
|
P t l -> P (t2t t) (r2r l)
|
|
T ty cs -> V ty [t2t t | Cas _ t <- cs]
|
|
S t p -> S (t2t t) (t2t p)
|
|
_ -> composSafeOp t2t tr
|
|
where
|
|
t2t = term2term cgr env
|
|
r2r l = L (IC "_111") ---- TODO: number of label
|
|
valNum tr = maybe 456 id $ Map.lookup tr untyps
|
|
isStr tr = case tr of
|
|
Par _ _ -> False
|
|
EInt _ -> False
|
|
R rs -> any (isStr . trmAss) rs
|
|
FV ts -> any isStr ts
|
|
P t r -> True ---- TODO
|
|
_ -> True
|
|
trmAss (Ass _ t) = t
|
|
isVar p = case p of
|
|
Arg _ -> True
|
|
P q _ -> isVar q
|
|
_ -> False
|
|
mkCase c ps = EInt 666 ---- TODO: expand param constr with var
|
|
|
|
|
|
optConcrete :: [C.CncDef] -> [C.CncDef]
|
|
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
|
|
optTerm :: C.Term -> C.Term
|
|
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
|
|
_ -> tr
|
|
where
|
|
optToks ss = prf : suffs where
|
|
prf = pref (sort ss)
|
|
suffs = map (drop (length prf)) ss
|
|
pref ss = longestPref (head ss) (last ss)
|
|
longestPref w u = if isPrefixOf w u then w else longestPref (init w) u
|
|
isK t = case t of
|
|
C.K (C.KS _) -> True
|
|
_ -> False
|
|
|
|
mkSuff (p:ws) = C.W p (C.R (map (C.K . C.KS) ws))
|
|
|
|
|
|
|
|
subex :: [C.CncDef] -> [C.CncDef]
|
|
subex js = errVal js $ do
|
|
(tree,_) <- appSTM (getSubtermsMod js) (Map.empty,0)
|
|
return $ addSubexpConsts tree js
|
|
|
|
-- implementation
|
|
|
|
type TermList = Map.Map C.Term (Int,Int) -- number of occs, id
|
|
type TermM a = STM (TermList,Int) a
|
|
|
|
addSubexpConsts :: TermList -> [C.CncDef] -> [C.CncDef]
|
|
addSubexpConsts tree lins =
|
|
let opers = sortBy (\ (C.Lin f _) (C.Lin g _) -> compare f g)
|
|
[C.Lin (fid id) trm | (trm,(_,id)) <- list]
|
|
in map mkOne $ opers ++ lins
|
|
where
|
|
mkOne (C.Lin f trm) = (C.Lin f (recomp f trm))
|
|
recomp f t = case Map.lookup t tree of
|
|
Just (_,id) | fid id /= f -> C.F $ fid id -- not to replace oper itself
|
|
_ -> case t of
|
|
C.R ts -> C.R $ map (recomp f) ts
|
|
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)
|
|
_ -> t
|
|
fid n = C.CId $ "_" ++ show n
|
|
list = Map.toList tree
|
|
|
|
getSubtermsMod :: [C.CncDef] -> TermM TermList
|
|
getSubtermsMod js = do
|
|
mapM (getInfo collectSubterms) js
|
|
(tree0,_) <- readSTM
|
|
return $ Map.filter (\ (nu,_) -> nu > 1) tree0
|
|
where
|
|
getInfo get (C.Lin f trm) = do
|
|
get trm
|
|
return ()
|
|
|
|
collectSubterms :: C.Term -> TermM ()
|
|
collectSubterms t = case t of
|
|
C.R ts -> do
|
|
mapM collectSubterms ts
|
|
add t
|
|
C.S ts -> do
|
|
mapM collectSubterms ts
|
|
add t
|
|
C.W s u -> do
|
|
collectSubterms u
|
|
add t
|
|
_ -> return ()
|
|
where
|
|
add t = do
|
|
(ts,i) <- readSTM
|
|
let
|
|
((count,id),next) = case Map.lookup t ts of
|
|
Just (nu,id) -> ((nu+1,id), i)
|
|
_ -> ((1, i ), i+1)
|
|
writeSTM (Map.insert t (count,id) ts, next)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
{-
|
|
canon2sourceModule :: CanonModule -> Err G.SourceModule
|
|
canon2sourceModule (i,mi) = do
|
|
i' <- redIdent i
|
|
info' <- case mi of
|
|
M.ModMod m -> do
|
|
(e,os) <- redExtOpen m
|
|
flags <- mapM redFlag $ M.flags m
|
|
(abstr,mt) <- case M.mtype m of
|
|
M.MTConcrete a -> do
|
|
a' <- redIdent a
|
|
return (a', M.MTConcrete a')
|
|
M.MTAbstract -> return (i',M.MTAbstract) --- c' not needed
|
|
M.MTResource -> return (i',M.MTResource) --- c' not needed
|
|
M.MTTransfer x y -> return (i',M.MTTransfer x y) --- c' not needed
|
|
defs <- mapMTree redInfo $ M.jments m
|
|
return $ M.ModMod $ M.Module mt (M.mstatus m) flags e os defs
|
|
_ -> Bad $ "cannot decompile module type"
|
|
return (i',info')
|
|
where
|
|
redExtOpen m = do
|
|
e' <- return $ M.extend m
|
|
os' <- mapM (\ (M.OSimple q i) -> liftM (\i -> M.OQualif q i i) (redIdent i)) $
|
|
M.opens m
|
|
return (e',os')
|
|
|
|
redInfo :: (Ident,Info) -> Err (Ident,G.Info)
|
|
redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do
|
|
c' <- redIdent c
|
|
info' <- case info of
|
|
AbsCat cont fs -> do
|
|
return $ G.AbsCat (Yes cont) (Yes (map (uncurry G.Q) fs))
|
|
AbsFun typ df -> do
|
|
return $ G.AbsFun (Yes typ) (Yes df)
|
|
AbsTrans t -> do
|
|
return $ G.AbsTrans t
|
|
|
|
ResPar par -> liftM (G.ResParam . Yes) $ mapM redParam par
|
|
|
|
CncCat pty ptr ppr -> do
|
|
ty' <- redCType pty
|
|
trm' <- redCTerm ptr
|
|
ppr' <- redCTerm ppr
|
|
return $ G.CncCat (Yes ty') (Yes trm') (Yes ppr')
|
|
CncFun (CIQ abstr cat) xx body ppr -> do
|
|
xx' <- mapM redArgVar xx
|
|
body' <- redCTerm body
|
|
ppr' <- redCTerm ppr
|
|
cat' <- redIdent cat
|
|
return $ G.CncFun (Just (cat', ([],F.typeStr))) -- Nothing
|
|
(Yes (F.mkAbs xx' body')) (Yes ppr')
|
|
|
|
AnyInd b c -> liftM (G.AnyInd b) $ redIdent c
|
|
|
|
return (c',info')
|
|
|
|
redQIdent :: CIdent -> Err G.QIdent
|
|
redQIdent (CIQ m c) = liftM2 (,) (redIdent m) (redIdent c)
|
|
|
|
redIdent :: Ident -> Err Ident
|
|
redIdent = return
|
|
|
|
redFlag :: Flag -> Err O.Option
|
|
redFlag (Flg f x) = return $ O.Opt (prIdent f,[prIdent x])
|
|
|
|
redDecl :: Decl -> Err G.Decl
|
|
redDecl (Decl x a) = liftM2 (,) (redIdent x) (redTerm a)
|
|
|
|
redType :: Exp -> Err G.Type
|
|
redType = redTerm
|
|
|
|
redTerm :: Exp -> Err G.Term
|
|
redTerm t = return $ trExp t
|
|
|
|
-- resource
|
|
|
|
redParam (ParD c cont) = do
|
|
c' <- redIdent c
|
|
cont' <- mapM redCType cont
|
|
return $ (c', [(IW,t) | t <- cont'])
|
|
|
|
-- concrete syntax
|
|
|
|
redCType :: CType -> Err G.Type
|
|
redCType t = case t of
|
|
RecType lbs -> do
|
|
let (ls,ts) = unzip [(l,t) | Lbg l t <- lbs]
|
|
ls' = map redLabel ls
|
|
ts' <- mapM redCType ts
|
|
return $ G.RecType $ zip ls' ts'
|
|
Table p v -> liftM2 G.Table (redCType p) (redCType v)
|
|
Cn mc -> liftM (uncurry G.QC) $ redQIdent mc
|
|
TStr -> return $ F.typeStr
|
|
TInts i -> return $ F.typeInts (fromInteger i)
|
|
|
|
redCTerm :: Term -> Err G.Term
|
|
redCTerm x = case x of
|
|
Arg argvar -> liftM G.Vr $ redArgVar argvar
|
|
I cident -> liftM (uncurry G.Q) $ redQIdent cident
|
|
Par cident terms -> liftM2 F.mkApp
|
|
(liftM (uncurry G.QC) $ redQIdent cident)
|
|
(mapM redCTerm terms)
|
|
LI id -> liftM G.Vr $ redIdent id
|
|
R assigns -> do
|
|
let (ls,ts) = unzip [(l,t) | Ass l t <- assigns]
|
|
let ls' = map redLabel ls
|
|
ts' <- mapM redCTerm ts
|
|
return $ G.R [(l,(Nothing,t)) | (l,t) <- zip ls' ts']
|
|
P term label -> liftM2 G.P (redCTerm term) (return $ redLabel label)
|
|
T ctype cases -> do
|
|
ctype' <- redCType ctype
|
|
let (ps,ts) = unzip [(ps,t) | Cas ps t <- cases]
|
|
ps' <- mapM (mapM redPatt) ps
|
|
ts' <- mapM redCTerm ts
|
|
let tinfo = case ps' of
|
|
[[G.PV _]] -> G.TTyped ctype'
|
|
_ -> G.TComp ctype'
|
|
return $ G.TSh tinfo $ zip ps' ts'
|
|
V ctype ts -> do
|
|
ctype' <- redCType ctype
|
|
ts' <- mapM redCTerm ts
|
|
return $ G.V ctype' ts'
|
|
S term0 term -> liftM2 G.S (redCTerm term0) (redCTerm term)
|
|
C term0 term -> liftM2 G.C (redCTerm term0) (redCTerm term)
|
|
FV terms -> liftM G.FV $ mapM redCTerm terms
|
|
K (KS str) -> return $ G.K str
|
|
EInt i -> return $ G.EInt i
|
|
EFloat i -> return $ G.EFloat i
|
|
E -> return $ G.Empty
|
|
K (KP d vs) -> return $
|
|
G.Alts (tList d,[(tList s, G.Strs $ map G.K v) | Var s v <- vs])
|
|
where
|
|
tList ss = case ss of --- this should be in Macros
|
|
[] -> G.Empty
|
|
_ -> foldr1 G.C $ map G.K ss
|
|
|
|
failure x = Bad $ "not yet" +++ show x ----
|
|
|
|
redArgVar :: ArgVar -> Err Ident
|
|
redArgVar x = case x of
|
|
A x i -> return $ IA (prIdent x, fromInteger i)
|
|
AB x b i -> return $ IAV (prIdent x, fromInteger b, fromInteger i)
|
|
|
|
redLabel :: Label -> G.Label
|
|
redLabel (L x) = G.LIdent $ prIdent x
|
|
redLabel (LV i) = G.LVar $ fromInteger i
|
|
|
|
redPatt :: Patt -> Err G.Patt
|
|
redPatt p = case p of
|
|
PV x -> liftM G.PV $ redIdent x
|
|
PC mc ps -> do
|
|
(m,c) <- redQIdent mc
|
|
liftM (G.PP m c) (mapM redPatt ps)
|
|
PR rs -> do
|
|
let (ls,ts) = unzip [(l,t) | PAss l t <- rs]
|
|
ls' = map redLabel ls
|
|
ts <- mapM redPatt ts
|
|
return $ G.PR $ zip ls' ts
|
|
PI i -> return $ G.PInt i
|
|
PF i -> return $ G.PFloat i
|
|
_ -> Bad $ "cannot recompile pattern" +++ show p
|
|
|
|
-}
|