forked from GitHub/gf-core
started modifying GFtoGFCC for new internal GF format
This commit is contained in:
aarne
517
src/GF/Devel/Compile/GFtoGFCC.hs
Normal file
517
src/GF/Devel/Compile/GFtoGFCC.hs
Normal file
@@ -0,0 +1,517 @@
|
||||
module GF.Devel.GFtoGFCC (prGrammar2gfcc,mkCanon2gfcc) where
|
||||
|
||||
import GF.Devel.Compile.Factorize (unshareModule)
|
||||
|
||||
import GF.Devel.Grammar.Grammar
|
||||
import GF.Devel.Grammar.Construct
|
||||
import qualified GF.Devel.Grammar.Lookup as Look
|
||||
|
||||
import qualified GF.Devel.Grammar.Grammar as A ----
|
||||
import qualified GF.Devel.Grammar.Grammar as M ----
|
||||
import qualified GF.Devel.Grammar.Macros as GM
|
||||
--import qualified GF.Grammar.Compute as Compute
|
||||
|
||||
import GF.Devel.Grammar.PrGF
|
||||
--import GF.Devel.ModDeps
|
||||
import GF.Infra.Ident
|
||||
|
||||
import qualified GF.GFCC.Macros as CM
|
||||
import qualified GF.GFCC.AbsGFCC as C
|
||||
import qualified GF.GFCC.DataGFCC as D
|
||||
|
||||
import GF.Infra.Option ----
|
||||
import GF.Data.Operations
|
||||
import GF.Text.UTF8
|
||||
|
||||
import Data.List
|
||||
import Data.Char (isDigit,isSpace)
|
||||
import qualified Data.Map as Map
|
||||
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
|
||||
(abs,gc) = mkCanon2gfcc opts cnc gr
|
||||
|
||||
mkCanon2gfcc :: Options -> String -> GF -> (String,D.GFCC)
|
||||
mkCanon2gfcc opts cnc gr =
|
||||
(prIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon abs) gr)
|
||||
where
|
||||
abs = err error id $ Look.abstractOfConcrete gr (identC cnc)
|
||||
pars = mkParamLincat gr
|
||||
|
||||
-- Generate GFCC from GFCM.
|
||||
-- this assumes a grammar translated by canon2canon
|
||||
|
||||
canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> GF -> D.GFCC
|
||||
canon2gfcc opts pars cgr =
|
||||
(if (oElem (iOpt "show_canon") opts) then trace (prt cgr) else id) $
|
||||
D.GFCC an cns gflags abs cncs
|
||||
where
|
||||
-- recognize abstract and concretes
|
||||
[[(a,abm)],cms] =
|
||||
partition ((== MTAbstract) . mtype . snd) (Map.toList gfmodules cgr)
|
||||
|
||||
-- abstract
|
||||
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)]]
|
||||
where fg = "firstlang"
|
||||
aflags = Map.fromList [(C.CId f,x) | Opt (f,[x]) <- M.mflags abm]
|
||||
mkDef pty = case pty of
|
||||
Meta _ -> CM.primNotion
|
||||
t -> mkExp t
|
||||
|
||||
funs = Map.fromAscList lfuns
|
||||
cats = Map.fromAscList lcats
|
||||
|
||||
lfuns = [(i2i f, (mkType (jtype ju), mkDef (jdef ju))) |
|
||||
(f,ju) <- listJudgements abm, jform ju == JFun]
|
||||
lcats = [(i2i c, mkContext (GM.contextOfType (jtype ju))) |
|
||||
(c,ju) <- listJudgements abm, jform ju == JCat]
|
||||
catfuns = Map.fromList
|
||||
[(cat,[f | (f, (C.DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
|
||||
|
||||
-- concretes
|
||||
cncs = Map.fromList [mkConcr lang (i2i lang) mo | (lang,mo) <- cms]
|
||||
mkConcr lang0 lang mo =
|
||||
(lang,D.Concr flags lins opers lincats lindefs printnames params)
|
||||
where
|
||||
js = listJudgements mo
|
||||
flags = Map.fromList [(C.CId f,x) | Opt (f,[x]) <- M.mflags mo]
|
||||
opers = Map.fromAscList [] -- opers will be created as optimization
|
||||
utf = if elem (Opt ("coding",["utf8"])) (M.mflags mo)
|
||||
then D.convertStringsInTerm decodeUTF8 else id
|
||||
lins = Map.fromAscList
|
||||
[(i2i f, utf (mkTerm (jdef ju))) | (f,ju) <- js, jform ju == JLin]
|
||||
lincats = Map.fromAscList
|
||||
[(i2i c, utf (mkTerm (jtype ju))) | (c,ju) <- js, jform ju == JLincat]
|
||||
lindefs = Map.fromAscList
|
||||
[(i2i c, utf (mkTerm (jdef ju))) | (c,ju) <- js, jform ju == JLincat]
|
||||
printnames = Map.fromAscList
|
||||
[(i2i c, utf (mkTerm (jprintname ju))) |
|
||||
(c,ju) <- js, elem (jform ju) [JLincat,JLin]]
|
||||
params = Map.fromAscList
|
||||
[(i2i c, pars lang0 (jtype ju)) | (c,ju) <- js, jform ju == JLincat]
|
||||
|
||||
i2i :: Ident -> C.CId
|
||||
i2i = C.CId . prIdent
|
||||
|
||||
mkType :: A.Type -> C.Type
|
||||
mkType t = case GM.typeForm t of
|
||||
(hyps,(Q _ cat),args) -> C.DTyp (mkContext hyps) (i2i cat) (map mkExp args)
|
||||
|
||||
mkExp :: A.Term -> C.Exp
|
||||
mkExp t = case t of
|
||||
A.Eqs eqs -> C.EEq [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs]
|
||||
_ -> case GM.termForm t of
|
||||
Ok (xx,c,args) -> C.DTr [i2i x | x <- xx] (mkAt c) (map mkExp args)
|
||||
where
|
||||
mkAt c = case c of
|
||||
Q _ c -> C.AC $ i2i c
|
||||
QC _ c -> C.AC $ i2i c
|
||||
Vr x -> C.AV $ i2i x
|
||||
EInt i -> C.AI i
|
||||
EFloat f -> C.AF f
|
||||
K s -> C.AS s
|
||||
Meta i -> C.AM $ toInteger i
|
||||
_ -> C.AM 0
|
||||
mkPatt p = uncurry CM.tree $ case p of
|
||||
A.PP _ c ps -> (C.AC (i2i c), map mkPatt ps)
|
||||
A.PV x -> (C.AV (i2i x), [])
|
||||
A.PW -> (C.AV CM.wildCId, [])
|
||||
A.PInt i -> (C.AI i, [])
|
||||
|
||||
mkContext :: A.Context -> [C.Hypo]
|
||||
mkContext hyps = [C.Hyp (i2i x) (mkType ty) | (x,ty) <- hyps]
|
||||
|
||||
mkTerm :: Term -> C.Term
|
||||
mkTerm tr = case tr of
|
||||
Vr (IA (_,i)) -> C.V i
|
||||
Vr (IC s) | isDigit (last s) ->
|
||||
C.V (read (reverse (takeWhile (/='_') (reverse s))))
|
||||
---- from gf parser of gfc
|
||||
EInt i -> C.C $ fromInteger i
|
||||
R rs -> C.R [mkTerm t | (_, (_,t)) <- rs]
|
||||
P t l -> C.P (mkTerm t) (C.C (mkLab l))
|
||||
T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------
|
||||
V _ cs -> C.R [mkTerm t | t <- cs]
|
||||
S t p -> C.P (mkTerm t) (mkTerm p)
|
||||
C s t -> C.S $ concatMap flats [mkTerm x | x <- [s,t]]
|
||||
FV ts -> C.FV [mkTerm t | t <- ts]
|
||||
K s -> C.K (C.KS s)
|
||||
----- K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants
|
||||
Empty -> C.S []
|
||||
App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging
|
||||
Abs _ t -> mkTerm t ---- only on toplevel
|
||||
Alts (td,tvs) ->
|
||||
C.K (C.KP (strings td) [C.Var (strings u) (strings v) | (u,v) <- tvs])
|
||||
_ -> prtTrace tr $ C.S [C.K (C.KS (prt tr +++ "66662"))] ---- for debugging
|
||||
where
|
||||
mkLab (LIdent l) = case l of
|
||||
'_':ds -> (read ds) :: Int
|
||||
_ -> prtTrace tr $ 66663
|
||||
strings t = case t of
|
||||
K s -> [s]
|
||||
C u v -> strings u ++ strings v
|
||||
FV ss -> concatMap strings ss
|
||||
_ -> prtTrace tr $ ["66660"]
|
||||
flats t = case t of
|
||||
C.S ts -> concatMap flats ts
|
||||
_ -> [t]
|
||||
|
||||
-- encoding GFCC-internal lincats as terms
|
||||
mkCType :: Type -> C.Term
|
||||
mkCType t = case t of
|
||||
EInt i -> C.C $ fromInteger i
|
||||
RecType rs -> C.R [mkCType t | (_, t) <- rs]
|
||||
Table pt vt -> case pt of
|
||||
EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt
|
||||
RecType rs -> mkCType $ foldr Table vt (map snd rs)
|
||||
Sort "Str" -> C.S [] --- Str only
|
||||
App (Q (IC "Predef") (IC "Ints")) (EInt i) -> C.C $ fromInteger i
|
||||
_ -> error $ "mkCType " ++ show t
|
||||
|
||||
-- encoding showable lincats (as in source gf) as terms
|
||||
mkParamLincat :: GF -> Ident -> Ident -> C.Term
|
||||
mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
|
||||
typ <- Look.lookupLincat sgr lang cat
|
||||
mkPType typ
|
||||
where
|
||||
mkPType typ = case typ of
|
||||
RecType lts -> do
|
||||
ts <- mapM (mkPType . snd) lts
|
||||
return $ C.R [ C.P (kks $ prt_ l) t | ((l,_),t) <- zip lts ts]
|
||||
Table (RecType lts) v -> do
|
||||
ps <- mapM (mkPType . snd) lts
|
||||
v' <- mkPType v
|
||||
return $ foldr (\p v -> C.S [p,v]) v' ps
|
||||
Table p v -> do
|
||||
p' <- mkPType p
|
||||
v' <- mkPType v
|
||||
return $ C.S [p',v']
|
||||
Sort "Str" -> return $ C.S []
|
||||
_ -> return $
|
||||
C.FV $ map (kks . filter showable . prt_) $
|
||||
errVal [] $ Look.allParamValues sgr typ
|
||||
showable c = not (isSpace c) ---- || (c == ' ') -- to eliminate \n in records
|
||||
kks = C.K . C.KS
|
||||
|
||||
-- return just one module per language
|
||||
|
||||
reorder :: Ident -> GF -> GF
|
||||
reorder abs cg = emptyGF {
|
||||
gfabsname = abs,
|
||||
gfcncnames = Map.fromList (map fst cncs),
|
||||
gfmodules = Map.fromList ((abs,absm) : map mkCnc cncs)
|
||||
}
|
||||
where
|
||||
absm = emptyModule {
|
||||
mtype = MTAbstract,
|
||||
mflags = aflags,
|
||||
mjments = adefs
|
||||
}
|
||||
mkCnc (c,cnc) = (c,emptyModule {
|
||||
mtype = MTConcrete abs,
|
||||
mflags = fst cnc,
|
||||
mjments = snd cnc
|
||||
})
|
||||
|
||||
mos = gfmodules cg
|
||||
|
||||
adefs = Map.fromAscList $ sortIds $
|
||||
predefADefs ++ Look.allOrigJudgements cg abs
|
||||
predefADefs =
|
||||
[(IC c, absCat []) | c <- ["Float","Int","String"]]
|
||||
aflags = nubByFst $
|
||||
concat [M.mflags mo | (_,mo) <- mos, mtype mo == MTAbstract] ----too many
|
||||
|
||||
cncs = sortIds [(lang, concr lang) | lang <- Look.allConcretes cg abs]
|
||||
concr la = (nubByFst flags, sortIds (predefCDefs ++ jments)) where
|
||||
jments = Look.allOrigJudgements cg la
|
||||
flags = Look.lookupFlags cg la
|
||||
----concat [M.mflags mo |
|
||||
---- (i,mo) <- mos, M.isModCnc mo,
|
||||
---- Just r <- [lookup i (M.allExtendSpecs cg la)]]
|
||||
|
||||
predefCDefs = [(IC c, cncCat GM.defLinType) |
|
||||
---- lindef,printname
|
||||
c <- ["Float","Int","String"]]
|
||||
|
||||
sortIds = sortBy (\ (f,_) (g,_) -> compare f g)
|
||||
|
||||
nubByFst = nubBy (\ (f,_) (g,_) -> f == g)
|
||||
|
||||
|
||||
-- one grammar per language - needed for symtab generation
|
||||
repartition :: Ident -> GF -> [GF]
|
||||
repartition abs cg = [Look.partOfGrammar cg (lang,mo) |
|
||||
let mos = gfmodules cg,
|
||||
lang <- Look.allConcretes cg abs,
|
||||
let mo = errVal
|
||||
(error ("no module found for " ++ prt lang)) $ Look.lookupModule cg lang
|
||||
]
|
||||
|
||||
|
||||
-- translate tables and records to arrays, parameters and labels to indices
|
||||
|
||||
canon2canon :: Ident -> GF -> GF
|
||||
canon2canon abs =
|
||||
recollect . map cl2cl . repartition abs . purgeGrammar abs
|
||||
where
|
||||
recollect gfs = emptyGF {gfmodules = nubModules gfs}
|
||||
nubModules = Map.toList . nubByFst . concatMap (Map.fromList. gfmodules)
|
||||
|
||||
cl2cl = M.MGrammar . js2js . map (c2c p2p) . M.modules
|
||||
|
||||
js2js ms = map (c2c (j2j (M.MGrammar ms))) ms
|
||||
|
||||
c2c f2 (c,m) = case m of
|
||||
M.ModMod mo@(M.Module _ _ _ _ _ js) ->
|
||||
(c, M.ModMod $ M.replaceJudgements mo $ mapTree f2 js)
|
||||
_ -> (c,m)
|
||||
j2j cg (f,j) = case j of
|
||||
CncFun x (Yes tr) z -> (f,CncFun x (Yes (t2t tr)) z)
|
||||
CncCat (Yes ty) (Yes x) y -> (f,CncCat (Yes (ty2ty ty)) (Yes (t2t x)) y)
|
||||
_ -> (f,j)
|
||||
where
|
||||
t2t = term2term cg pv
|
||||
ty2ty = type2type cg pv
|
||||
pv@(labels,untyps,typs) = paramValues cg ---trs $ paramValues cg
|
||||
|
||||
-- flatten record arguments of param constructors
|
||||
p2p (f,j) = case j of
|
||||
ResParam (Yes (ps,v)) ->
|
||||
(f,ResParam (Yes ([(c,concatMap unRec cont) | (c,cont) <- ps],Nothing)))
|
||||
_ -> (f,j)
|
||||
unRec (x,ty) = case ty of
|
||||
RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (identW,typ)]
|
||||
_ -> [(x,ty)]
|
||||
|
||||
----
|
||||
trs v = trace (tr v) v
|
||||
|
||||
tr (labels,untyps,typs) =
|
||||
("labels:" ++++
|
||||
unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i |
|
||||
((c,l),i) <- Map.toList labels]) ++
|
||||
("untyps:" ++++ unlines [A.prt t +++ "=" +++ show i |
|
||||
(t,i) <- Map.toList untyps]) ++
|
||||
("typs:" ++++ unlines [A.prt t |
|
||||
(t,_) <- Map.toList typs])
|
||||
----
|
||||
|
||||
purgeGrammar :: Ident -> GF -> GF
|
||||
purgeGrammar abstr gr =
|
||||
(M.MGrammar . map unopt . filter complete . purge . M.modules) gr
|
||||
where
|
||||
purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
|
||||
needed = nub $ concatMap (requiredCanModules isSingle gr) acncs
|
||||
acncs = abstr : M.allConcretes gr abstr
|
||||
isSingle = True
|
||||
complete (i,M.ModMod m) = M.isCompleteModule m --- not . isIncompleteCanon
|
||||
unopt = unshareModule gr -- subexp elim undone when compiled
|
||||
|
||||
type ParamEnv =
|
||||
(Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels
|
||||
Map.Map Term Integer, -- untyped terms to values
|
||||
Map.Map Type (Map.Map Term Integer)) -- types to their terms to values
|
||||
|
||||
--- gathers those param types that are actually used in lincats and lin terms
|
||||
paramValues :: GF -> ParamEnv
|
||||
paramValues cgr = (labels,untyps,typs) where
|
||||
partyps = nub $ [ty |
|
||||
(_,(_,CncCat (Yes (RecType ls)) _ _)) <- jments,
|
||||
ty0 <- [ty | (_, ty) <- unlockTyp ls],
|
||||
ty <- typsFrom ty0
|
||||
] ++ [
|
||||
Q m ty |
|
||||
(m,(ty,ResParam _)) <- jments
|
||||
] ++ [ty |
|
||||
(_,(_,CncFun _ (Yes tr) _)) <- jments,
|
||||
ty <- err (const []) snd $ appSTM (typsFromTrm tr) []
|
||||
]
|
||||
params = [(ty, errVal [] $ Look.allParamValues cgr ty) | ty <- partyps]
|
||||
typsFrom ty = case ty of
|
||||
Table p t -> typsFrom p ++ typsFrom t
|
||||
RecType ls -> RecType (sort (unlockTyp ls)) : concat [typsFrom t | (_, t) <- ls]
|
||||
_ -> [ty]
|
||||
|
||||
typsFromTrm :: Term -> STM [Type] Term
|
||||
typsFromTrm tr = case tr of
|
||||
R fs -> mapM_ (typsFromField . snd) fs >> return tr
|
||||
where
|
||||
typsFromField (mty, t) = case mty of
|
||||
Just x -> updateSTM (x:) >> typsFromTrm t
|
||||
_ -> typsFromTrm t
|
||||
V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr
|
||||
T (TTyped ty) cs ->
|
||||
updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
|
||||
T (TComp ty) cs ->
|
||||
updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
|
||||
_ -> GM.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,[(LIdent "s",GM.typeStr)]) | cat <- ["Int", "Float", "String"]] ++
|
||||
reverse ---- TODO: really those lincats that are reached
|
||||
---- reverse is enough to expel overshadowed ones...
|
||||
[(cat,(unlockTyp ls)) | (_,(cat,CncCat (Yes (RecType ls)) _ _)) <- jments]
|
||||
labels = Map.fromList $ concat
|
||||
[((cat,[lab]),(typ,i)):
|
||||
[((cat,[lab,lab2]),(ty,j)) |
|
||||
rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]]
|
||||
|
|
||||
(cat,ls) <- lincats, ((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 :: GF -> ParamEnv -> Type -> Type
|
||||
type2type cgr env@(labels,untyps,typs) ty = case ty of
|
||||
RecType rs ->
|
||||
RecType [(mkLab i, t2t t) | (i,(l, t)) <- zip [0..] (unlockTyp rs)]
|
||||
Table pt vt -> Table (t2t pt) (t2t vt)
|
||||
QC _ _ -> look ty
|
||||
_ -> ty
|
||||
where
|
||||
t2t = type2type cgr env
|
||||
look ty = EInt $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of
|
||||
Just vs -> length $ Map.assocs vs
|
||||
_ -> trace ("unknown partype " ++ show ty) 66669
|
||||
|
||||
term2term :: GF -> ParamEnv -> Term -> Term
|
||||
term2term cgr env@(labels,untyps,typs) tr = case tr of
|
||||
App _ _ -> mkValCase (unrec tr)
|
||||
QC _ _ -> mkValCase tr
|
||||
R rs -> R [(mkLab i, (Nothing, t2t t)) |
|
||||
(i,(l,(_,t))) <- zip [0..] (sort (unlock rs))]
|
||||
P t l -> r2r tr
|
||||
PI t l i -> EInt $ toInteger i
|
||||
T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
|
||||
T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
|
||||
V ty ts -> mkCurry $ V ty [t2t t | t <- ts]
|
||||
S t p -> mkCurrySel (t2t t) (t2t p)
|
||||
_ -> GM.composSafeOp t2t tr
|
||||
where
|
||||
t2t = term2term cgr env
|
||||
|
||||
unrec t = case t of
|
||||
App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs]
|
||||
_ -> GM.composSafeOp unrec t
|
||||
|
||||
mkValCase tr = case appSTM (doVar tr) [] of
|
||||
Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st
|
||||
_ -> valNum $ comp tr
|
||||
|
||||
--- this is mainly needed for parameter record projections
|
||||
---- was: errVal t $ Compute.computeConcreteRec cgr t
|
||||
comp t = case t of
|
||||
T (TComp typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should...
|
||||
T (TTyped typ) ts -> comp $ V typ (map (comp . snd) ts) ---- should
|
||||
V typ ts -> V typ (map comp ts)
|
||||
S (V typ ts) v0 -> err error id $ do
|
||||
let v = comp v0
|
||||
return $ maybe t (comp . (ts !!) . fromInteger) $ Map.lookup v untyps
|
||||
R r -> R [(l,(ty,comp t)) | (l,(ty,t)) <- r]
|
||||
P (R r) l -> maybe t (comp . snd) $ lookup l r
|
||||
_ -> GM.composSafeOp comp t
|
||||
|
||||
doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term
|
||||
doVar tr = case getLab tr of
|
||||
Ok (cat, lab) -> do
|
||||
k <- readSTM >>= return . length
|
||||
let tr' = Vr $ 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'
|
||||
_ -> GM.composOp doVar tr
|
||||
|
||||
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 ((A.prt tr +++ prtTrace tr "66665"))
|
||||
|
||||
-- this goes recursively into tables (ignored) and records (accumulated)
|
||||
getLab tr = case tr of
|
||||
Vr (IA (cat, _)) -> return (identC cat,[])
|
||||
Vr (IC s) -> return (identC cat,[]) where
|
||||
cat = init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser
|
||||
---- Vr _ -> error $ "getLab " ++ show tr
|
||||
P p lab2 -> do
|
||||
(cat,labs) <- getLab p
|
||||
return (cat,labs++[lab2])
|
||||
S p _ -> getLab p
|
||||
_ -> Bad "getLab"
|
||||
|
||||
|
||||
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
|
||||
_ -> GM.composSafeOp (mkBranch x t) tr
|
||||
|
||||
valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps
|
||||
where
|
||||
tryFV tr = case GM.appForm tr of
|
||||
(c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryFV ts)]
|
||||
(FV ts,_) -> ts
|
||||
_ -> [tr]
|
||||
valNumFV ts = case ts of
|
||||
[tr] -> trace (unwords (map prt (Map.keys typs))) $
|
||||
prtTrace tr $ K "66667"
|
||||
_ -> FV $ map valNum ts
|
||||
|
||||
mkCurry trm = case trm of
|
||||
V (RecType [(_,ty)]) ts -> V ty ts
|
||||
V (RecType ((_,ty):ltys)) ts ->
|
||||
V ty [mkCurry (V (RecType ltys) cs) |
|
||||
cs <- chop (product (map (lengthtyp . snd) ltys)) ts]
|
||||
_ -> trm
|
||||
lengthtyp ty = case Map.lookup ty typs of
|
||||
Just m -> length (Map.assocs m)
|
||||
_ -> error $ "length of type " ++ show ty
|
||||
chop i xs = case splitAt i xs of
|
||||
(xs1,[]) -> [xs1]
|
||||
(xs1,xs2) -> xs1:chop i xs2
|
||||
|
||||
|
||||
mkCurrySel t p = S t p -- done properly in CheckGFCC
|
||||
|
||||
|
||||
mkLab k = LIdent (("_" ++ show k))
|
||||
|
||||
-- remove lock fields; in fact, any empty records and record types
|
||||
unlock = filter notlock where
|
||||
notlock (l,(_, t)) = case t of --- need not look at l
|
||||
R [] -> False
|
||||
_ -> True
|
||||
unlockTyp = filter notlock where
|
||||
notlock (l, t) = case t of --- need not look at l
|
||||
RecType [] -> False
|
||||
_ -> True
|
||||
|
||||
prtTrace tr n =
|
||||
trace ("-- INTERNAL COMPILER ERROR" +++ A.prt tr ++++ show n) n
|
||||
prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n
|
||||
|
||||
@@ -80,6 +80,11 @@ lookupParamValues gf m c = do
|
||||
vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gf ty) co
|
||||
return $ lmap (mkApp (QC m f)) vs
|
||||
|
||||
lookupFlags :: GF -> Ident -> [(Ident,String)]
|
||||
lookupFlags gf m = errVal [] $ do
|
||||
mo <- lookupModule gf m
|
||||
return $ toList $ mflags mo
|
||||
|
||||
allParamValues :: GF -> Type -> Err [Term]
|
||||
allParamValues cnc ptyp = case ptyp of
|
||||
App (Q (IC "Predef") (IC "Ints")) (EInt n) ->
|
||||
@@ -96,6 +101,47 @@ allParamValues cnc ptyp = case ptyp of
|
||||
-- to normalize records and record types
|
||||
sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
|
||||
|
||||
abstractOfConcrete :: GF -> Ident -> Err Ident
|
||||
abstractOfConcrete gf m = do
|
||||
mo <- lookupModule gf m
|
||||
case mtype mo of
|
||||
MTConcrete a -> return a
|
||||
MTInstance a -> return a
|
||||
MTGrammar -> return m
|
||||
_ -> prtBad "not concrete module" m
|
||||
|
||||
allOrigJudgements :: GF -> Ident -> [(Ident,Judgement)]
|
||||
allOrigJudgements gf m = errVal [] $ do
|
||||
mo <- lookupModule gf m
|
||||
return [ju | ju@(_,j) <- listJudgements mo, jform j /= JLink]
|
||||
|
||||
allConcretes :: GF -> Ident -> [Ident]
|
||||
allConcretes gf m =
|
||||
[c | (c,mo) <- toList (gfmodules gf), mtype mo == MTConcrete m]
|
||||
|
||||
-- | select just those modules that a given one depends on, including itself
|
||||
partOfGrammar :: GF -> (Ident,Module) -> GF
|
||||
partOfGrammar gr (i,mo) = gr {
|
||||
gfmodules = fromList [m | m@(j,_) <- mos, elem j modsFor]
|
||||
}
|
||||
where
|
||||
mos = toList $ gfmodules gr
|
||||
modsFor = i : allDepsModule gr mo
|
||||
|
||||
allDepsModule :: GF -> Module -> [Ident]
|
||||
allDepsModule gr m = iterFix add os0 where
|
||||
os0 = depPathModule m
|
||||
add os = [m | o <- os, Just n <- [llookup o mods], m <- depPathModule n]
|
||||
mods = toList $ gfmodules gr
|
||||
|
||||
-- | initial dependency list
|
||||
depPathModule :: Module -> [Ident]
|
||||
depPathModule mo = fors ++ lmap fst (mextends mo) ++ lmap snd (mopens mo) where
|
||||
fors = case mtype mo of
|
||||
MTConcrete i -> [i]
|
||||
MTInstance i -> [i]
|
||||
_ -> []
|
||||
|
||||
-- infrastructure for lookup
|
||||
|
||||
lookupModule :: GF -> Ident -> Err Module
|
||||
@@ -121,4 +167,5 @@ mlookup = Data.Map.lookup
|
||||
raiseIdent msg i = raise (msg +++ prIdent i)
|
||||
|
||||
lmap = Prelude.map
|
||||
llookup = Prelude.lookup
|
||||
|
||||
|
||||
Reference in New Issue
Block a user