module Data.Record (

    -- * Kinds
    Kind (type Forall, encase),
    Sort (specialize),

    -- * Styles
    Style (type K),

    -- * ???
    Value,

    -- * Records
    Record (build),
    ExtenderPiece (ExtenderPiece),
    X (X),
    (:&) ((:&)),
    (:::) ((:=)),

    -- * Catenation
    Cat,
    cat,

    -- * Mapping
    map,
    TransformerPiece (TransformerPiece),

    -- * Subrecords
    Subrecord (narrow)

) where

    -- Prelude
    import Prelude hiding (map)

    -- Fixities
    infixl 2 :&
    infix  3 :::, :=

    -- * Kinds
    class Kind kind where

        data Forall kind :: (* -> *) -> *

        encase :: (forall sort. (Sort kind sort) => piece sort) -> Forall kind piece

    class Sort kind sort where

        specialize :: Forall kind piece -> piece sort

    -- * Styles
    class (Kind (K style)) => Style style where

        type K style :: *

    -- * ???
    type family Value style sort :: *

    -- * Records
    {-|
        The class of all record types.

        A record type is a type of records without the style parameter. Therefore, it has kind @* ->
        *@.
    -}
    class (Kind kind) => Record kind record where

        {-|
            A general method for building record-related “things”.

            For each record type, this method constructs a value which is somehow related to this
            record type. Such a value is called a thing. The type parameter @thing@ maps record
            types to the types of their corresponding things. The first argument of @build@ gives
            the thing of the empty record type while the second argument tells how to transform a
            thing of an arbitrary record type into the thing of this record type extended
            with an arbitrary field type.

            @build@ is used, for example, to implement the function 'cat'.
        -}
        build :: thing X
              -> (forall record name. (Record kind record) =>
                  Forall kind (ExtenderPiece thing record name))
              -> thing record

    instance (Kind kind) => Record kind X where

        build nilThing _ = nilThing

    instance (Kind kind, Record kind record, Sort kind sort) =>
             Record kind (record :& name ::: sort) where

        build nilThing extender = let

                                      ExtenderPiece consThing = specialize extender

                                  in consThing (build nilThing extender)

    newtype ExtenderPiece thing record name sort = ExtenderPiece (thing record ->
                                                                  thing (record :& name ::: sort))

    -- |The type of empty records.
    data X style = X deriving (Show)

    -- |The type of non-empty records, consisting of an initial record and a last field.
    data (record :& field) style = !(record style) :& !(field style)

    {-
        explicit instance declaration to avoid parantheses around init records (will lead to
        missing parantheses if init is constructed by an operator constructor of the same fixity as
        :& which is right- or non-associative)
    -}
    instance (Show (init style), Show (last style)) => Show ((init :& last) style) where

        showsPrec enclPrec (init :& last) = showParen (enclPrec > snocPrec) $
                                            showsPrec snocPrec init        .
                                            showString " :& "              .
                                            showsPrec (succ snocPrec) last where

            snocPrec = 2

    {-|
        The family of record fields.

        Each instance of it matches arbitrary @name@ parameters and all @signalOfVal@ parameters
        which are of the form @/signal/ `'Of'` /val/@. The actual choice of the instance
        depends only on the @style@ parameter. The structure of fields of a specific style is
        documented together with the respective style type.
    -}
    data (name ::: sort) style = !name := Value style sort

    {-
        explicit instance declaration because GHC doesn’t support deriving because of the use of the
        type family Value
    -}
    instance (Show name, Show (Value style sort)) => Show ((name ::: sort) style) where

        showsPrec enclPrec (name := val) = showParen (enclPrec > assignPrec) $
                                           showsPrec (succ assignPrec) name .
                                           showString " := "                .
                                           showsPrec (succ assignPrec) val where

            assignPrec = 3

    -- * Catenation
    -- |The catenation of two record types.
    type family Cat (record1 :: * -> *) (record2 :: * -> *) :: * -> *
    type instance Cat record1 X                   = record1
    type instance Cat record1 (record2 :& field2) = Cat record1 record2 :& field2

    -- |The catenation of two records.
    cat :: (Style style, Record (K style) record1, Record (K style) record2) =>
           record1 style -> record2 style -> Cat record1 record2 style
    cat record1 = case build (nilCatThing record1) catExtender of CatThing attach -> attach

    newtype CatThing style record1 record2 = CatThing (record2 style -> Cat record1 record2 style)

    nilCatThing :: record1 style -> CatThing style record1 X
    nilCatThing record1 = CatThing $ \X -> record1

    catExtender :: (Style style) =>
                   Forall (K style) (ExtenderPiece (CatThing style record1) record name)
    catExtender = encase (ExtenderPiece consCatThing)

    consCatThing :: CatThing style record1 record2
                 -> CatThing style record1 (record2 :& name ::: sort)
    consCatThing (CatThing attach) = CatThing $ \(record2 :& field2) -> attach record2 :& field2

    -- * Mapping
    -- |Application of a function to the fields of a record.
    map :: (Style style, Style style', K style ~ K style', Record (K style) record)
        => Forall (K style) (TransformerPiece style style')
        -> record style -> record style'
    map = case build nilMapThing mapExtender of MapThing map -> map

    newtype TransformerPiece style style' sort = TransformerPiece (Value style sort ->
                                                                   Value style' sort)

    newtype MapThing style
                     style'
                     record = MapThing (Forall (K style) (TransformerPiece style style') ->
                                        record style -> record style')

    nilMapThing :: MapThing style style' X
    nilMapThing = MapThing $ \_ X -> X

    mapExtender :: (Style style) =>
                   Forall (K style) (ExtenderPiece (MapThing style style') record name)
    mapExtender = encase (ExtenderPiece consMapThing)

    consMapThing :: forall style style' record name sort.
                    (Sort (K style) sort)
                 => MapThing style style' record
                 -> MapThing style style' (record :& name ::: sort)
    consMapThing (MapThing map) = MapThing $ \transformer (record :& name := val) -> let

            TransformerPiece fun = specialize transformer :: TransformerPiece style style' sort

        in map transformer record :& name := fun val

    -- * Subrecords
    {-|
        The class of all pairs of record types where the first is a subrecord of the second.

        Currenty, the subrecord relation is only defined for records which do not have multiple
        occurences of the same name. A records is a subrecord of another record if all field types
        of the first record are also field types of the second, independently of order.

        The instance declarations of @Subrecord@ use several helper classes which are hidden. One of
        them is the class @Presence@. You get the error message that no instance of @Presence
        /name/@ could be found if the alleged subrecord contains a name which is not present in the
        alleged superrecord.
    -}
    class Subrecord subrecord record where

        -- |Converts a record into a subrecord by dropping and reordering fields appropriately.
        narrow :: (Style style) => record style -> subrecord style

    instance Subrecord X record where

        narrow _ = X

    instance (Dissection record remainder subname subsort, Subrecord subrecord remainder) =>
             Subrecord (subrecord :& subname ::: subsort) record where

        narrow record = narrow remainder :& lookupField where

            (remainder,lookupField) = dissect record

    class Dissection record remainder lookupName lookupSort | record lookupName -> remainder where

        dissect :: record style -> (remainder style,(lookupName ::: lookupSort) style)

    instance (Present lookupName) => Dissection X remainder lookupName lookupSort where

        dissect = undefined

    instance (lastSort ~ lookupSort) =>
             Dissection (init :& lookupName ::: lastSort) init lookupName lookupSort where

        dissect (init :& last) = (init,last)

    instance (Dissection init initRemainder lookupName lookupSort,
              (initRemainder :& lastName ::: lastSort) ~ remainder) =>
             Dissection (init :& lastName ::: lastSort) remainder lookupName lookupSort where

        dissect (init :& last) = (initRemainder :& last,lookupField) where

            (initRemainder,lookupField) = dissect init

    class Present lookupName