{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE PolyKinds              #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeInType             #-}
{-# LANGUAGE TypeOperators          #-}

module Database.Bolt.Extras.DSL.Typed.Types where

import           Data.Kind                               (Constraint, Type)
import           Data.Text                               (Text)
import qualified Database.Bolt                           as B
import           GHC.Generics                            (Rep)
import           GHC.TypeLits                            (KnownSymbol, Symbol)

import qualified Database.Bolt.Extras.DSL                as UT

import           Database.Bolt.Extras.DSL.Typed.Families

{- $setup
>>> :set -XDeriveGeneric
>>> :set -XTypeApplications
>>> :set -XOverloadedLabels
>>> :load Database.Bolt.Extras.DSL.Typed.Instances
>>> import Data.Text (unpack)
>>> import GHC.Generics (Generic)
>>> import Database.Bolt.Extras (toCypher)
>>> toCypherN = putStrLn . unpack . toCypher  . nodeSelector
-}

-- | Class for Selectors that know type of their labels. This class is kind-polymorphic,
-- so that instances may select a specific collection of labels they support.
--
-- __NOTE__: Due to the way GHC orders type variables for class methods, it's more convenient
-- to use 'lbl' and 'prop' synonyms defined below, and 'withLabel' and 'withProp' methods
-- should be considered an implementation detail.
class SelectorLike (a :: k -> Type) where
  -- | This constraint checks that current collection of types supports adding one more.
  type CanAddType (types :: k) :: Constraint

  -- | This type family implements adding a new type (of label) to the collection.
  --
  -- Injectivity annotation is required to make type inference possible.
  type AddType (types :: k) (typ :: Type) = (result :: k) | result -> types typ

  -- | This constraint checks that field with this name has correct type in the collection
  -- of labels.
  type HasField (types :: k) (field :: Symbol) (typ :: Type) :: Constraint

  -- | This constraint checks that field with this name exists in the collection, with any type.
  type HasField' (types :: k) (field :: Symbol) :: Constraint

  -- | Set an identifier — Cypher variable name.
  withIdentifier :: Text -> a types -> a types

  -- | Add a new label, if possible.
  withLabel
    :: CanAddType types
    => KnownSymbol (GetTypeName (Rep typ))
    => a types
    -> a (AddType types typ)

  -- | Add a property with value, checking that such property exists.
  withProp
    :: HasField types field typ
    => B.IsValue typ
    => (SymbolS field, typ)
    -> a types
    -> a types

  -- | Add a property as named parameter (@$foo@). Only checks that given property exists,
  -- no matter its type.
  withParam
    :: HasField' types field
    => (SymbolS field, Text)
    -> a types
    -> a types

-- | Constraint for types that may be used with 'lbl'.
type LabelConstraint (typ :: Type) = KnownSymbol (GetTypeName (Rep typ))

-- | Synonym for 'withLabel' with label type variable as first one, enabling @lbl \@Foo@ type
-- application syntax.
lbl
  :: forall (typ :: Type) k (types :: k) (a :: k -> Type)
  .  SelectorLike a
  => CanAddType types
  => KnownSymbol (GetTypeName (Rep typ))
  => a types
  -> a (AddType types typ)
lbl :: a types -> a (AddType types typ)
lbl = a types -> a (AddType types typ)
forall k (a :: k -> *) (types :: k) typ.
(SelectorLike a, CanAddType types,
 KnownSymbol (GetTypeName (Rep typ))) =>
a types -> a (AddType types typ)
withLabel

-- | Shorter synonym for 'withProp'.
--
-- Properties of type @Maybe a@ are treated as properties of type @a@, since there is no difference
-- between the two in Cypher.
--
-- >>> data Foo = Foo { foo :: Int, bar :: Maybe String } deriving Generic
-- >>> toCypherN $ defN .& lbl @Foo .& prop (#foo =: 42)
-- (:Foo{foo:42})
-- >>> toCypherN $ defN .& lbl @Foo .& prop (#bar =: "hello")
-- (:Foo{bar:"hello"})
prop
  :: forall (field :: Symbol) k (a :: k -> Type) (types :: k) (typ :: Type)
  .  SelectorLike a
  => HasField types field typ
  => B.IsValue typ
  => (SymbolS field, typ) -- ^ Field name along with its value. This pair should be constructed with '=:'.
  -> a types -> a types
prop :: (SymbolS field, typ) -> a types -> a types
prop = (SymbolS field, typ) -> a types -> a types
forall k (a :: k -> *) (types :: k) (field :: Symbol) typ.
(SelectorLike a, HasField types field typ, IsValue typ) =>
(SymbolS field, typ) -> a types -> a types
withProp

-- | A variant of 'prop' that accepts values in @Maybe@. If given @Nothing@, does nothing.
--
-- This works both for properties with @Maybe@ and without.
--
-- >>> data Foo = Foo { foo :: Int, bar :: Maybe String } deriving Generic
-- >>> toCypherN $ defN .& lbl @Foo .& propMaybe (#foo =: Just 42)
-- (:Foo{foo:42})
-- >>> toCypherN $ defN .& lbl @Foo .& propMaybe (#bar =: Nothing)
-- (:Foo)
propMaybe
  :: forall (field :: Symbol) k (a :: k -> Type) (types :: k) (typ :: Type)
  .  SelectorLike a
  => HasField types field typ
  => B.IsValue typ
  => (SymbolS field, Maybe typ)
  -> a types -> a types
propMaybe :: (SymbolS field, Maybe typ) -> a types -> a types
propMaybe (SymbolS field
name, Just typ
val) = (SymbolS field, typ) -> a types -> a types
forall k (a :: k -> *) (types :: k) (field :: Symbol) typ.
(SelectorLike a, HasField types field typ, IsValue typ) =>
(SymbolS field, typ) -> a types -> a types
withProp (SymbolS field
name, typ
val)
propMaybe (SymbolS field, Maybe typ)
_                = a types -> a types
forall a. a -> a
id

-- | Shorter synonym for 'withParam'.
--
-- >>> data Foo = Foo { foo :: Int, bar :: Maybe String } deriving Generic
-- >>> toCypherN $ defN .& lbl @Foo .& param (#foo =: "foo")
-- (:Foo{foo:$foo})
-- >>> toCypherN $ defN .& lbl @Foo .& prop (#foo =: 42) .& param (#bar =: "bar")
-- (:Foo{foo:42,bar:$bar})
-- >>> toCypherN $ defN .& lbl @Foo .& param (#baz =: "baz")
-- ...
-- ... There is no field "baz" in any of the records
-- ... '[Foo]
-- ...
--
-- __NOTE__: this will add @$@ symbol to parameter name automatically.
param
  :: forall (field :: Symbol) k (a :: k -> Type) (types :: k)
  .  SelectorLike a
  => HasField' types field
  => (SymbolS field, Text)
  -> a types -> a types
param :: (SymbolS field, Text) -> a types -> a types
param = (SymbolS field, Text) -> a types -> a types
forall k (a :: k -> *) (types :: k) (field :: Symbol).
(SelectorLike a, HasField' types field) =>
(SymbolS field, Text) -> a types -> a types
withParam

-- | Smart constructor for type-level tuples, to avoid writing @'("foo", Int)@ with extra tick.
type (=:) (a :: k) (b :: l) = '(a, b)

-- | Smart constructor for a pair of field name and its value. To be used with @OverloadedLabels@:
--
-- > #uuid =: "123"
(=:) :: forall (field :: Symbol) (typ :: Type). SymbolS field -> typ -> (SymbolS field, typ)
=: :: SymbolS field -> typ -> (SymbolS field, typ)
(=:) = (,)

-- | A wrapper around 'Database.Extras.DSL.NodeSelector' with phantom type.
--
-- Node selectors remember arbitrary number of labels in a type-level list.
newtype NodeSelector (typ :: [Type])
  = NodeSelector
      { NodeSelector typ -> NodeSelector
nodeSelector :: UT.NodeSelector -- ^ Convert to untyped 'UT.NodeSelector'.
      }
    deriving (Int -> NodeSelector typ -> ShowS
[NodeSelector typ] -> ShowS
NodeSelector typ -> String
(Int -> NodeSelector typ -> ShowS)
-> (NodeSelector typ -> String)
-> ([NodeSelector typ] -> ShowS)
-> Show (NodeSelector typ)
forall (typ :: [*]). Int -> NodeSelector typ -> ShowS
forall (typ :: [*]). [NodeSelector typ] -> ShowS
forall (typ :: [*]). NodeSelector typ -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeSelector typ] -> ShowS
$cshowList :: forall (typ :: [*]). [NodeSelector typ] -> ShowS
show :: NodeSelector typ -> String
$cshow :: forall (typ :: [*]). NodeSelector typ -> String
showsPrec :: Int -> NodeSelector typ -> ShowS
$cshowsPrec :: forall (typ :: [*]). Int -> NodeSelector typ -> ShowS
Show, NodeSelector typ -> NodeSelector typ -> Bool
(NodeSelector typ -> NodeSelector typ -> Bool)
-> (NodeSelector typ -> NodeSelector typ -> Bool)
-> Eq (NodeSelector typ)
forall (typ :: [*]). NodeSelector typ -> NodeSelector typ -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeSelector typ -> NodeSelector typ -> Bool
$c/= :: forall (typ :: [*]). NodeSelector typ -> NodeSelector typ -> Bool
== :: NodeSelector typ -> NodeSelector typ -> Bool
$c== :: forall (typ :: [*]). NodeSelector typ -> NodeSelector typ -> Bool
Eq)

-- | A wrapper around 'Database.Extras.DSL.RelSelector' with phantom type.
--
-- Relationship selectors remember at most one label in a type-level @Maybe@.
newtype RelSelector (typ :: Maybe Type)
  = RelSelector
      { RelSelector typ -> RelSelector
relSelector :: UT.RelSelector -- ^ Convert to untyped 'UT.RelSelector'.
      }
    deriving (Int -> RelSelector typ -> ShowS
[RelSelector typ] -> ShowS
RelSelector typ -> String
(Int -> RelSelector typ -> ShowS)
-> (RelSelector typ -> String)
-> ([RelSelector typ] -> ShowS)
-> Show (RelSelector typ)
forall (typ :: Maybe *). Int -> RelSelector typ -> ShowS
forall (typ :: Maybe *). [RelSelector typ] -> ShowS
forall (typ :: Maybe *). RelSelector typ -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RelSelector typ] -> ShowS
$cshowList :: forall (typ :: Maybe *). [RelSelector typ] -> ShowS
show :: RelSelector typ -> String
$cshow :: forall (typ :: Maybe *). RelSelector typ -> String
showsPrec :: Int -> RelSelector typ -> ShowS
$cshowsPrec :: forall (typ :: Maybe *). Int -> RelSelector typ -> ShowS
Show, RelSelector typ -> RelSelector typ -> Bool
(RelSelector typ -> RelSelector typ -> Bool)
-> (RelSelector typ -> RelSelector typ -> Bool)
-> Eq (RelSelector typ)
forall (typ :: Maybe *). RelSelector typ -> RelSelector typ -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RelSelector typ -> RelSelector typ -> Bool
$c/= :: forall (typ :: Maybe *). RelSelector typ -> RelSelector typ -> Bool
== :: RelSelector typ -> RelSelector typ -> Bool
$c== :: forall (typ :: Maybe *). RelSelector typ -> RelSelector typ -> Bool
Eq)

newtype SymbolS (s :: Symbol) = SymbolS { SymbolS s -> String
getSymbol :: String }
  deriving (Int -> SymbolS s -> ShowS
[SymbolS s] -> ShowS
SymbolS s -> String
(Int -> SymbolS s -> ShowS)
-> (SymbolS s -> String)
-> ([SymbolS s] -> ShowS)
-> Show (SymbolS s)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: Symbol). Int -> SymbolS s -> ShowS
forall (s :: Symbol). [SymbolS s] -> ShowS
forall (s :: Symbol). SymbolS s -> String
showList :: [SymbolS s] -> ShowS
$cshowList :: forall (s :: Symbol). [SymbolS s] -> ShowS
show :: SymbolS s -> String
$cshow :: forall (s :: Symbol). SymbolS s -> String
showsPrec :: Int -> SymbolS s -> ShowS
$cshowsPrec :: forall (s :: Symbol). Int -> SymbolS s -> ShowS
Show)

-- | An empty 'NodeSelector'.
defN :: NodeSelector '[]
defN :: NodeSelector '[]
defN = NodeSelector -> NodeSelector '[]
forall (typ :: [*]). NodeSelector -> NodeSelector typ
NodeSelector NodeSelector
UT.defaultNode

-- | An empty 'RelSelector'.
defR :: RelSelector 'Nothing
defR :: RelSelector 'Nothing
defR = RelSelector -> RelSelector 'Nothing
forall (typ :: Maybe *). RelSelector -> RelSelector typ
RelSelector RelSelector
UT.defaultRel

infixl 3 .&
-- | This is the same as 'Data.Function.&', but with higher precedence, so that it binds before
-- path combinators.
(.&) :: a -> (a -> b) -> b
a
a .& :: a -> (a -> b) -> b
.& a -> b
f = a -> b
f a
a
{-# INLINE (.&) #-}

infixl 2 !->:
-- | See 'UT.:!->:'. This combinator forgets type-level information from the selectors.
(!->:) :: RelSelector a -> NodeSelector b -> UT.PathPart
RelSelector RelSelector
r !->: :: RelSelector a -> NodeSelector b -> PathPart
!->: NodeSelector NodeSelector
n = RelSelector
r RelSelector -> NodeSelector -> PathPart
UT.:!->: NodeSelector
n

infixl 2 !-:
-- | See 'UT.:!-:'. This combinator forgets type-level information from the selectors.
(!-:) :: RelSelector a -> NodeSelector b -> UT.PathPart
RelSelector RelSelector
r !-: :: RelSelector a -> NodeSelector b -> PathPart
!-: NodeSelector NodeSelector
n = RelSelector
r RelSelector -> NodeSelector -> PathPart
UT.:!-: NodeSelector
n

infixl 1 -:
-- | See 'UT.-:'. This combinator forgets type-level information from the selectors.
(-:) :: NodeSelector a -> UT.PathPart -> UT.PathSelector
NodeSelector NodeSelector
ns -: :: NodeSelector a -> PathPart -> PathSelector
-: PathPart
pp = NodeSelector -> PathSelector
UT.P NodeSelector
ns PathSelector -> PathPart -> PathSelector
UT.:-!: PathPart
pp

infixl 1 <-:
-- | See 'UT.<-:'. This combinator forgets type-level information from the selectors.
(<-:) :: NodeSelector a -> UT.PathPart -> UT.PathSelector
NodeSelector NodeSelector
ns <-: :: NodeSelector a -> PathPart -> PathSelector
<-: PathPart
pp = NodeSelector -> PathSelector
UT.P NodeSelector
ns PathSelector -> PathPart -> PathSelector
UT.:<-!: PathPart
pp

-- | See 'UT.P'. This combinator forgets type-level information from the selectors.
p :: NodeSelector a -> UT.PathSelector
p :: NodeSelector a -> PathSelector
p (NodeSelector NodeSelector
ns) = NodeSelector -> PathSelector
UT.P NodeSelector
ns