content: {-# LANGUAGE DeriveFunctor #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE DeriveFoldable #-}
  {-# LANGUAGE DeriveTraversable #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE DeriveDataTypeable #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  --------------------------------------------------------------------
  -- |
  -- Copyright :  (c) Edward Kmett and Dan Doel 2012-2014
  -- License   :  BSD2
  -- Maintainer:  Dan Doel <dan.doel@gmail.com>
  -- Stability :  experimental
  -- Portability: non-portable (DeriveDataTypeable)
  --
  -- This module provides the AST for data type declarations
  --------------------------------------------------------------------
  
  module Ermine.Syntax.Constructor
    ( Constructor(Constructor)
    , ekinds
    , etypes
    , fields
    ) where
  
  import Bound
  import Bound.Scope
  import Control.Applicative
  import Control.Lens
  import Data.Bifoldable
  import Data.Bifunctor
  import Data.Bitraversable
  import Data.Binary as Binary
  import Data.Bytes.Serial
  import Data.Foldable (Foldable)
  import Data.Typeable
  import Ermine.Syntax.Hint
  import Ermine.Syntax.Global
  import Ermine.Syntax.Kind as Kind
  import Ermine.Syntax.Scope
  import Ermine.Syntax.Type as Type
  import GHC.Generics hiding (Constructor)
  import Prelude.Extras
  
  data Constructor k t =
    Constructor { _cname  :: Global
                , _ekinds :: [Hint]
                , _etypes :: [(Hint, Scope Int Kind k)]
                , _fields :: [Scope Int (TK k) t]
                }
   deriving (Show, Eq, Functor, Foldable, Traversable, Typeable, Generic)
  
  instance HasGlobal (Constructor k t) where
    global = lens _cname (\c t -> c { _cname = t })
  
  ekinds :: Lens' (Constructor k t) [Hint]
  ekinds = lens _ekinds (\c ks -> c { _ekinds = ks })
  
  etypes :: Lens' (Constructor k t) [(Hint, Scope Int Kind k)]
  etypes = lens _etypes (\c ts -> c { _etypes = ts })
  
  fields :: Lens' (Constructor k t) [Scope Int (TK k) t]
  fields = lens _fields (\c fs -> c { _fields = fs })
  
  instance Show k => Show1 (Constructor k)
  instance Show2 Constructor
  
  instance Eq k => Eq1 (Constructor k)
  instance Eq2 Constructor
  
  instance Bifunctor Constructor where
    bimap = bimapDefault
  
  instance Bifoldable Constructor where
    bifoldMap = bifoldMapDefault
  
  instance Bitraversable Constructor where
    bitraverse f g (Constructor n ek et as) =
      Constructor n ek
        <$> traverse (traverse (traverseScope pure f)) et
        <*> traverse (bitraverseScope (traverse f) g) as
  
  instance HasKindVars (Constructor k t) (Constructor k' t) k k' where
    kindVars f (Constructor n ek et as) =
      Constructor n ek
        <$> traverse (traverse (kindVars f)) et
        <*> traverse (bitraverseScopeTK f pure) as
  
  instance HasTypeVars (Constructor k t) (Constructor k t') t t' where
    typeVars = traverse
  
  instance BoundBy (Constructor k) (Type k) where
    boundBy f (Constructor tg ks ts fs) = Constructor tg ks ts $ map (>>>= first F . f) fs
  
  -- Serialization
  instance Serial2 Constructor where
    serializeWith2 pk pt (Constructor nm ek et as) =
      serialize nm *>
      serialize ek *>
      serializeWith (serializeWith $ serializeScope3 serialize serializeWith pk) et *>
      serializeWith (serializeScope3 serialize (serializeTK pk) pt) as
  
    deserializeWith2 gk gt =
      Constructor
        <$> deserialize
        <*> deserialize
        <*> deserializeWith
              (deserializeWith $ deserializeScope3 deserialize deserializeWith gk)
        <*> deserializeWith (deserializeScope3 deserialize (deserializeTK gk) gt)
  
  instance Serial k => Serial1 (Constructor k) where
    serializeWith = serializeWith2 serialize
    deserializeWith = deserializeWith2 deserialize
  
  instance (Serial k, Serial t) => Serial (Constructor k t) where
    serialize = serializeWith serialize
    deserialize = deserializeWith deserialize
  
  instance (Binary k, Binary t) => Binary (Constructor k t) where
    get = deserializeWith2 Binary.get Binary.get
    put = serializeWith2 Binary.put Binary.put
  