content: {-|
  Module: Squeal.PostgreSQL.Type.Alias
  Description: aliases
  Copyright: (c) Eitan Chatav, 2019
  Maintainer: eitan@morphism.tech
  Stability: experimental
  
  This module embeds Postgres's alias system in Haskell in
  a typesafe fashion. Thanks to GHC's @OverloadedLabels@ extension,
  Squeal can reference aliases by prepending with a @#@.
  -}
  
  {-# LANGUAGE
      AllowAmbiguousTypes
    , ConstraintKinds
    , DeriveAnyClass
    , DeriveGeneric
    , FlexibleContexts
    , FlexibleInstances
    , FunctionalDependencies
    , GADTs
    , LambdaCase
    , OverloadedStrings
    , QuantifiedConstraints
    , RankNTypes
    , ScopedTypeVariables
    , StandaloneDeriving
    , TypeApplications
    , TypeFamilyDependencies
    , DataKinds
    , PolyKinds
    , TypeOperators
    , UndecidableInstances
    , UndecidableSuperClasses
  #-}
  
  module Squeal.PostgreSQL.Type.Alias
    ( -- * Aliases
      (:::)
    , Alias (..)
    , IsLabel (..)
    , Aliased (As)
    , Aliasable (as)
    , renderAliased
    , mapAliased
    , Has
    , HasUnique
    , HasErr
    , HasAll
    , HasIn
      -- * Qualified Aliases
    , QualifiedAlias (..)
    , IsQualified (..)
      -- * Grouping
    , Grouping (..)
    , GroupedBy
      -- * Error reporting
    , LookupFailedError
    , PrettyPrintHaystack
    , PrettyPrintInfo(..)
    , MismatchError
    , LookupFailedError'
    , DefaultPrettyPrinter
    , MismatchError'
    ) where
  
  import Control.DeepSeq
  import Data.ByteString (ByteString)
  import Data.String (fromString)
  import GHC.Exts (Any, Constraint)
  import GHC.OverloadedLabels
  import GHC.TypeLits
  
  import qualified Generics.SOP as SOP
  import qualified GHC.Generics as GHC
  
  import Squeal.PostgreSQL.Type.List
  import Squeal.PostgreSQL.Render
  
  -- $setup
  -- >>> import Squeal.PostgreSQL
  
  -- | The alias operator `:::` is like a promoted version of `As`,
  -- a type level pair between an alias and some type.
  type (:::) (alias :: Symbol) ty = '(alias,ty)
  infixr 6 :::
  
  
  -- | `Grouping` is an auxiliary namespace, created by
  -- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.groupBy`), and used
  -- for typesafe aggregation
  data Grouping
    = Ungrouped -- ^ no aggregation permitted
    | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped
  
  {- | A `GroupedBy` constraint indicates that a table qualified column is
  a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,
  may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.
  -}
  class (KnownSymbol table, KnownSymbol column)
    => GroupedBy table column bys where
  instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)
    => GroupedBy table column ('(table,column) ': bys)
  instance {-# OVERLAPPABLE #-}
    ( KnownSymbol table
    , KnownSymbol column
    , GroupedBy table column bys
    ) => GroupedBy table column (tabcol ': bys)
  
  -- | `Alias`es are proxies for a type level string or `Symbol`
  -- and have an `IsLabel` instance so that with @-XOverloadedLabels@
  --
  -- >>> :set -XOverloadedLabels
  -- >>> #foobar :: Alias "foobar"
  -- Alias
  data Alias (alias :: Symbol) = Alias
    deriving (Eq,GHC.Generic,Ord,Show,NFData)
  instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
    fromLabel = Alias
  instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where
    fromLabel = fromLabel SOP.:* Nil
  -- | >>> printSQL (#jimbob :: Alias "jimbob")
  -- "jimbob"
  instance KnownSymbol alias => RenderSQL (Alias alias) where
    renderSQL = doubleQuoted . fromString . symbolVal
  
  -- >>> printSQL (#jimbob :* #kandi :: NP Alias '["jimbob", "kandi"])
  -- "jimbob", "kandi"
  instance SOP.All KnownSymbol aliases => RenderSQL (NP Alias aliases) where
    renderSQL
      = commaSeparated
      . SOP.hcollapse
      . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderSQL)
  
  -- | The `As` operator is used to name an expression. `As` is like a demoted
  -- version of `:::`.
  --
  -- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)
  -- As (Just "hello") Alias
  data Aliased expression aliased where
    As
      :: KnownSymbol alias
      => expression ty
      -> Alias alias
      -> Aliased expression (alias ::: ty)
  deriving instance Show (expression ty)
    => Show (Aliased expression (alias ::: ty))
  deriving instance Eq (expression ty)
    => Eq (Aliased expression (alias ::: ty))
  deriving instance Ord (expression ty)
    => Ord (Aliased expression (alias ::: ty))
  instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)
    => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where
      fromLabel = fromLabel @alias2 `As` fromLabel @alias1
  
  -- | The `Aliasable` class provides a way to scrap your `Nil`s
  -- in an `NP` list of `Aliased` expressions.
  class KnownSymbol alias => Aliasable alias expression aliased
    | aliased -> expression
    , aliased -> alias
    where as :: expression -> Alias alias -> aliased
  instance (KnownSymbol alias, aliased ~ (alias ::: ty)) => Aliasable alias
    (expression ty)
    (Aliased expression aliased)
      where
        as = As
  instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias
    (expression ty)
    (NP (Aliased expression) tys)
      where
        expression `as` alias = expression `As` alias SOP.:* Nil
  
  -- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")
  -- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int)
  -- "Just AS \"an_int\""
  renderAliased
    :: (forall ty. expression ty -> ByteString)
    -> Aliased expression aliased
    -> ByteString
  renderAliased render (expression `As` alias) =
    render expression <> " AS " <> renderSQL alias
  
  -- | Map a function over an `Aliased` expression.
  mapAliased
    :: (expr x -> expr y)
    -> Aliased expr (alias ::: x)
    -> Aliased expr (alias ::: y)
  mapAliased f (x `As` alias) = f x `As` alias
  
  -- | @HasUnique alias fields field@ is a constraint that proves that
  -- @fields@ is a singleton of @alias ::: field@.
  type HasUnique alias fields field = fields ~ '[alias ::: field]
  
  -- | @Has alias fields field@ is a constraint that proves that
  -- @fields@ has a field of @alias ::: field@, inferring @field@
  -- from @alias@ and @fields@.
  class (KnownSymbol alias) => Has (alias :: Symbol) (fields :: [(Symbol, kind)]) (field :: kind) | alias fields -> field
  -- having these instances forces 'Has' to inspect 'alias' and 'fields' and thereby fail before delegating to
  -- 'HasErr', which means 'Has' shows up in error messages instead of 'HasErr'
  instance {-# OVERLAPPING #-} (KnownSymbol alias, HasErr (alias ::: field0 ': fields) alias (alias ::: field0 ': fields) field1)
    => Has alias (alias ::: field0 ': fields) field1
  instance {-# OVERLAPPABLE #-} (KnownSymbol alias, HasErr (field' ': fields) alias (field' ': fields) field)
    => Has alias (field' ': fields) field
  instance (KnownSymbol alias, HasErr '[] alias '[] field)
    => Has alias '[] field
  
  {- | 'HasErr' is like `Has` except it also retains the original
  list of fields being searched, so that error messages are more
  useful.
  -}
  class KnownSymbol alias =>
    HasErr (allFields :: [(Symbol, kind)]) (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
    | alias fields -> field where
  instance {-# OVERLAPPING #-} (KnownSymbol alias, field0 ~ field1, MismatchError alias allFields field0 field1)
    => HasErr allFields alias (alias ::: field0 ': fields) field1
  instance {-# OVERLAPPABLE #-} (KnownSymbol alias, HasErr allFields alias fields field)
    => HasErr allFields alias (field' ': fields) field
  instance ( KnownSymbol alias
           , LookupFailedError alias allFields -- report a nicer error
           , field ~ Any -- required to satisfy the fundep
           ) => HasErr allFields alias '[] field
  
  -- | @MismatchError@ reports a nicer error with more context when we successfully do a lookup but
  -- find a different field than we expected. As a type family, it ensures that we only do the (expensive)
  -- calculation of coming up with our pretty printing information when we actually have a mismatch
  type family MismatchError (alias :: Symbol) (fields :: [(Symbol, kind)]) (found :: kind) (expected :: kind) :: Constraint where
    MismatchError _ _ found found = ()
    MismatchError alias fields found expected = MismatchError' (MismatchError' () (DefaultPrettyPrinter fields) alias fields found expected) (PrettyPrintHaystack fields) alias fields found expected
  
  -- | @MismatchError'@ is the workhorse behind @MismatchError@, but taking an additional type as the first argument. We can put another type error
  -- in there which will only show if @MismatchError'@ is stuck; this allows us to fall back to @DefaultPrettyPrinter@ when a @PrettyPrintHaystack@ instance
  -- is missing
  type family MismatchError' (err :: Constraint) (ppInfo :: PrettyPrintInfo) (alias :: Symbol) (fields :: [(Symbol, kind)]) (found :: kind) (expected :: kind) :: Constraint where
    MismatchError' _ ('PrettyPrintInfo needleName haystackName _) alias fields found expected = TypeError
      (     'Text "Type mismatch when looking up " ':<>: needleName ':<>: 'Text " named " ':<>: 'ShowType alias
      ':$$: 'Text "in " ':<>: haystackName ':<>: 'Text ":"
      -- we don't use a pretty haystack because we want to show the values
      ':$$: 'ShowType fields
      ':$$: 'Text ""
      ':$$: 'Text "Expected: " ':<>: 'ShowType expected
      ':$$: 'Text "But found: " ':<>: 'ShowType found
      ':$$: 'Text ""
      )
  
  -- | @LookupFailedError@ reports a nicer error when we fail to look up some @needle@ in some @haystack@
  type LookupFailedError needle haystack = LookupFailedError' (LookupFailedError' () (DefaultPrettyPrinter haystack) needle haystack) (PrettyPrintHaystack haystack) needle haystack
  
  -- | @LookupFailedError'@ is the workhorse behind @LookupFailedError@, but taking an additional type as the first argument. We can put another type error
  -- in there which will only show if @LookupFailedError'@ is stuck; this allows us to fall back to @DefaultPrettyPrinter@ when a @PrettyPrintHaystack@ instance
  -- is missing
  type family LookupFailedError' (fallbackForUnknownKind :: Constraint) (prettyPrintInfo :: PrettyPrintInfo) (needle :: Symbol) (haystack :: [(Symbol, k)]) :: Constraint where
    LookupFailedError' _ ('PrettyPrintInfo needleName haystackName prettyHaystack) needle rawHaystack = TypeError
      (     'Text "Could not find " ':<>: needleName ':<>: 'Text " named " ':<>: 'ShowType needle
      ':$$: 'Text "in " ':<>: haystackName ':<>: 'Text ":"
      ':$$: prettyHaystack
      ':$$: 'Text ""
      ':$$: 'Text "*Raw " ':<>: haystackName ':<>: 'Text "*:"
      ':$$: 'ShowType rawHaystack
      ':$$: 'Text ""
      )
  
  -- | @PrettyPrintInfo@ is a data type intended to be used at the type level
  -- which describes how to pretty print a haystack in our custom errors. The general intention is we use @PrettyPrintHaystack@
  -- to define a more specific way of pretty printing our error information for each kind that we care about
  data PrettyPrintInfo = PrettyPrintInfo
    { _needleName :: ErrorMessage
    , _haystackName :: ErrorMessage
    , _haystackPrettyPrint :: ErrorMessage
    }
  
  -- | 'PrettyPrintHaystack' allows us to use the kind of our haystack to come up
  -- with nicer errors. It is implemented as an open type family for dependency reasons
  type family PrettyPrintHaystack (haystack :: [(Symbol, k)]) :: PrettyPrintInfo
  
  -- | @DefaultPrettyPrinter@ provides a default we can use for kinds that don't provide an instance of @PrettyPrintInfo@,
  -- although that should generally only be accidental
  type family DefaultPrettyPrinter (haystack :: [(Symbol, k)]) :: PrettyPrintInfo where
    DefaultPrettyPrinter (haystack :: [(Symbol, k)]) = 'PrettyPrintInfo
      ('Text "some kind without a PrettyPrintHaystack instance ("  ':<>: 'ShowType k ':<>: 'Text ")")
      ('Text "associative list of that kind ([(Symbol, "  ':<>: 'ShowType k ':<>: 'Text ")])")
      ('ShowType (Sort (MapFst haystack)))
  
  {-| @HasIn fields (alias ::: field)@ is a constraint that proves that
  @fields@ has a field of @alias ::: field@. It is used in @UPDATE@s to
  choose which subfields to update.
  -}
  class HasIn fields field where
  instance (Has alias fields field) => HasIn fields (alias ::: field) where
  
  -- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer
  -- a list of @subfields@.
  class
    ( SOP.All KnownSymbol aliases
    ) => HasAll
      (aliases :: [Symbol])
      (fields :: [(Symbol,kind)])
      (subfields :: [(Symbol,kind)])
      | aliases fields -> subfields where
  instance {-# OVERLAPPING #-} HasAll '[] fields '[]
  instance {-# OVERLAPPABLE #-}
    (Has alias fields field, HasAll aliases fields subfields)
    => HasAll (alias ': aliases) fields (alias ::: field ': subfields)
  
  -- | Analagous to `IsLabel`, the constraint
  -- `IsQualified` defines `!` for a column alias qualified
  -- by a table alias.
  class IsQualified qualifier alias expression where
    (!) :: Alias qualifier -> Alias alias -> expression
    infixl 9 !
  instance IsQualified qualifier alias (Alias qualifier, Alias alias) where
    (!) = (,)
  
  {-| `QualifiedAlias`es enables multi-schema support by allowing a reference
  to a `Squeal.PostgreSQL.Type.Schema.Table`, `Squeal.PostgreSQL.Type.Schema.Typedef`
  or `Squeal.PostgreSQL.Type.Schema.View` to be qualified by their schemas. By default,
  a qualifier of @public@ is provided.
  
  >>> :{
  let
    alias1 :: QualifiedAlias "sch" "tab"
    alias1 = #sch ! #tab
    alias2 :: QualifiedAlias "public" "vw"
    alias2 = #vw
  in printSQL alias1 >> printSQL alias2
  :}
  "sch"."tab"
  "vw"
  -}
  data QualifiedAlias (qualifier :: Symbol) (alias :: Symbol) = QualifiedAlias
    deriving (Eq,GHC.Generic,Ord,Show,NFData)
  instance (q ~ q', a ~ a') => IsQualified q a (QualifiedAlias q' a') where
    _ ! _ = QualifiedAlias
  instance (q' ~ "public", a ~ a') => IsLabel a (QualifiedAlias q' a') where
    fromLabel = QualifiedAlias
  instance (q0 ~ q1, a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
    IsQualified q0 a0 (Aliased (QualifiedAlias q1) (a1 ::: a2)) where
      _ ! _ = QualifiedAlias `As` Alias
  instance (q ~ "public", a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
    IsLabel a0 (Aliased (QualifiedAlias q) (a1 ::: a2)) where
      fromLabel = QualifiedAlias `As` Alias
  
  instance (KnownSymbol q, KnownSymbol a)
    => RenderSQL (QualifiedAlias q a) where
      renderSQL _ =
        let
          qualifier = renderSQL (Alias @q)
          alias = renderSQL (Alias @a)
        in
          if qualifier == "\"public\"" then alias else qualifier <> "." <> alias
  