path: root/src/compiler/GF/Grammar/Canonical.hs

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