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

Unify the data model between the C runtime and the Haskell binding

Browse Source
This commit is contained in:
krangelov
2021-11-09 02:04:36 +01:00
parent b3ef14c39b
commit 6552bcf909
13 changed files with 118 additions and 140 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -103,13 +103,17 @@ instance Binary Options where
toString (LInt n) = show n
toString (LFlt d) = show d
instance Binary PMCFGCat where
put (PMCFGCat r rs) = put (r,rs)
get = get >>= \(r,rs) -> return (PMCFGCat r rs)
instance Binary LParam where
put (LParam r rs) = put (r,rs)
get = get >>= \(r,rs) -> return (LParam 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 PArg where
put (PArg x y) = put (x,y)
get = get >>= \(x,y) -> return (PArg x y)
instance Binary Production where
put (Production args res rules) = put (args,res,rules)
get = get >>= \(args,res,rules) -> return (Production args res rules)
instance Binary Info where
put (AbsCat x) = putWord8 0 >> put x
@@ -312,8 +316,8 @@ instance Binary Literal where
_ -> decodingError
instance Binary Symbol where
put (SymCat d r rs) = putWord8 0 >> put (d,r,rs)
put (SymLit n l) = putWord8 1 >> put (n,l)
put (SymCat d r) = putWord8 0 >> put (d,r)
put (SymLit d r) = putWord8 1 >> put (d,r)
put (SymVar n l) = putWord8 2 >> put (n,l)
put (SymKS ts) = putWord8 3 >> put ts
put (SymKP d vs) = putWord8 4 >> put (d,vs)
@@ -325,7 +329,7 @@ instance Binary Symbol where
put SymALL_CAPIT = putWord8 10
get = do tag <- getWord8
case tag of
0 -> liftM3 SymCat get get get
0 -> liftM2 SymCat get get
1 -> liftM2 SymLit get get
2 -> liftM2 SymVar get get
3 -> liftM SymKS get

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

@@ -64,7 +64,7 @@ module GF.Grammar.Grammar (
Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
-- ** PMCFG
PMCFGCat(..), PMCFGRule(..)
LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..)
) 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,LParam)
import PGF2.Transactions(LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..))
import Data.Array.IArray(Array)
import Data.Array.Unboxed(UArray)
@@ -304,12 +304,6 @@ allConcreteModules gr =
[i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
data PMCFGCat = PMCFGCat LIndex [(LIndex,LParam)]
deriving (Eq,Show)
data PMCFGRule = PMCFGRule PMCFGCat [PMCFGCat] [[Symbol]]
deriving (Eq,Show)
-- | the constructors are judgements in
--
-- - abstract syntax (/ABS/)
@@ -335,8 +329,8 @@ data Info =
| 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 [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'
| CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe [Production]) -- ^ (/CNC/) lindef ini'zed,
| CncFun (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe [Production]) -- ^ (/CNC/) type info added at 'TC'
-- indirection to module Ident
| AnyInd Bool ModuleName -- ^ (/INDIR/) the 'Bool' says if canonical

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

@@ -25,7 +25,6 @@ module GF.Grammar.Printer
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import PGF2(Literal(..))
import PGF2.Transactions(LIndex,LParam,Symbol(..))
import GF.Infra.Ident
import GF.Infra.Option
import GF.Grammar.Values
@@ -159,16 +158,18 @@ ppJudgement q (id, AnyInd cann mid) =
Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
_ -> empty
ppPmcfgRule id arg_cats res_cat (PMCFGRule res args lins) =
ppPmcfgRule id arg_cats res_cat (Production args res lins) =
pp id <+> (':' <+>
(if null args
then empty
else hsep (intersperse (pp '*') (zipWith ppPmcfgCat arg_cats args)) <+> "->") <+>
else hsep (intersperse (pp '*') (zipWith ppPArg 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)
ppPArg cat (PArg _ p) = ppPmcfgCat cat p
ppPmcfgCat :: Ident -> LParam -> Doc
ppPmcfgCat cat p = pp cat <> parens (ppLParam p)
instance Pretty Term where pp = ppTerm Unqualified 0
@@ -365,8 +366,8 @@ ppLit (LStr s) = pp (show s)
ppLit (LInt n) = pp n
ppLit (LFlt d) = pp d
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 (SymCat d r)= pp '<' <> pp d <> pp ',' <> ppLParam r <> pp '>'
ppSymbol (SymLit d r)= pp '{' <> pp d <> pp ',' <> ppLParam r <> pp '}'
ppSymbol (SymVar d r) = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>'
ppSymbol (SymKS t) = doubleQuotes (pp t)
ppSymbol SymNE = pp "nonExist"
@@ -377,6 +378,8 @@ 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)))
ppLParam (LParam r rs) = ppLinFun ppLVar r rs
ppLinFun ppParam r rs
| r == 0 && not (null rs) = hcat (intersperse (pp '+') ( map ppTerm rs))
| otherwise = hcat (intersperse (pp '+') (pp r : map ppTerm rs))
@@ -385,7 +388,7 @@ ppLinFun ppParam r rs
| i == 1 = ppParam p
| otherwise = pp i <> pp '*' <> ppParam p
ppLParam p
ppLVar p
| i == 0 = pp (chars !! j)
| otherwise = pp (chars !! j : show i)
where