{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Internal.Utils
  ( capitalize,
    nameSpaceField,
    nameSpaceType,
    capitalTypeName,
    Collection (..),
    Selectable (..),
    FromElems (..),
    Failure (..),
    KeyOf (..),
    toPair,
    selectBy,
    mapFst,
    mapSnd,
    mapTuple,
    traverseCollection,
    prop,
    stripFieldNamespace,
    stripConstructorNamespace,
    fromLBS,
    toLBS,
    mergeT,
    Elems (..),
    size,
    failOnDuplicates,
  )
where

import Data.ByteString.Lazy (ByteString)
import Data.Char
  ( toLower,
    toUpper,
  )
import qualified Data.HashMap.Lazy as HM
import Data.Morpheus.Error.NameCollision (NameCollision (..))
import Data.Morpheus.Ext.Elems (Elems (..), size)
import Data.Morpheus.Ext.Failure (Failure (..))
import Data.Morpheus.Ext.KeyOf (KeyOf (..), toPair)
import Data.Morpheus.Ext.Map
  ( ResolutionT,
    fromListT,
    runResolutionT,
  )
import Data.Morpheus.Types.Internal.AST.Base
  ( FieldName,
    FieldName (..),
    Token,
    TypeName (..),
    ValidationErrors,
  )
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
import Instances.TH.Lift ()
import Relude hiding
  ( ByteString,
    decodeUtf8,
    encodeUtf8,
  )

toLBS :: Text -> ByteString
toLBS :: Text -> ByteString
toLBS = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
LT.fromStrict

fromLBS :: ByteString -> Text
fromLBS :: ByteString -> Text
fromLBS = Text -> Text
LT.toStrict (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8

prop :: (b -> b -> m b) -> (a -> b) -> a -> a -> m b
prop :: (b -> b -> m b) -> (a -> b) -> a -> a -> m b
prop b -> b -> m b
f a -> b
fSel a
a1 a
a2 = b -> b -> m b
f (a -> b
fSel a
a1) (a -> b
fSel a
a2)

nameSpaceType :: [FieldName] -> TypeName -> TypeName
nameSpaceType :: [FieldName] -> TypeName -> TypeName
nameSpaceType [FieldName]
list (TypeName Text
name) = Text -> TypeName
TypeName (Text -> TypeName) -> ([Text] -> Text) -> [Text] -> TypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat ([Text] -> TypeName) -> [Text] -> TypeName
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
capitalize ((FieldName -> Text) -> [FieldName] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldName -> Text
readName [FieldName]
list [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
name])

nameSpaceField :: TypeName -> FieldName -> FieldName
nameSpaceField :: TypeName -> FieldName -> FieldName
nameSpaceField (TypeName Text
nSpace) (FieldName Text
name) = Text -> FieldName
FieldName (Text -> Text
uncapitalize Text
nSpace Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
capitalize Text
name)

dropPrefix :: TypeName -> String -> String
dropPrefix :: TypeName -> String -> String
dropPrefix (TypeName Text
name) = Int -> String -> String
forall a. Int -> [a] -> [a]
drop (Text -> Int
T.length Text
name)

stripConstructorNamespace :: TypeName -> String -> String
stripConstructorNamespace :: TypeName -> String -> String
stripConstructorNamespace = TypeName -> String -> String
dropPrefix

stripFieldNamespace :: TypeName -> String -> String
stripFieldNamespace :: TypeName -> String -> String
stripFieldNamespace TypeName
prefix = String -> String
__uncapitalize (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> String -> String
dropPrefix TypeName
prefix
  where
    __uncapitalize :: String -> String
__uncapitalize [] = []
    __uncapitalize (Char
x : String
xs) = Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs

capitalize :: Text -> Text
capitalize :: Text -> Text
capitalize = (Char -> Char) -> Text -> Text
mapFstChar Char -> Char
toUpper

uncapitalize :: Text -> Text
uncapitalize :: Text -> Text
uncapitalize = (Char -> Char) -> Text -> Text
mapFstChar Char -> Char
toLower

mapFstChar :: (Char -> Char) -> Token -> Token
mapFstChar :: (Char -> Char) -> Text -> Text
mapFstChar Char -> Char
f Text
x
  | Text -> Bool
T.null Text
x = Text
x
  | Bool
otherwise = Char -> Text
T.singleton (Char -> Char
f (Char -> Char) -> Char -> Char
forall a b. (a -> b) -> a -> b
$ Text -> Char
T.head Text
x) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.tail Text
x

capitalTypeName :: FieldName -> TypeName
capitalTypeName :: FieldName -> TypeName
capitalTypeName = Text -> TypeName
TypeName (Text -> TypeName) -> (FieldName -> Text) -> FieldName -> TypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
capitalize (Text -> Text) -> (FieldName -> Text) -> FieldName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Text
readName

--(KEY v ~ k) =>
class Collection a coll | coll -> a where
  empty :: coll
  singleton :: a -> coll

instance Collection a [a] where
  empty :: [a]
empty = []
  singleton :: a -> [a]
singleton a
x = [a
x]

instance KeyOf k v => Collection v (HashMap k v) where
  empty :: HashMap k v
empty = HashMap k v
forall k v. HashMap k v
HM.empty
  singleton :: v -> HashMap k v
singleton v
x = k -> v -> HashMap k v
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton (v -> k
forall k a. KeyOf k a => a -> k
keyOf v
x) v
x

class Selectable k a c | c -> a where
  selectOr :: d -> (a -> d) -> k -> c -> d

  member :: k -> c -> Bool
  member = Bool -> (a -> Bool) -> k -> c -> Bool
forall k a c d. Selectable k a c => d -> (a -> d) -> k -> c -> d
selectOr Bool
False (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True)

instance KeyOf k a => Selectable k a [a] where
  selectOr :: d -> (a -> d) -> k -> [a] -> d
selectOr d
fb a -> d
f k
key [a]
lib = d -> (a -> d) -> Maybe a -> d
forall b a. b -> (a -> b) -> Maybe a -> b
maybe d
fb a -> d
f ((a -> Bool) -> [a] -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((k
key k -> k -> Bool
forall a. Eq a => a -> a -> Bool
==) (k -> Bool) -> (a -> k) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> k
forall k a. KeyOf k a => a -> k
keyOf) [a]
lib)

instance KeyOf k a => Selectable k a (HashMap k a) where
  selectOr :: d -> (a -> d) -> k -> HashMap k a -> d
selectOr d
fb a -> d
f k
key HashMap k a
lib = d -> (a -> d) -> Maybe a -> d
forall b a. b -> (a -> b) -> Maybe a -> b
maybe d
fb a -> d
f (k -> HashMap k a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup k
key HashMap k a
lib)

selectBy :: (Failure e m, Selectable k a c, Monad m) => e -> k -> c -> m a
selectBy :: e -> k -> c -> m a
selectBy e
err = m a -> (a -> m a) -> k -> c -> m a
forall k a c d. Selectable k a c => d -> (a -> d) -> k -> c -> d
selectOr (e -> m a
forall error (f :: * -> *) v. Failure error f => error -> f v
failure e
err) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

traverseCollection ::
  ( Monad f,
    KeyOf k b,
    Elems a (t a),
    FromElems f b (t' b),
    Failure ValidationErrors f
  ) =>
  (a -> f b) ->
  t a ->
  f (t' b)
traverseCollection :: (a -> f b) -> t a -> f (t' b)
traverseCollection a -> f b
f t a
a = [b] -> f (t' b)
forall k (m :: k -> *) a (coll :: k).
FromElems m a coll =>
[a] -> m coll
fromElems ([b] -> f (t' b)) -> f [b] -> f (t' b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (a -> f b) -> [a] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f (t a -> [a]
forall a coll. Elems a coll => coll -> [a]
elems t a
a)

-- list Like Collections
class FromElems m a coll | coll -> a where
  fromElems :: [a] -> m coll

mergeT :: (KeyOf k a, Monad m, Elems a c) => c -> c -> ResolutionT k a c m c
mergeT :: c -> c -> ResolutionT k a c m c
mergeT c
x c
y = [(k, a)] -> ResolutionT k a c m c
forall (m :: * -> *) k a coll.
(Monad m, Eq k, Hashable k) =>
[(k, a)] -> ResolutionT k a coll m coll
fromListT (a -> (k, a)
forall k a. KeyOf k a => a -> (k, a)
toPair (a -> (k, a)) -> [a] -> [(k, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (c -> [a]
forall a coll. Elems a coll => coll -> [a]
elems c
x [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> c -> [a]
forall a coll. Elems a coll => coll -> [a]
elems c
y))

instance
  ( NameCollision a,
    Failure ValidationErrors m,
    KeyOf k a,
    Monad m
  ) =>
  FromElems m a (HashMap k a)
  where
  fromElems :: [a] -> m (HashMap k a)
fromElems [a]
xs = ResolutionT k a (HashMap k a) m (HashMap k a)
-> ([(k, a)] -> HashMap k a)
-> (NonEmpty a -> m a)
-> m (HashMap k a)
forall k a coll (m :: * -> *) b.
ResolutionT k a coll m b
-> ([(k, a)] -> coll) -> (NonEmpty a -> m a) -> m b
runResolutionT ([(k, a)] -> ResolutionT k a (HashMap k a) m (HashMap k a)
forall (m :: * -> *) k a coll.
(Monad m, Eq k, Hashable k) =>
[(k, a)] -> ResolutionT k a coll m coll
fromListT (a -> (k, a)
forall k a. KeyOf k a => a -> (k, a)
toPair (a -> (k, a)) -> [a] -> [(k, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
xs)) [(k, a)] -> HashMap k a
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList NonEmpty a -> m a
forall (m :: * -> *) a.
(Failure ValidationErrors m, NameCollision a) =>
NonEmpty a -> m a
failOnDuplicates

-- Merge Object with of Failure as an Option

mapFst :: (a -> a') -> (a, b) -> (a', b)
mapFst :: (a -> a') -> (a, b) -> (a', b)
mapFst a -> a'
f (a
a, b
b) = (a -> a'
f a
a, b
b)

mapSnd :: (b -> b') -> (a, b) -> (a, b')
mapSnd :: (b -> b') -> (a, b) -> (a, b')
mapSnd b -> b'
f (a
a, b
b) = (a
a, b -> b'
f b
b)

mapTuple :: (a -> a') -> (b -> b') -> (a, b) -> (a', b')
mapTuple :: (a -> a') -> (b -> b') -> (a, b) -> (a', b')
mapTuple a -> a'
f1 b -> b'
f2 (a
a, b
b) = (a -> a'
f1 a
a, b -> b'
f2 b
b)

failOnDuplicates :: (Failure ValidationErrors m, NameCollision a) => NonEmpty a -> m a
failOnDuplicates :: NonEmpty a -> m a
failOnDuplicates (a
x :| [a]
xs)
  | [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  | Bool
otherwise = ValidationErrors -> m a
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (ValidationErrors -> m a) -> ValidationErrors -> m a
forall a b. (a -> b) -> a -> b
$ (a -> ValidationError) -> [a] -> ValidationErrors
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> ValidationError
forall a. NameCollision a => a -> ValidationError
nameCollision (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs)