{-# language DataKinds #-}
{-# language FlexibleInstances #-}
{-# language GADTs #-}
{-# language InstanceSigs #-}
{-# language NamedFieldPuns #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language UndecidableInstances #-}

module Rel8.Table.Tag
  ( Tag(..), Taggable
  , fromAggregate
  , fromExpr
  , fromName
  )
where

-- base
import Control.Applicative ( (<|>), empty )
import Data.Kind ( Constraint, Type )
import Data.Foldable ( fold )
import Data.Monoid ( getFirst )
import Data.Proxy ( Proxy( Proxy ) )
import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
import Prelude

-- rel8
import Rel8.Aggregate ( Aggregate, Aggregator, foldInputs )
import Rel8.Expr ( Expr )
import Rel8.Expr.Opaleye ( fromPrimExpr )
import Rel8.Schema.Name ( Name( Name ) )
import Rel8.Schema.Null ( Sql )
import Rel8.Type.Monoid ( DBMonoid )


type Tag :: Symbol -> Type -> Type
data Tag label a = Tag
  { Tag label a -> Expr a
expr :: Expr a
  , Tag label a -> Maybe Aggregator
aggregator :: Maybe Aggregator
  , Tag label a -> Name a
name :: Name a
  }


type Taggable :: Type -> Constraint
class Taggable a where
  tappend :: KnownSymbol label => Tag label a -> Tag label a -> Tag label a
  tempty :: KnownSymbol label => Tag label a


instance Sql DBMonoid a => Taggable a where
  tappend :: forall label. KnownSymbol label
    => Tag label a -> Tag label a -> Tag label a
  tappend :: Tag label a -> Tag label a -> Tag label a
tappend Tag label a
a Tag label a
b = Tag :: forall (label :: Symbol) a.
Expr a -> Maybe Aggregator -> Name a -> Tag label a
Tag
    { expr :: Expr a
expr = Tag label a -> Expr a
forall (label :: Symbol) a. Tag label a -> Expr a
expr Tag label a
a Expr a -> Expr a -> Expr a
forall a. Semigroup a => a -> a -> a
<> Tag label a -> Expr a
forall (label :: Symbol) a. Tag label a -> Expr a
expr Tag label a
b
    , aggregator :: Maybe Aggregator
aggregator = Tag label a -> Maybe Aggregator
forall (label :: Symbol) a. Tag label a -> Maybe Aggregator
aggregator Tag label a
a Maybe Aggregator -> Maybe Aggregator -> Maybe Aggregator
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tag label a -> Maybe Aggregator
forall (label :: Symbol) a. Tag label a -> Maybe Aggregator
aggregator Tag label a
b
    , name :: Name a
name = case (Tag label a -> Name a
forall (label :: Symbol) a. Tag label a -> Name a
name Tag label a
a, Proxy label -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy label
forall k (t :: k). Proxy t
Proxy @label)) of
        (Name String
x, String
y)
          | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
y -> Tag label a -> Name a
forall (label :: Symbol) a. Tag label a -> Name a
name Tag label a
b
          | Bool
otherwise -> Tag label a -> Name a
forall (label :: Symbol) a. Tag label a -> Name a
name Tag label a
a
    }
  {-# INLINABLE tappend #-}

  tempty :: forall label. KnownSymbol label => Tag label a
  tempty :: Tag label a
tempty = Tag :: forall (label :: Symbol) a.
Expr a -> Maybe Aggregator -> Name a -> Tag label a
Tag
    { expr :: Expr a
expr = Expr a
forall a. Monoid a => a
mempty
    , aggregator :: Maybe Aggregator
aggregator = Maybe Aggregator
forall (f :: * -> *) a. Alternative f => f a
empty
    , name :: Name a
name = String -> Name a
forall k (a :: k). (k ~ *) => String -> Name a
Name (Proxy label -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy label
forall k (t :: k). Proxy t
Proxy @label))
    }
  {-# INLINABLE tempty #-}


instance (KnownSymbol label, Taggable a) => Semigroup (Tag label a) where
  <> :: Tag label a -> Tag label a -> Tag label a
(<>) = Tag label a -> Tag label a -> Tag label a
forall a (label :: Symbol).
(Taggable a, KnownSymbol label) =>
Tag label a -> Tag label a -> Tag label a
tappend


instance (KnownSymbol label, Taggable a) => Monoid (Tag label a) where
  mempty :: Tag label a
mempty = Tag label a
forall a (label :: Symbol).
(Taggable a, KnownSymbol label) =>
Tag label a
tempty


fromAggregate :: forall a label. (KnownSymbol label, Taggable a)
  => Aggregate a -> Tag label a
fromAggregate :: Aggregate a -> Tag label a
fromAggregate = Maybe (Tag label a) -> Tag label a
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Maybe (Tag label a) -> Tag label a)
-> (Aggregate a -> Maybe (Tag label a))
-> Aggregate a
-> Tag label a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. First (Tag label a) -> Maybe (Tag label a)
forall a. First a -> Maybe a
getFirst (First (Tag label a) -> Maybe (Tag label a))
-> (Aggregate a -> First (Tag label a))
-> Aggregate a
-> Maybe (Tag label a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Aggregator -> PrimExpr -> First (Tag label a))
-> Aggregate a -> First (Tag label a)
forall k b (a :: k).
Monoid b =>
(Maybe Aggregator -> PrimExpr -> b) -> Aggregate a -> b
foldInputs Maybe Aggregator -> PrimExpr -> First (Tag label a)
go
  where
    go :: Maybe Aggregator -> PrimExpr -> First (Tag label a)
go Maybe Aggregator
aggregator PrimExpr
primExpr = Tag label a -> First (Tag label a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tag label a -> First (Tag label a))
-> Tag label a -> First (Tag label a)
forall a b. (a -> b) -> a -> b
$ (KnownSymbol label => Tag label a
forall a (label :: Symbol).
(Taggable a, KnownSymbol label) =>
Tag label a
tempty @a @label)
      { expr :: Expr a
expr = PrimExpr -> Expr a
forall a. PrimExpr -> Expr a
fromPrimExpr PrimExpr
primExpr
      , Maybe Aggregator
aggregator :: Maybe Aggregator
aggregator :: Maybe Aggregator
aggregator
      }


fromExpr :: forall label a. (KnownSymbol label, Taggable a)
  => Expr a -> Tag label a
fromExpr :: Expr a -> Tag label a
fromExpr Expr a
expr = (KnownSymbol label => Tag label a
forall a (label :: Symbol).
(Taggable a, KnownSymbol label) =>
Tag label a
tempty @a @label) {Expr a
expr :: Expr a
expr :: Expr a
expr}


fromName :: forall a label. Taggable a => Name a -> Tag label a
fromName :: Name a -> Tag label a
fromName Name a
name = (KnownSymbol "" => Tag "" a
forall a (label :: Symbol).
(Taggable a, KnownSymbol label) =>
Tag label a
tempty @a @"") {Name a
name :: Name a
name :: Name a
name}