msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Expose GF.Grammar.Canonical + some refactoring

Browse Source 
to make it available in other tools by depending on the gf package and
importing it
This commit is contained in:
Thomas Hallgren
2019-03-07 17:41:16 +01:00
parent b783299b73
commit 5b401f3880
6 changed files with 105 additions and 53 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
gf.cabal
View File

@@ -151,6 +151,7 @@ Library
GF.Support
GF.Text.Pretty
GF.Text.Lexing
GF.Grammar.Canonical
other-modules:
GF.Main GF.Compiler GF.Interactive
@@ -190,7 +191,6 @@ Library
GF.Haskell
GF.Compile.ConcreteToHaskell
GF.Compile.GrammarToCanonical
GF.Grammar.Canonical
GF.Grammar.CanonicalJSON
GF.Compile.PGFtoJS
GF.Compile.PGFtoProlog

6
src/compiler/GF.hs
View File

@@ -19,7 +19,9 @@ module GF(
module GF.Grammar.Printer,
module GF.Infra.Ident,
-- ** Binary serialisation
module GF.Grammar.Binary
module GF.Grammar.Binary,
-- * Canonical GF
module GF.Compile.GrammarToCanonical
) where
import GF.Main
import GF.Compiler
@@ -36,3 +38,5 @@ import GF.Grammar.Macros
import GF.Grammar.Printer
import GF.Infra.Ident
import GF.Grammar.Binary
import GF.Compile.GrammarToCanonical

26
src/compiler/GF/Compile/ConcreteToHaskell.hs
View File

@@ -142,8 +142,8 @@ concrete2haskell opts
rhs = lets (zipWith letlin args absctx)
(convert vs (coerce env lincat rhs0))
where
vs = [(VarValueId x,a)|(VarId x,a)<-zip xs args]
env= [(VarValueId x,lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args]
env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) =
(a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
@@ -173,15 +173,20 @@ concrete2haskell opts
VariantValue [] -> empty
VariantValue ts@(_:_) -> variants ts
VarValue x -> maybe (Var (gId x)) (pure . Var) $ lookup x vs
IntConstant n -> pure (lit n)
StrConstant s -> pure (token s)
PreValue vs t' -> pure (alts t' vs)
ParamConstant (Param c vs) -> aps (Var (pId c)) (map ppT vs)
ErrorValue s -> ap (Const "error") (Const (show s)) -- !!
LiteralValue l -> ppL l
_ -> error ("convert "++show t)
ppL l =
case l of
FloatConstant x -> pure (lit x)
IntConstant n -> pure (lit n)
StrConstant s -> pure (token s)
pId p@(ParamId s) =
if "to_R_" `isPrefixOf` s then toIdent p else gId p -- !! a hack
if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
table cs =
if all (null.patVars) ps
@@ -329,7 +334,7 @@ coerce env ty t =
_ -> t
where
app f ts = ParamConstant (Param f ts) -- !! a hack
to_rcon = ParamId . to_rcon' . labels
to_rcon = ParamId . Unqual . to_rcon' . labels
patVars p = []
@@ -395,11 +400,16 @@ linfunName c = prefixIdent "lin" (toIdent c)
class ToIdent i where toIdent :: i -> Ident
instance ToIdent ParamId where toIdent (ParamId s) = identS s
instance ToIdent ParamId where toIdent (ParamId q) = qIdentS q
instance ToIdent PredefId where toIdent (PredefId s) = identS s
instance ToIdent CatId where toIdent (CatId s) = identS s
instance ToIdent C.FunId where toIdent (FunId s) = identS s
instance ToIdent VarValueId where toIdent (VarValueId s) = identS s
instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q
qIdentS = identS . unqual
unqual (Qual (ModId m) n) = m++"_"++n
unqual (Unqual n) = n
instance ToIdent VarId where
toIdent Anonymous = identW

46
src/compiler/GF/Compile/GrammarToCanonical.hs
View File

@@ -165,11 +165,11 @@ convert' gr vs = ppT
Cn x -> VarValue (gId x) -- hmm
Con c -> ParamConstant (Param (gId c) [])
Sort k -> VarValue (gId k)
EInt n -> IntConstant n
Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gId (qual m n))
QC (m,n) -> ParamConstant (Param (gId (qual m n)) [])
K s -> StrConstant s
Empty -> StrConstant ""
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
@@ -183,14 +183,14 @@ convert' gr vs = ppT
Ok SOFT_SPACE -> p "SOFT_SPACE"
Ok CAPIT -> p "CAPIT"
Ok ALL_CAPIT -> p "ALL_CAPIT"
_ -> VarValue (gId n)
_ -> 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 (gId (qual m 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
@@ -233,8 +233,8 @@ convert' gr vs = ppT
concatValue v1 v2 =
case (v1,v2) of
(StrConstant "",_) -> v2
(_,StrConstant "") -> v1
(LiteralValue (StrConstant ""),_) -> v2
(_,LiteralValue (StrConstant "")) -> v1
_ -> ConcatValue v1 v2
projection r l = maybe (Projection r l) id (proj r l)
@@ -298,8 +298,8 @@ convType = ppT
Sort k -> convSort k
-- EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
FV (t:ts) -> ppT t -- !!
QC (m,n) -> ParamType (ParamTypeId (gId (qual m n)))
Q (m,n) -> ParamType (ParamTypeId (gId (qual m n)))
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)
@@ -325,25 +325,21 @@ paramType gr q@(_,n) =
((S.singleton (m,n),argTypes ps),
[ParamDef name (map (param m) ps)]
)
where name = gId (qual m n)
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 (gId (qual m n)) [identS "n"]) (TId (identS "Int"))])-}
[Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
| otherwise ->
((S.singleton (m,n),paramTypes gr t),
[ParamAliasDef (gId (qual m n)) (convType t)])
[ParamAliasDef ((gQId m n)) (convType t)])
_ -> ((S.empty,S.empty),[])
where
param m (n,ctx) = Param (gId (qual m n)) [toParamId t|(_,_,t)<-ctx]
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]
qual :: ModuleName -> Ident -> Ident
qual m = prefixIdent (render m++"_")
lblId = LabelId . render -- hmm
modId (MN m) = ModId (showIdent m)
@@ -354,8 +350,16 @@ instance FromIdent VarId where
instance FromIdent C.FunId where gId = C.FunId . showIdent
instance FromIdent CatId where gId = CatId . showIdent
instance FromIdent ParamId where gId = ParamId . showIdent
instance FromIdent VarValueId where gId = VarValueId . 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) |

62
src/compiler/GF/Grammar/Canonical.hs
View File

@@ -1,7 +1,12 @@
-- | Abstract syntax for canonical GF grammars, i.e. what's left after
-- |
-- Module : GF.Grammar.Canonical
-- Stability : provisional
--
-- Abstract syntax for canonical GF grammars, i.e. what's left after
-- high-level constructions such as functors and opers have been eliminated
-- by partial evaluation. This is intended as a common intermediate
-- representation to simplify export to other formats.
module GF.Grammar.Canonical where
import Prelude hiding ((<>))
import GF.Text.Pretty
@@ -51,13 +56,11 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
-- | Linearization value, RHS of @lin@
data LinValue = ConcatValue LinValue LinValue
| LiteralValue LinLiteral
| ErrorValue String
| FloatConstant Float
| IntConstant Int
| ParamConstant ParamValue
| PredefValue PredefId
| RecordValue [RecordRowValue]
| StrConstant String
| TableValue LinType [TableRowValue]
--- | VTableValue LinType [LinValue]
| TupleValue [LinValue]
@@ -66,7 +69,12 @@ data LinValue = ConcatValue LinValue LinValue
| PreValue [([String], LinValue)] LinValue
| Projection LinValue LabelId
| Selection LinValue LinValue
deriving (Eq,Ord,Show)
deriving (Eq,Ord,Show)
data LinLiteral = FloatConstant Float
| IntConstant Int
| StrConstant String
deriving (Eq,Ord,Show)
data LinPattern = ParamPattern ParamPattern
| RecordPattern [RecordRow LinPattern]
@@ -87,27 +95,33 @@ data TableRowValue = TableRowValue LinPattern LinValue deriving (Eq,Ord,Show)
-- *** Identifiers in Concrete Syntax
newtype PredefId = PredefId String deriving (Eq,Ord,Show)
newtype LabelId = LabelId String deriving (Eq,Ord,Show)
data VarValueId = VarValueId String deriving (Eq,Ord,Show)
newtype PredefId = PredefId Id deriving (Eq,Ord,Show)
newtype LabelId = LabelId Id deriving (Eq,Ord,Show)
data VarValueId = VarValueId QualId deriving (Eq,Ord,Show)
-- | Name of param type or param value
newtype ParamId = ParamId String deriving (Eq,Ord,Show)
newtype ParamId = ParamId QualId deriving (Eq,Ord,Show)
--------------------------------------------------------------------------------
-- ** Used in both Abstract and Concrete Syntax
newtype ModId = ModId String deriving (Eq,Show)
newtype ModId = ModId Id deriving (Eq,Ord,Show)
newtype CatId = CatId String deriving (Eq,Ord,Show)
newtype FunId = FunId String deriving (Eq,Show)
newtype CatId = CatId Id deriving (Eq,Ord,Show)
newtype FunId = FunId Id deriving (Eq,Show)
data VarId = Anonymous | VarId String deriving Show
data VarId = Anonymous | VarId Id deriving Show
newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
type FlagName = String
type FlagName = Id
data FlagValue = Str String | Int Int | Flt Double deriving Show
-- *** Identifiers
type Id = String
data QualId = Qual ModId Id | Unqual Id deriving (Eq,Ord,Show)
--------------------------------------------------------------------------------
-- ** Pretty printing
@@ -203,8 +217,7 @@ instance Pretty LinValue where
instance PPA LinValue where
ppA lv = case lv of
FloatConstant f -> pp f
IntConstant n -> pp n
LiteralValue l -> ppA l
ParamConstant pv -> ppA pv
PredefValue p -> ppA p
RecordValue [] -> pp "<>"
@@ -214,13 +227,20 @@ instance PPA LinValue where
where
alt (ss,lv) = hang (hcat (punctuate "|" (map doubleQuotes ss)))
2 ("=>"<+>lv)
StrConstant s -> doubleQuotes s -- hmm
TableValue _ tvs -> "table"<+>block tvs
-- VTableValue t ts -> "table"<+>t<+>brackets (semiSep ts)
TupleValue lvs -> "<"<>punctuate "," lvs<>">"
VarValue v -> pp v
_ -> parens lv
instance Pretty LinLiteral where pp = ppA
instance PPA LinLiteral where
ppA l = case l of
FloatConstant f -> pp f
IntConstant n -> pp n
StrConstant s -> doubleQuotes s -- hmm
instance RhsSeparator LinValue where rhsSep _ = pp "="
instance Pretty LinPattern where
@@ -250,11 +270,17 @@ instance Pretty CatId where pp (CatId s) = pp s
instance Pretty FunId where pp (FunId s) = pp s
instance Pretty LabelId where pp (LabelId s) = pp s
instance Pretty PredefId where pp = ppA
instance PPA PredefId where ppA (PredefId s) = pp s
instance PPA PredefId where ppA (PredefId s) = "Predef."<>s
instance Pretty ParamId where pp = ppA
instance PPA ParamId where ppA (ParamId s) = pp s
instance Pretty VarValueId where pp (VarValueId s) = pp s
instance Pretty QualId where pp = ppA
instance PPA QualId where
ppA (Qual m n) = m<>"_"<>n -- hmm
ppA (Unqual n) = pp n
instance Pretty Flags where
pp (Flags []) = empty
pp (Flags flags) = "flags" <+> vcat (map ppFlag flags)

16
src/compiler/GF/Grammar/CanonicalJSON.hs
View File

@@ -95,10 +95,7 @@ instance JSON LinType where
instance JSON LinValue where
showJSON lv = case lv of
-- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
StrConstant s -> showJSON s
FloatConstant f -> showJSON f
IntConstant n -> showJSON n
LiteralValue l -> showJSON l
-- concatenation is encoded as a JSON array:
ConcatValue v v' -> showJSON [showJSON v, showJSON v']
-- most values are encoded as JSON objects:
@@ -115,6 +112,13 @@ instance JSON LinValue where
-- records are encoded directly as JSON records:
RecordValue rows -> showJSON rows
instance JSON LinLiteral where
showJSON l = case l of
-- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
StrConstant s -> showJSON s
FloatConstant f -> showJSON f
IntConstant n -> showJSON n
instance JSON LinPattern where
showJSON linpat = case linpat of
-- wildcards and patterns without arguments are encoded as strings:
@@ -161,6 +165,10 @@ instance JSON VarId where
showJSON Anonymous = showJSON "_"
showJSON (VarId x) = showJSON x
instance JSON QualId where
showJSON (Qual (ModId m) n) = showJSON (m++"_"++n)
showJSON (Unqual n) = showJSON n
instance JSON Flags where
-- flags are encoded directly as JSON records (i.e., objects):
showJSON (Flags fs) = makeObj [(f,showJSON v) | (f, v) <- fs]