forked from GitHub/gf-core
129 lines
4.9 KiB
Haskell
129 lines
4.9 KiB
Haskell
-- | Translate grammars to Canonical form
|
|
-- (a common intermediate representation to simplify export to other formats)
|
|
module GF.Compile.GrammarToCanonical(
|
|
grammar2canonical
|
|
) where
|
|
|
|
import GF.Data.ErrM
|
|
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,fromMaybe)
|
|
import Control.Monad (forM)
|
|
|
|
-- | Generate Canonical code for the named abstract syntax and all associated
|
|
-- concrete syntaxes
|
|
grammar2canonical :: Options -> ModuleName -> Grammar -> Check Grammar
|
|
grammar2canonical opts absname gr = do
|
|
abs <- abstract2canonical absname gr
|
|
cncs <- concretes2canonical opts absname gr
|
|
return (mGrammar (abs:cncs))
|
|
|
|
-- | Generate Canonical code for the named abstract syntax
|
|
abstract2canonical :: ModuleName -> Grammar -> Check Module
|
|
abstract2canonical absname gr = do
|
|
let infos = [(id,info) | ((mn,id),info) <- allOrigInfos gr absname]
|
|
return (absname, ModInfo {
|
|
mtype = MTAbstract,
|
|
mstatus = MSComplete,
|
|
mflags = convFlags gr absname,
|
|
mextend = [],
|
|
mwith = Nothing,
|
|
mopens = [],
|
|
mexdeps = [],
|
|
msrc = "",
|
|
mseqs = Nothing,
|
|
jments = Map.fromList infos
|
|
})
|
|
|
|
-- | 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 = 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 (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)
|
|
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
|
|
let pts = paramTypes typ
|
|
return (pts,Just (id,CncCat (Just (L loc typ)) lindef linref pprn mb_prods))
|
|
convInfo g ((mn,id), CncFun mb_ty@(Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn mb_prods) = do
|
|
def <- normalForm g (eta_expand def ctx)
|
|
return (Set.empty,Just (id,CncFun mb_ty (Just (L loc def)) pprn mb_prods))
|
|
convInfo g _ = return (Set.empty,Nothing)
|
|
|
|
eta_expand t [] = t
|
|
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
|
|
|
|
|
|
convFlags :: Grammar -> ModuleName -> Options
|
|
convFlags gr mn = err (const noOptions) mflags (lookupModule gr mn)
|