{-# 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)