forked from GitHub/gf-core
cannonical export now may contain some resource modules with parameters
This commit is contained in:
Krasimir Angelov
@@ -1,18 +1,18 @@
|
||||
-- | Translate grammars to Canonical form
|
||||
-- (a common intermediate representation to simplify export to other formats)
|
||||
module GF.Compile.GrammarToCanonical(
|
||||
grammar2canonical,abstract2canonical,concretes2canonical,
|
||||
grammar2canonical
|
||||
) where
|
||||
|
||||
import GF.Data.ErrM
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar
|
||||
import GF.Grammar.Lookup(allOrigInfos,lookupOrigInfo)
|
||||
import GF.Infra.Option(Options,noOptions)
|
||||
import GF.Infra.CheckM
|
||||
import GF.Compile.Compute.Concrete2
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Data.Maybe(mapMaybe)
|
||||
import Data.Maybe(mapMaybe,fromMaybe)
|
||||
import Control.Monad (forM)
|
||||
|
||||
-- | Generate Canonical code for the named abstract syntax and all associated
|
||||
@@ -43,33 +43,62 @@ abstract2canonical absname gr = do
|
||||
-- | Generate Canonical code for the all concrete syntaxes associated with
|
||||
-- the named abstract syntax in given the grammar.
|
||||
concretes2canonical :: Options -> ModuleName -> Grammar -> Check [Module]
|
||||
concretes2canonical opts absname gr =
|
||||
sequence
|
||||
[concrete2canonical gr absname cnc modinfo
|
||||
| cnc<-allConcretes gr absname,
|
||||
let Ok modinfo = lookupModule gr cnc
|
||||
]
|
||||
concretes2canonical opts absname gr = do
|
||||
res <- sequence
|
||||
[concrete2canonical gr absname cnc modinfo
|
||||
| cnc<-allConcretes gr absname,
|
||||
let Ok modinfo = lookupModule gr cnc]
|
||||
let pts = Set.unions (map fst res)
|
||||
ms <- closure pts (Set.toList pts) (Map.fromList (map snd res))
|
||||
return (Map.toList ms)
|
||||
where
|
||||
closure pts [] ms = return ms
|
||||
closure pts (q@(m,id):qs) ms = do
|
||||
(_,info@(ResParam (Just (L _ ps)) _)) <- lookupOrigInfo gr q
|
||||
let pts' = Set.unions [paramTypes ty | (_,ctx) <- ps, (_,_,ty) <- ctx]
|
||||
new_pts = Set.difference pts' pts
|
||||
closure (Set.union new_pts pts) (Set.toList new_pts++qs) (insert q info ms)
|
||||
|
||||
insert (m,id) info ms =
|
||||
let mi0 = fromMaybe emptyRes (Map.lookup m ms)
|
||||
mi = mi0{jments=Map.insert id info (jments mi0)}
|
||||
in Map.insert m mi ms
|
||||
|
||||
emptyRes =
|
||||
ModInfo {
|
||||
mtype = MTResource,
|
||||
mstatus = MSComplete,
|
||||
mflags = noOptions,
|
||||
mextend = [],
|
||||
mwith = Nothing,
|
||||
mopens = [],
|
||||
mexdeps = [],
|
||||
msrc = "",
|
||||
mseqs = Nothing,
|
||||
jments = Map.empty
|
||||
}
|
||||
|
||||
type QSet = Set.Set (ModuleName,Ident)
|
||||
|
||||
-- | Generate Canonical GF for the given concrete module.
|
||||
concrete2canonical :: Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Check Module
|
||||
concrete2canonical :: Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Check (QSet,Module)
|
||||
concrete2canonical gr absname cncname modinfo = do
|
||||
let g = Gl gr (stdPredef g)
|
||||
infos <- mapM (convInfo g) (allOrigInfos gr cncname)
|
||||
let pts = Set.unions (map fst infos)
|
||||
pts <- closure pts (Set.toList pts)
|
||||
return (cncname, ModInfo {
|
||||
mtype = MTConcrete absname,
|
||||
mstatus = MSComplete,
|
||||
mflags = convFlags gr cncname,
|
||||
mextend = [],
|
||||
mwith = Nothing,
|
||||
mopens = [],
|
||||
mexdeps = [],
|
||||
msrc = "",
|
||||
mseqs = Nothing,
|
||||
jments = Map.union (Map.fromList (mapMaybe snd infos))
|
||||
pts
|
||||
})
|
||||
return (pts,
|
||||
(cncname, ModInfo {
|
||||
mtype = MTConcrete absname,
|
||||
mstatus = MSComplete,
|
||||
mflags = convFlags gr cncname,
|
||||
mextend = [],
|
||||
mwith = Nothing,
|
||||
mopens = [],
|
||||
mexdeps = [],
|
||||
msrc = "",
|
||||
mseqs = Nothing,
|
||||
jments = Map.fromList (mapMaybe snd infos)
|
||||
}))
|
||||
where
|
||||
convInfo g ((mn,id), CncCat (Just (L loc typ)) lindef linref pprn mb_prods) = do
|
||||
typ <- normalForm g typ
|
||||
@@ -84,22 +113,16 @@ concrete2canonical gr absname cncname modinfo = do
|
||||
eta_expand t ((Implicit,x,_):ctx) = Abs Implicit x (eta_expand (App t (ImplArg (Vr x))) ctx)
|
||||
eta_expand t ((Explicit,x,_):ctx) = Abs Explicit x (eta_expand (App t (Vr x)) ctx)
|
||||
|
||||
paramTypes (RecType fs) = Set.unions (map (paramTypes.snd) fs)
|
||||
paramTypes (Table t1 t2) = Set.union (paramTypes t1) (paramTypes t2)
|
||||
paramTypes (App tf ta) = Set.union (paramTypes tf) (paramTypes ta)
|
||||
paramTypes (Sort _) = Set.empty
|
||||
paramTypes (EInt _) = Set.empty
|
||||
paramTypes (QC q) = Set.singleton q
|
||||
paramTypes (FV ts) = Set.unions (map paramTypes ts)
|
||||
paramTypes _ = Set.empty
|
||||
|
||||
closure pts [] = return Map.empty
|
||||
closure pts (q@(_,id):qs) = do
|
||||
(_,info@(ResParam (Just (L _ ps)) _)) <- lookupOrigInfo gr q
|
||||
let pts' = Set.unions [paramTypes ty | (_,ctx) <- ps, (_,_,ty) <- ctx]
|
||||
new_pts = Set.difference pts' pts
|
||||
infos <- closure (Set.union new_pts pts) (Set.toList new_pts++qs)
|
||||
return (Map.insert id info infos)
|
||||
paramTypes (RecType fs) = Set.unions (map (paramTypes.snd) fs)
|
||||
paramTypes (Table t1 t2) = Set.union (paramTypes t1) (paramTypes t2)
|
||||
paramTypes (App tf ta) = Set.union (paramTypes tf) (paramTypes ta)
|
||||
paramTypes (Sort _) = Set.empty
|
||||
paramTypes (EInt _) = Set.empty
|
||||
paramTypes (QC q) = Set.singleton q
|
||||
paramTypes (FV ts) = Set.unions (map paramTypes ts)
|
||||
paramTypes _ = Set.empty
|
||||
|
||||
|
||||
convFlags :: Grammar -> ModuleName -> Options
|
||||
convFlags gr mn = err (const noOptions) mflags (lookupModule gr mn)
|
||||
|
||||
@@ -296,7 +296,7 @@ runRepl opts@ReplOpts { noPrelude, inputFiles } = do
|
||||
(g0, opens) <- case toLoad of
|
||||
[] -> pure (mGrammar [], [])
|
||||
_ -> do
|
||||
(_, (_, g0)) <- batchCompile noOptions Nothing toLoad
|
||||
(_, g0) <- batchCompile noOptions Nothing toLoad
|
||||
pure (g0, OSimple . moduleNameS . justModuleName <$> toLoad)
|
||||
let
|
||||
modInfo = ModInfo
|
||||
|
||||
Reference in New Issue
Block a user