GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-19 16:12:52 -06:00
Code Issues Packages Projects Releases Wiki Activity

working PMCFG generation

Browse Source
This commit is contained in:
krangelov
2021-10-13 19:14:56 +02:00
parent f9c6e94672
commit c3eb6973f4
16 changed files with 253 additions and 210 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
src/compiler/GF/Grammar/Analyse.hs
View File

@@ -29,7 +29,7 @@ stripInfo i = case i of
AbsCat _ -> i
AbsFun mt mi me mb -> AbsFun mt mi Nothing mb
ResParam mp mt -> ResParam mp Nothing
ResValue lt -> i ----
ResValue lt _ -> i ----
ResOper mt md -> ResOper mt Nothing
ResOverload is fs -> ResOverload is [(lty, L loc (EInt 0)) | (lty,L loc _) <- fs]
CncCat mty mte _ mtf mpmcfg -> CncCat mty Nothing Nothing Nothing Nothing
@@ -108,7 +108,7 @@ sizeInfo i = case i of
sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es]
ResParam mp mt ->
1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co) <- ps]
ResValue lt -> 0
ResValue _ _ -> 0
ResOper mt md -> 1 + msize mt + msize md
ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]
CncCat mty _ _ _ _ -> 1 + msize mty -- ignoring lindef, linref and printname

14
src/compiler/GF/Grammar/Binary.hs
View File

@@ -103,15 +103,19 @@ instance Binary Options where
toString (LInt n) = show n
toString (LFlt d) = show d
instance Binary PMCFG where
put (PMCFG lins) = put lins
get = fmap PMCFG get
instance Binary PMCFGCat where
put (PMCFGCat r rs) = put (r,rs)
get = get >>= \(r,rs) -> return (PMCFGCat r rs)
instance Binary PMCFGRule where
put (PMCFGRule res args rules) = put (res,args,rules)
get = get >>= \(res,args,rules) -> return (PMCFGRule res args rules)
instance Binary Info where
put (AbsCat x) = putWord8 0 >> put x
put (AbsFun w x y z) = putWord8 1 >> put (w,x,y,z)
put (ResParam x y) = putWord8 2 >> put (x,y)
put (ResValue x) = putWord8 3 >> put x
put (ResValue x y) = putWord8 3 >> put (x,y)
put (ResOper x y) = putWord8 4 >> put (x,y)
put (ResOverload x y)= putWord8 5 >> put (x,y)
put (CncCat v w x y z)=putWord8 6 >> put (v,w,x,y,z)
@@ -122,7 +126,7 @@ instance Binary Info where
0 -> get >>= \x -> return (AbsCat x)
1 -> get >>= \(w,x,y,z) -> return (AbsFun w x y z)
2 -> get >>= \(x,y) -> return (ResParam x y)
3 -> get >>= \x -> return (ResValue x)
3 -> get >>= \(x,y) -> return (ResValue x y)
4 -> get >>= \(x,y) -> return (ResOper x y)
5 -> get >>= \(x,y) -> return (ResOverload x y)
6 -> get >>= \(v,w,x,y,z)->return (CncCat v w x y z)

26
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -64,7 +64,7 @@ module GF.Grammar.Grammar (
Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
-- ** PMCFG
PMCFG(..)
PMCFGCat(..), PMCFGRule(..)
) where
import GF.Infra.Ident
@@ -74,7 +74,7 @@ import GF.Infra.Location
import GF.Data.Operations
import PGF2(BindType(..))
import PGF2.Transactions(Symbol,LIndex)
import PGF2.Transactions(Symbol,LIndex,LParam)
import Data.Array.IArray(Array)
import Data.Array.Unboxed(UArray)
@@ -304,8 +304,11 @@ allConcreteModules gr =
[i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
data PMCFG = PMCFG [[[Symbol]]]
deriving (Eq,Show)
data PMCFGCat = PMCFGCat LIndex [(LIndex,LParam)]
deriving (Eq,Show)
data PMCFGRule = PMCFGRule PMCFGCat [PMCFGCat] [[Symbol]]
deriving (Eq,Show)
-- | the constructors are judgements in
--
@@ -322,15 +325,18 @@ data Info =
| AbsFun (Maybe (L Type)) (Maybe Int) (Maybe [L Equation]) (Maybe Bool) -- ^ (/ABS/) type, arrity and definition of a function
-- judgements in resource
| ResParam (Maybe (L [Param])) (Maybe [Term]) -- ^ (/RES/) the second parameter is list of all possible values
| ResValue (L Type) -- ^ (/RES/) to mark parameter constructors for lookup
| ResOper (Maybe (L Type)) (Maybe (L Term)) -- ^ (/RES/)
| ResParam (Maybe (L [Param])) (Maybe ([Term],Int)) -- ^ (/RES/) The second argument is list of all possible values
-- and its precomputed length.
| ResValue (L Type) Int -- ^ (/RES/) to mark parameter constructors for lookup.
-- The second argument is the offset into the list of all values
-- where that constructor appears first.
| ResOper (Maybe (L Type)) (Maybe (L Term)) -- ^ (/RES/)
| ResOverload [ModuleName] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited
| ResOverload [ModuleName] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited
-- judgements in concrete syntax
| CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) lindef ini'zed,
| CncFun (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) type info added at 'TC'
| CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe [PMCFGRule]) -- ^ (/CNC/) lindef ini'zed,
| CncFun (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe [PMCFGRule]) -- ^ (/CNC/) type info added at 'TC'
-- indirection to module Ident
| AnyInd Bool ModuleName -- ^ (/INDIR/) the 'Bool' says if canonical

26
src/compiler/GF/Grammar/Lookup.hs
View File

@@ -78,12 +78,12 @@ lookupResDefLoc gr (m,c)
CncCat (Just (L l ty)) _ _ _ _ -> fmap (L l) (lock c ty)
CncCat _ _ _ _ _ -> fmap noLoc (lock c defLinType)
CncFun (Just (cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr)
CncFun _ (Just ltr) _ _ -> return ltr
CncFun (Just (_,cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr)
CncFun _ (Just ltr) _ _ -> return ltr
AnyInd _ n -> look n c
ResParam _ _ -> return (noLoc (QC (m,c)))
ResValue _ -> return (noLoc (QC (m,c)))
ResValue _ _ -> return (noLoc (QC (m,c)))
_ -> raise $ render (c <+> "is not defined in resource" <+> m)
lookupResType :: ErrorMonad m => Grammar -> QIdent -> m Type
@@ -94,12 +94,12 @@ lookupResType gr (m,c) = do
-- used in reused concrete
CncCat _ _ _ _ _ -> return typeType
CncFun (Just (cat,cont,val)) _ _ _ -> do
CncFun (Just (_,cat,cont,val)) _ _ _ -> do
val' <- lock cat val
return $ mkProd cont val' []
AnyInd _ n -> lookupResType gr (n,c)
ResParam _ _ -> return typePType
ResValue (L _ t) -> return t
ResParam _ _ -> return typePType
ResValue (L _ t) _ -> return t
_ -> raise $ render (c <+> "has no type defined in resource" <+> m)
lookupOverloadTypes :: ErrorMonad m => Grammar -> QIdent -> m [(Term,Type)]
@@ -110,11 +110,11 @@ lookupOverloadTypes gr id@(m,c) = do
-- used in reused concrete
CncCat _ _ _ _ _ -> ret typeType
CncFun (Just (cat,cont,val)) _ _ _ -> do
CncFun (Just (_,cat,cont,val)) _ _ _ -> do
val' <- lock cat val
ret $ mkProd cont val' []
ResParam _ _ -> ret typePType
ResValue (L _ t) -> ret t
ResParam _ _ -> ret typePType
ResValue (L _ t) _ -> ret t
ResOverload os tysts -> do
tss <- mapM (\x -> lookupOverloadTypes gr (x,c)) os
return $ [(tr,ty) | (L _ ty,L _ tr) <- tysts] ++
@@ -154,8 +154,8 @@ lookupParamValues :: ErrorMonad m => Grammar -> QIdent -> m [Term]
lookupParamValues gr c = do
(_,info) <- lookupOrigInfo gr c
case info of
ResParam _ (Just pvs) -> return pvs
_ -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
ResParam _ (Just (pvs,_)) -> return pvs
_ -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
allParamValues :: ErrorMonad m => Grammar -> Type -> m [Term]
allParamValues cnc ptyp =
@@ -226,9 +226,9 @@ allOpers gr =
typesIn info = case info of
AbsFun (Just ltyp) _ _ _ -> [ltyp]
ResOper (Just ltyp) _ -> [ltyp]
ResValue ltyp -> [ltyp]
ResValue ltyp _ -> [ltyp]
ResOverload _ tytrs -> [ltyp | (ltyp,_) <- tytrs]
CncFun (Just (i,ctx,typ)) _ _ _ ->
CncFun (Just (_,i,ctx,typ)) _ _ _ ->
[L NoLoc (mkProdSimple ctx (lock' i typ))]
_ -> []

4
src/compiler/GF/Grammar/Parser.y
View File

@@ -267,7 +267,7 @@ DataDef
ParamDef :: { [(Ident,Info)] }
ParamDef
: Posn LhsIdent '=' ListParConstr Posn { ($2, ResParam (Just (mkL $1 $5 [param | L loc param <- $4])) Nothing) :
[(f, ResValue (L loc (mkProdSimple co (Cn $2)))) | L loc (f,co) <- $4] }
[(f, ResValue (L loc (mkProdSimple co (Cn $2))) 0) | L loc (f,co) <- $4] }
| Posn LhsIdent Posn { [($2, ResParam Nothing Nothing)] }
OperDef :: { [(Ident,Info)] }
@@ -774,7 +774,7 @@ checkInfoType mt jment@(id,info) =
CncCat pty pd pr ppn _->ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh pr ++ locPerh ppn)
CncFun _ pd ppn _ -> ifConcrete mt (locPerh pd ++ locPerh ppn)
ResParam pparam _ -> ifResource mt (locPerh pparam)
ResValue ty -> ifResource mt (locL ty)
ResValue ty _ -> ifResource mt (locL ty)
ResOper pty pt -> ifOper mt pty pt
ResOverload _ xs -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
where

68
src/compiler/GF/Grammar/Printer.hs
View File

@@ -24,8 +24,8 @@ module GF.Grammar.Printer
) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import PGF2 as PGF2
import PGF2.Transactions as PGF2
import PGF2(Literal(..))
import PGF2.Transactions(LIndex,LParam,Symbol(..))
import GF.Infra.Ident
import GF.Infra.Option
import GF.Grammar.Values
@@ -108,10 +108,10 @@ ppJudgement q (id, ResParam pparams _) =
(case pparams of
Just (L _ ps) -> '=' <+> ppParams q ps
_ -> empty) <+> ';'
ppJudgement q (id, ResValue pvalue) =
ppJudgement q (id, ResValue pvalue idx) =
"-- param constructor" <+> id <+> ':' <+>
(case pvalue of
(L _ ty) -> ppTerm q 0 ty) <+> ';'
(L _ ty) -> ppTerm q 0 ty) <+> ';' <+> parens (pp "index = " <> pp idx)
ppJudgement q (id, ResOper ptype pexp) =
"oper" <+> id <+>
(case ptype of {Just (L _ t) -> ':' <+> ppTerm q 0 t; Nothing -> empty} $$
@@ -121,8 +121,8 @@ ppJudgement q (id, ResOverload ids defs) =
("overload" <+> '{' $$
nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$
'}') <+> ';'
ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
(case pcat of
ppJudgement q (id, CncCat mtyp pdef pref pprn mpmcfg) =
(case mtyp of
Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
Nothing -> empty) $$
(case pdef of
@@ -134,13 +134,13 @@ ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
(case pprn of
Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
Nothing -> empty) $$
(case (mpmcfg,q) of
(Just (PMCFG lins),Internal)
-> "pmcfg" <+> id <+> '=' <+> '{' $$
nest 2 (vcat (map ppPmcfgLin lins)) $$
(case (mtyp,mpmcfg,q) of
(Just (L _ typ),Just rules,Internal)
-> "pmcfg" <+> '{' $$
nest 2 (vcat (map (ppPmcfgRule id [] id) rules)) $$
'}'
_ -> empty)
ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) =
ppJudgement q (id, CncFun mtyp pdef pprn mpmcfg) =
(case pdef of
Just (L _ e) -> let (xs,e') = getAbs e
in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
@@ -148,10 +148,10 @@ ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) =
(case pprn of
Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
Nothing -> empty) $$
(case (mpmcfg,q) of
(Just (PMCFG lins),Internal)
-> "pmcfg" <+> id <+> '=' <+> '{' $$
nest 2 (vcat (map ppPmcfgLin lins)) $$
(case (mtyp,mpmcfg,q) of
(Just (args,res,_,_),Just rules,Internal)
-> "pmcfg" <+> '{' $$
nest 2 (vcat (map (ppPmcfgRule id args res) rules)) $$
'}'
_ -> empty)
ppJudgement q (id, AnyInd cann mid) =
@@ -159,8 +159,12 @@ ppJudgement q (id, AnyInd cann mid) =
Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
_ -> empty
ppPmcfgLin lin =
brackets (vcat (map (hsep . map ppSymbol) lin))
ppPmcfgRule id arg_cats res_cat (PMCFGRule res args lins) =
pp id <+> (':' <+> hsep (intersperse (pp '*') (zipWith ppPmcfgCat arg_cats args)) <+> "->" <+> ppPmcfgCat res_cat res $$
'=' <+> brackets (vcat (map (hsep . map ppSymbol) lins)))
ppPmcfgCat :: Ident -> PMCFGCat -> Doc
ppPmcfgCat cat (PMCFGCat r rs) = pp cat <> parens (ppLinFun ppLParam r rs)
instance Pretty Term where pp = ppTerm Unqualified 0
@@ -353,21 +357,21 @@ ppMeta n
| n == 0 = pp '?'
| otherwise = pp '?' <> pp n
ppLit (PGF2.LStr s) = pp (show s)
ppLit (PGF2.LInt n) = pp n
ppLit (PGF2.LFlt d) = pp d
ppLit (LStr s) = pp (show s)
ppLit (LInt n) = pp n
ppLit (LFlt d) = pp d
ppSymbol (PGF2.SymCat d r rs)= pp '<' <> pp d <> pp ',' <> ppLinFun ppIntVar r rs <> pp '>'
ppSymbol (PGF2.SymLit d r) = pp '{' <> pp d <> pp ',' <> pp r <> pp '}'
ppSymbol (PGF2.SymVar d r) = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>'
ppSymbol (PGF2.SymKS t) = doubleQuotes (pp t)
ppSymbol PGF2.SymNE = pp "nonExist"
ppSymbol PGF2.SymBIND = pp "BIND"
ppSymbol PGF2.SymSOFT_BIND = pp "SOFT_BIND"
ppSymbol PGF2.SymSOFT_SPACE = pp "SOFT_SPACE"
ppSymbol PGF2.SymCAPIT = pp "CAPIT"
ppSymbol PGF2.SymALL_CAPIT = pp "ALL_CAPIT"
ppSymbol (PGF2.SymKP syms alts) = pp "pre" <+> braces (hsep (punctuate (pp ';') (hsep (map ppSymbol syms) : map ppAlt alts)))
ppSymbol (SymCat d r rs)= pp '<' <> pp d <> pp ',' <> ppLinFun ppLParam r rs <> pp '>'
ppSymbol (SymLit d r) = pp '{' <> pp d <> pp ',' <> pp r <> pp '}'
ppSymbol (SymVar d r) = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>'
ppSymbol (SymKS t) = doubleQuotes (pp t)
ppSymbol SymNE = pp "nonExist"
ppSymbol SymBIND = pp "BIND"
ppSymbol SymSOFT_BIND = pp "SOFT_BIND"
ppSymbol SymSOFT_SPACE = pp "SOFT_SPACE"
ppSymbol SymCAPIT = pp "CAPIT"
ppSymbol SymALL_CAPIT = pp "ALL_CAPIT"
ppSymbol (SymKP syms alts) = pp "pre" <+> braces (hsep (punctuate (pp ';') (hsep (map ppSymbol syms) : map ppAlt alts)))
ppLinFun ppParam r rs
| r == 0 && not (null rs) = hcat (intersperse (pp '+') ( map ppTerm rs))
@@ -377,7 +381,7 @@ ppLinFun ppParam r rs
| i == 1 = ppParam p
| otherwise = pp i <> pp '*' <> ppParam p
ppIntVar p
ppLParam p
| i == 0 = pp (chars !! j)
| otherwise = pp (chars !! j : show i)
where