mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-20 18:29:33 -06:00
314 lines
10 KiB
Haskell
314 lines
10 KiB
Haskell
-- |
|
|
-- 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.
|
|
|
|
{-# LANGUAGE DeriveTraversable #-}
|
|
module GF.Grammar.Canonical where
|
|
import Prelude hiding ((<>))
|
|
import GF.Text.Pretty
|
|
import GF.Infra.Ident (RawIdent)
|
|
|
|
-- | A Complete grammar
|
|
data Grammar = Grammar Abstract [Concrete] deriving Show
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- ** Abstract Syntax
|
|
|
|
-- | Abstract Syntax
|
|
data Abstract = Abstract ModId Flags [CatDef] [FunDef] deriving Show
|
|
abstrName (Abstract mn _ _ _) = mn
|
|
|
|
data CatDef = CatDef CatId [CatId] deriving Show
|
|
data FunDef = FunDef FunId Type deriving Show
|
|
data Type = Type [TypeBinding] TypeApp deriving Show
|
|
data TypeApp = TypeApp CatId [Type] deriving Show
|
|
|
|
data TypeBinding = TypeBinding VarId Type deriving Show
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- ** Concreate syntax
|
|
|
|
-- | Concrete Syntax
|
|
data Concrete = Concrete ModId ModId Flags [ParamDef] [LincatDef] [LinDef]
|
|
deriving Show
|
|
concName (Concrete cnc _ _ _ _ _) = cnc
|
|
|
|
data ParamDef = ParamDef ParamId [ParamValueDef]
|
|
| ParamAliasDef ParamId LinType
|
|
deriving Show
|
|
data LincatDef = LincatDef CatId LinType deriving Show
|
|
data LinDef = LinDef FunId [VarId] LinValue deriving Show
|
|
|
|
-- | Linearization type, RHS of @lincat@
|
|
data LinType = FloatType
|
|
| IntType
|
|
| ParamType ParamType
|
|
| RecordType [RecordRowType]
|
|
| StrType
|
|
| TableType LinType LinType
|
|
| TupleType [LinType]
|
|
deriving (Eq,Ord,Show)
|
|
|
|
newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
|
|
|
|
-- | Linearization value, RHS of @lin@
|
|
data LinValue = ConcatValue LinValue LinValue
|
|
| LiteralValue LinLiteral
|
|
| ErrorValue String
|
|
| ParamConstant ParamValue
|
|
| PredefValue PredefId
|
|
| RecordValue [RecordRowValue]
|
|
| TableValue LinType [TableRowValue]
|
|
--- | VTableValue LinType [LinValue]
|
|
| TupleValue [LinValue]
|
|
| VariantValue [LinValue]
|
|
| VarValue VarValueId
|
|
| PreValue [([String], LinValue)] LinValue
|
|
| Projection LinValue LabelId
|
|
| Selection LinValue LinValue
|
|
| CommentedValue String LinValue
|
|
deriving (Eq,Ord,Show)
|
|
|
|
data LinLiteral = FloatConstant Float
|
|
| IntConstant Int
|
|
| StrConstant String
|
|
deriving (Eq,Ord,Show)
|
|
|
|
data LinPattern = ParamPattern ParamPattern
|
|
| RecordPattern [RecordRow LinPattern]
|
|
| TuplePattern [LinPattern]
|
|
| WildPattern
|
|
deriving (Eq,Ord,Show)
|
|
|
|
type ParamValue = Param LinValue
|
|
type ParamPattern = Param LinPattern
|
|
type ParamValueDef = Param ParamId
|
|
|
|
data Param arg = Param ParamId [arg]
|
|
deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
|
|
|
|
type RecordRowType = RecordRow LinType
|
|
type RecordRowValue = RecordRow LinValue
|
|
type TableRowValue = TableRow LinValue
|
|
|
|
data RecordRow rhs = RecordRow LabelId rhs
|
|
deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
|
|
data TableRow rhs = TableRow LinPattern rhs
|
|
deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
|
|
|
|
-- *** Identifiers in Concrete Syntax
|
|
|
|
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 QualId deriving (Eq,Ord,Show)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- ** Used in both Abstract and Concrete Syntax
|
|
|
|
newtype ModId = ModId Id deriving (Eq,Ord,Show)
|
|
|
|
newtype CatId = CatId Id deriving (Eq,Ord,Show)
|
|
newtype FunId = FunId Id deriving (Eq,Show)
|
|
|
|
data VarId = Anonymous | VarId Id deriving Show
|
|
|
|
newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
|
|
type FlagName = Id
|
|
data FlagValue = Str String | Int Int | Flt Double deriving Show
|
|
|
|
|
|
-- *** Identifiers
|
|
|
|
type Id = RawIdent
|
|
data QualId = Qual ModId Id | Unqual Id deriving (Eq,Ord,Show)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- ** Pretty printing
|
|
|
|
instance Pretty Grammar where
|
|
pp (Grammar abs cncs) = abs $+$ vcat cncs
|
|
|
|
instance Pretty Abstract where
|
|
pp (Abstract m flags cats funs) =
|
|
"abstract" <+> m <+> "=" <+> "{" $$
|
|
flags $$
|
|
"cat" <+> fsep cats $$
|
|
"fun" <+> vcat funs $$
|
|
"}"
|
|
|
|
instance Pretty CatDef where
|
|
pp (CatDef c cs) = hsep (c:cs)<>";"
|
|
|
|
instance Pretty FunDef where
|
|
pp (FunDef f ty) = f <+> ":" <+> ty <>";"
|
|
|
|
instance Pretty Type where
|
|
pp (Type bs ty) = sep (punctuate " ->" (map pp bs ++ [pp ty]))
|
|
|
|
instance PPA Type where
|
|
ppA (Type [] (TypeApp c [])) = pp c
|
|
ppA t = parens t
|
|
|
|
instance Pretty TypeBinding where
|
|
pp (TypeBinding Anonymous (Type [] tapp)) = pp tapp
|
|
pp (TypeBinding Anonymous ty) = parens ty
|
|
pp (TypeBinding (VarId x) ty) = parens (x<+>":"<+>ty)
|
|
|
|
instance Pretty TypeApp where
|
|
pp (TypeApp c targs) = c<+>hsep (map ppA targs)
|
|
|
|
instance Pretty VarId where
|
|
pp Anonymous = pp "_"
|
|
pp (VarId x) = pp x
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
instance Pretty Concrete where
|
|
pp (Concrete cncid absid flags params lincats lins) =
|
|
"concrete" <+> cncid <+> "of" <+> absid <+> "=" <+> "{" $$
|
|
vcat params $$
|
|
section "lincat" lincats $$
|
|
section "lin" lins $$
|
|
"}"
|
|
where
|
|
section name [] = empty
|
|
section name ds = name <+> vcat (map (<> ";") ds)
|
|
|
|
instance Pretty ParamDef where
|
|
pp (ParamDef p pvs) = hang ("param"<+> p <+> "=") 4 (punctuate " |" pvs)<>";"
|
|
pp (ParamAliasDef p t) = hang ("oper"<+> p <+> "=") 4 t<>";"
|
|
|
|
instance PPA arg => Pretty (Param arg) where
|
|
pp (Param p ps) = pp p<+>sep (map ppA ps)
|
|
|
|
instance PPA arg => PPA (Param arg) where
|
|
ppA (Param p []) = pp p
|
|
ppA pv = parens pv
|
|
|
|
instance Pretty LincatDef where
|
|
pp (LincatDef c lt) = hang (c <+> "=") 4 lt
|
|
|
|
instance Pretty LinType where
|
|
pp lt = case lt of
|
|
FloatType -> pp "Float"
|
|
IntType -> pp "Int"
|
|
ParamType pt -> pp pt
|
|
RecordType rs -> block rs
|
|
StrType -> pp "Str"
|
|
TableType pt lt -> sep [pt <+> "=>",pp lt]
|
|
TupleType lts -> "<"<>punctuate "," lts<>">"
|
|
|
|
instance RhsSeparator LinType where rhsSep _ = pp ":"
|
|
|
|
instance Pretty ParamType where
|
|
pp (ParamTypeId p) = pp p
|
|
|
|
instance Pretty LinDef where
|
|
pp (LinDef f xs lv) = hang (f<+>hsep xs<+>"=") 4 lv
|
|
|
|
instance Pretty LinValue where
|
|
pp lv = case lv of
|
|
ConcatValue v1 v2 -> sep [v1 <+> "++",pp v2]
|
|
ErrorValue s -> "Predef.error"<+>doubleQuotes s
|
|
ParamConstant pv -> pp pv
|
|
Projection lv l -> ppA lv<>"."<>l
|
|
Selection tv pv -> ppA tv<>"!"<>ppA pv
|
|
VariantValue vs -> "variants"<+>block vs
|
|
CommentedValue s v -> "{-" <+> s <+> "-}" $$ v
|
|
_ -> ppA lv
|
|
|
|
instance PPA LinValue where
|
|
ppA lv = case lv of
|
|
LiteralValue l -> ppA l
|
|
ParamConstant pv -> ppA pv
|
|
PredefValue p -> ppA p
|
|
RecordValue [] -> pp "<>"
|
|
RecordValue rvs -> block rvs
|
|
PreValue alts def ->
|
|
"pre"<+>block (map alt alts++["_"<+>"=>"<+>def])
|
|
where
|
|
alt (ss,lv) = hang (hcat (punctuate "|" (map doubleQuotes ss)))
|
|
2 ("=>"<+>lv)
|
|
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
|
|
pp p =
|
|
case p of
|
|
ParamPattern pv -> pp pv
|
|
_ -> ppA p
|
|
|
|
instance PPA LinPattern where
|
|
ppA p =
|
|
case p of
|
|
ParamPattern pv -> ppA pv
|
|
RecordPattern r -> block r
|
|
TuplePattern ps -> "<"<>punctuate "," ps<>">"
|
|
WildPattern -> pp "_"
|
|
|
|
instance RhsSeparator LinPattern where rhsSep _ = pp "="
|
|
|
|
instance RhsSeparator rhs => Pretty (RecordRow rhs) where
|
|
pp (RecordRow l v) = hang (l<+>rhsSep v) 2 v
|
|
|
|
instance Pretty rhs => Pretty (TableRow rhs) where
|
|
pp (TableRow l v) = hang (l<+>"=>") 2 v
|
|
|
|
--------------------------------------------------------------------------------
|
|
instance Pretty ModId where pp (ModId s) = pp s
|
|
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) = "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)
|
|
where
|
|
ppFlag (name,value) = name <+> "=" <+> value <>";"
|
|
|
|
instance Pretty FlagValue where
|
|
pp (Str s) = pp s
|
|
pp (Int i) = pp i
|
|
pp (Flt d) = pp d
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Pretty print atomically (i.e. wrap it in parentheses if necessary)
|
|
class Pretty a => PPA a where ppA :: a -> Doc
|
|
|
|
class Pretty rhs => RhsSeparator rhs where rhsSep :: rhs -> Doc
|
|
|
|
semiSep xs = punctuate ";" xs
|
|
block xs = braces (semiSep xs)
|