forked from GitHub/gf-core
fe15aa0c00
Still contains some hardcoded values, missing cases. I notice now that LPGF and Canonical GF are almost identical, so maybe we don't need a new LPGF format, just a linearization-only runtime which works on canonical grammars. The argument for keeping LGPF is that it would be optimized for size and speed.
391 lines
13 KiB
Haskell
391 lines
13 KiB
Haskell
-- | Translate grammars to Canonical form
|
|
-- (a common intermediate representation to simplify export to other formats)
|
|
module GF.Compile.GrammarToCanonical(
|
|
grammar2canonical,abstract2canonical,concretes2canonical,
|
|
projection,selection
|
|
) where
|
|
import Data.List(nub,partition)
|
|
import qualified Data.Map as M
|
|
import qualified Data.Set as S
|
|
import GF.Data.ErrM
|
|
import GF.Text.Pretty
|
|
import GF.Grammar.Grammar
|
|
import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
|
|
import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt)
|
|
import GF.Grammar.Lockfield(isLockLabel)
|
|
import GF.Grammar.Predef(cPredef,cInts)
|
|
import GF.Compile.Compute.Predef(predef)
|
|
import GF.Compile.Compute.Value(Predefined(..))
|
|
import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent)
|
|
import GF.Infra.Option(Options, optionsPGF)
|
|
import PGF.Internal(Literal(..))
|
|
import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
|
|
import GF.Grammar.Canonical as C
|
|
import Debug.Trace
|
|
|
|
-- | Generate Canonical code for the named abstract syntax and all associated
|
|
-- concrete syntaxes
|
|
grammar2canonical :: Options -> ModuleName -> SourceGrammar -> C.Grammar
|
|
grammar2canonical opts absname gr =
|
|
Grammar (abstract2canonical absname gr)
|
|
(map snd (concretes2canonical opts absname gr))
|
|
|
|
-- | Generate Canonical code for the named abstract syntax
|
|
abstract2canonical absname gr =
|
|
Abstract (modId absname) (convFlags gr absname) cats funs
|
|
where
|
|
cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs]
|
|
|
|
funs = [FunDef (gId f) (convType ty) |
|
|
((_,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs]
|
|
|
|
adefs = allOrigInfos gr absname
|
|
|
|
convCtx = maybe [] (map convHypo . unLoc)
|
|
convHypo (bt,name,t) =
|
|
case typeForm t of
|
|
([],(_,cat),[]) -> gId cat -- !!
|
|
|
|
convType t =
|
|
case typeForm t of
|
|
(hyps,(_,cat),args) -> Type bs (TypeApp (gId cat) as)
|
|
where
|
|
bs = map convHypo' hyps
|
|
as = map convType args
|
|
|
|
convHypo' (bt,name,t) = TypeBinding (gId name) (convType t)
|
|
|
|
|
|
-- | Generate Canonical code for the all concrete syntaxes associated with
|
|
-- the named abstract syntax in given the grammar.
|
|
concretes2canonical opts absname gr =
|
|
[(cncname,concrete2canonical gr cenv absname cnc cncmod)
|
|
| let cenv = resourceValues opts gr,
|
|
cnc<-allConcretes gr absname,
|
|
let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath
|
|
Ok cncmod = lookupModule gr cnc
|
|
]
|
|
|
|
-- | Generate Canonical GF for the given concrete module.
|
|
concrete2canonical gr cenv absname cnc modinfo =
|
|
Concrete (modId cnc) (modId absname) (convFlags gr cnc)
|
|
(neededParamTypes S.empty (params defs))
|
|
[lincat|(_,Left lincat)<-defs]
|
|
[lin|(_,Right lin)<-defs]
|
|
where
|
|
defs = concatMap (toCanonical gr absname cenv) .
|
|
M.toList $
|
|
jments modinfo
|
|
|
|
params = S.toList . S.unions . map fst
|
|
|
|
neededParamTypes have [] = []
|
|
neededParamTypes have (q:qs) =
|
|
if q `S.member` have
|
|
then neededParamTypes have qs
|
|
else let ((got,need),def) = paramType gr q
|
|
in def++neededParamTypes (S.union got have) (S.toList need++qs)
|
|
|
|
toCanonical gr absname cenv (name,jment) =
|
|
case jment of
|
|
CncCat (Just (L loc typ)) _ _ pprn _ ->
|
|
[(pts,Left (LincatDef (gId name) (convType ntyp)))]
|
|
where
|
|
pts = paramTypes gr ntyp
|
|
ntyp = nf loc typ
|
|
CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ ->
|
|
[(tts,Right (LinDef (gId name) (map gId args) (convert gr e')))]
|
|
where
|
|
tts = tableTypes gr [e']
|
|
|
|
e' = unAbs (length params) $
|
|
nf loc (mkAbs params (mkApp def (map Vr args)))
|
|
params = [(b,x)|(b,x,_)<-ctx]
|
|
args = map snd params
|
|
|
|
AnyInd _ m -> case lookupOrigInfo gr (m,name) of
|
|
Ok (m,jment) -> toCanonical gr absname cenv (name,jment)
|
|
_ -> []
|
|
_ -> []
|
|
where
|
|
nf loc = normalForm cenv (L loc name)
|
|
-- aId n = prefixIdent "A." (gId n)
|
|
|
|
unAbs 0 t = t
|
|
unAbs n (Abs _ _ t) = unAbs (n-1) t
|
|
unAbs _ t = t
|
|
|
|
tableTypes gr ts = S.unions (map tabtys ts)
|
|
where
|
|
tabtys t =
|
|
case t of
|
|
V t cc -> S.union (paramTypes gr t) (tableTypes gr cc)
|
|
T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
|
|
_ -> collectOp tabtys t
|
|
|
|
paramTypes gr t =
|
|
case t of
|
|
RecType fs -> S.unions (map (paramTypes gr.snd) fs)
|
|
Table t1 t2 -> S.union (paramTypes gr t1) (paramTypes gr t2)
|
|
App tf ta -> S.union (paramTypes gr tf) (paramTypes gr ta)
|
|
Sort _ -> S.empty
|
|
EInt _ -> S.empty
|
|
Q q -> lookup q
|
|
QC q -> lookup q
|
|
FV ts -> S.unions (map (paramTypes gr) ts)
|
|
_ -> ignore
|
|
where
|
|
lookup q = case lookupOrigInfo gr q of
|
|
Ok (_,ResOper _ (Just (L _ t))) ->
|
|
S.insert q (paramTypes gr t)
|
|
Ok (_,ResParam {}) -> S.singleton q
|
|
_ -> ignore
|
|
|
|
ignore = trace ("Ignore: "++show t) S.empty
|
|
|
|
|
|
convert gr = convert' gr []
|
|
|
|
convert' gr vs = ppT
|
|
where
|
|
ppT0 = convert' gr vs
|
|
ppTv vs' = convert' gr vs'
|
|
|
|
ppT t =
|
|
case t of
|
|
-- Abs b x t -> ...
|
|
-- V ty ts -> VTableValue (convType ty) (map ppT ts)
|
|
V ty ts -> TableValue (convType ty) [TableRow (ppP p) (ppT t)|(p,t)<-zip ps ts]
|
|
where
|
|
Ok pts = allParamValues gr ty
|
|
Ok ps = mapM term2patt pts
|
|
T (TTyped ty) cs -> TableValue (convType ty) (map ppCase cs)
|
|
S t p -> selection (ppT t) (ppT p)
|
|
C t1 t2 -> concatValue (ppT t1) (ppT t2)
|
|
App f a -> ap (ppT f) (ppT a)
|
|
R r -> RecordValue (fields r)
|
|
P t l -> projection (ppT t) (lblId l)
|
|
Vr x -> VarValue (gId x)
|
|
Cn x -> VarValue (gId x) -- hmm
|
|
Con c -> ParamConstant (Param (gId c) [])
|
|
Sort k -> VarValue (gId k)
|
|
EInt n -> LiteralValue (IntConstant n)
|
|
Q (m,n) -> if m==cPredef then ppPredef n else VarValue ((gQId m n))
|
|
QC (m,n) -> ParamConstant (Param ((gQId m n)) [])
|
|
K s -> LiteralValue (StrConstant s)
|
|
Empty -> LiteralValue (StrConstant "")
|
|
FV ts -> VariantValue (map ppT ts)
|
|
Alts t' vs -> alts vs (ppT t')
|
|
_ -> error $ "convert' "++show t
|
|
|
|
ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
|
|
|
|
ppPredef n =
|
|
case predef n of
|
|
Ok BIND -> p "BIND"
|
|
Ok SOFT_BIND -> p "SOFT_BIND"
|
|
Ok SOFT_SPACE -> p "SOFT_SPACE"
|
|
Ok CAPIT -> p "CAPIT"
|
|
Ok ALL_CAPIT -> p "ALL_CAPIT"
|
|
_ -> VarValue (gQId cPredef n) -- hmm
|
|
where
|
|
p = PredefValue . PredefId
|
|
|
|
ppP p =
|
|
case p of
|
|
PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
|
|
PP (m,c) ps -> ParamPattern (Param ((gQId m c)) (map ppP ps))
|
|
PR r -> RecordPattern (fields r) {-
|
|
PW -> WildPattern
|
|
PV x -> VarP x
|
|
PString s -> Lit (show s) -- !!
|
|
PInt i -> Lit (show i)
|
|
PFloat x -> Lit (show x)
|
|
PT _ p -> ppP p
|
|
PAs x p -> AsP x (ppP p) -}
|
|
where
|
|
fields = map field . filter (not.isLockLabel.fst)
|
|
field (l,p) = RecordRow (lblId l) (ppP p)
|
|
|
|
-- patToParam p = case ppP p of ParamPattern pv -> pv
|
|
|
|
-- token s = single (c "TK" `Ap` lit s)
|
|
|
|
alts vs = PreValue (map alt vs)
|
|
where
|
|
alt (t,p) = (pre p,ppT0 t)
|
|
|
|
pre (K s) = [s]
|
|
pre Empty = [""] -- Empty == K ""
|
|
pre (Strs ts) = concatMap pre ts
|
|
pre (EPatt p) = pat p
|
|
pre t = error $ "pre "++show t
|
|
|
|
pat (PString s) = [s]
|
|
pat (PAlt p1 p2) = pat p1++pat p2
|
|
pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
|
|
pat p = error $ "pat "++show p
|
|
|
|
fields = map field . filter (not.isLockLabel.fst)
|
|
field (l,(_,t)) = RecordRow (lblId l) (ppT t)
|
|
--c = Const
|
|
--c = VarValue . VarValueId
|
|
--lit s = c (show s) -- hmm
|
|
|
|
ap f a = case f of
|
|
ParamConstant (Param p ps) ->
|
|
ParamConstant (Param p (ps++[a]))
|
|
_ -> error $ "convert' ap: "++render (ppA f <+> ppA a)
|
|
|
|
concatValue v1 v2 =
|
|
case (v1,v2) of
|
|
(LiteralValue (StrConstant ""),_) -> v2
|
|
(_,LiteralValue (StrConstant "")) -> v1
|
|
_ -> ConcatValue v1 v2
|
|
|
|
-- | Smart constructor for projections
|
|
projection r l = maybe (Projection r l) id (proj r l)
|
|
|
|
proj r l =
|
|
case r of
|
|
RecordValue r -> case [v|RecordRow l' v<-r,l'==l] of
|
|
[v] -> Just v
|
|
_ -> Nothing
|
|
_ -> Nothing
|
|
|
|
-- | Smart constructor for selections
|
|
selection t v =
|
|
-- Note: impossible cases can become possible after grammar transformation
|
|
case t of
|
|
TableValue tt r ->
|
|
case nub [rv|TableRow _ rv<-keep] of
|
|
[rv] -> rv
|
|
_ -> Selection (TableValue tt r') v
|
|
where
|
|
-- Don't introduce wildcard patterns, true to the canonical format,
|
|
-- annotate (or eliminate) rhs in impossible rows
|
|
r' = map trunc r
|
|
trunc r@(TableRow p e) = if mightMatchRow v r
|
|
then r
|
|
else TableRow p (impossible e)
|
|
{-
|
|
-- Creates smaller tables, but introduces wildcard patterns
|
|
r' = if null discard
|
|
then r
|
|
else keep++[TableRow WildPattern impossible]
|
|
-}
|
|
(keep,discard) = partition (mightMatchRow v) r
|
|
_ -> Selection t v
|
|
|
|
impossible = CommentedValue "impossible"
|
|
|
|
mightMatchRow v (TableRow p _) =
|
|
case p of
|
|
WildPattern -> True
|
|
_ -> mightMatch v p
|
|
|
|
mightMatch v p =
|
|
case v of
|
|
ConcatValue _ _ -> False
|
|
ParamConstant (Param c1 pvs) ->
|
|
case p of
|
|
ParamPattern (Param c2 pps) -> c1==c2 && length pvs==length pps &&
|
|
and [mightMatch v p|(v,p)<-zip pvs pps]
|
|
_ -> False
|
|
RecordValue rv ->
|
|
case p of
|
|
RecordPattern rp ->
|
|
and [maybe False (flip mightMatch p) (proj v l) | RecordRow l p<-rp]
|
|
_ -> False
|
|
_ -> True
|
|
|
|
patVars p =
|
|
case p of
|
|
PV x -> [x]
|
|
PAs x p -> x:patVars p
|
|
_ -> collectPattOp patVars p
|
|
|
|
convType = ppT
|
|
where
|
|
ppT t =
|
|
case t of
|
|
Table ti tv -> TableType (ppT ti) (ppT tv)
|
|
RecType rt -> RecordType (convFields rt)
|
|
-- App tf ta -> TAp (ppT tf) (ppT ta)
|
|
-- FV [] -> tcon0 (identS "({-empty variant-})")
|
|
Sort k -> convSort k
|
|
-- EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
|
|
FV (t:ts) -> ppT t -- !!
|
|
QC (m,n) -> ParamType (ParamTypeId ((gQId m n)))
|
|
Q (m,n) -> ParamType (ParamTypeId ((gQId m n)))
|
|
_ -> error $ "Missing case in convType for: "++show t
|
|
|
|
convFields = map convField . filter (not.isLockLabel.fst)
|
|
convField (l,r) = RecordRow (lblId l) (ppT r)
|
|
|
|
convSort k = case showIdent k of
|
|
"Float" -> FloatType
|
|
"Int" -> IntType
|
|
"Str" -> StrType
|
|
_ -> error ("convSort "++show k)
|
|
|
|
toParamType t = case convType t of
|
|
ParamType pt -> pt
|
|
_ -> error ("toParamType "++show t)
|
|
|
|
toParamId t = case toParamType t of
|
|
ParamTypeId p -> p
|
|
|
|
paramType gr q@(_,n) =
|
|
case lookupOrigInfo gr q of
|
|
Ok (m,ResParam (Just (L _ ps)) _)
|
|
{- - | m/=cPredef && m/=moduleNameS "Prelude"-} ->
|
|
((S.singleton (m,n),argTypes ps),
|
|
[ParamDef name (map (param m) ps)]
|
|
)
|
|
where name = (gQId m n)
|
|
Ok (m,ResOper _ (Just (L _ t)))
|
|
| m==cPredef && n==cInts ->
|
|
((S.empty,S.empty),[]) {-
|
|
((S.singleton (m,n),S.empty),
|
|
[Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
|
|
| otherwise ->
|
|
((S.singleton (m,n),paramTypes gr t),
|
|
[ParamAliasDef ((gQId m n)) (convType t)])
|
|
_ -> ((S.empty,S.empty),[])
|
|
where
|
|
param m (n,ctx) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx]
|
|
argTypes = S.unions . map argTypes1
|
|
argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
|
|
|
|
lblId = LabelId . render -- hmm
|
|
modId (MN m) = ModId (showIdent m)
|
|
|
|
class FromIdent i where gId :: Ident -> i
|
|
|
|
instance FromIdent VarId where
|
|
gId i = if isWildIdent i then Anonymous else VarId (showIdent i)
|
|
|
|
instance FromIdent C.FunId where gId = C.FunId . showIdent
|
|
instance FromIdent CatId where gId = CatId . showIdent
|
|
instance FromIdent ParamId where gId = ParamId . unqual
|
|
instance FromIdent VarValueId where gId = VarValueId . unqual
|
|
|
|
class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i
|
|
|
|
instance QualIdent ParamId where gQId m n = ParamId (qual m n)
|
|
instance QualIdent VarValueId where gQId m n = VarValueId (qual m n)
|
|
|
|
qual m n = Qual (modId m) (showIdent n)
|
|
unqual n = Unqual (showIdent n)
|
|
|
|
convFlags gr mn =
|
|
Flags [(n,convLit v) |
|
|
(n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
|
|
where
|
|
convLit l =
|
|
case l of
|
|
LStr s -> Str s
|
|
LInt i -> C.Int i
|
|
LFlt d -> Flt d
|