{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# LANGUAGE ExplicitNamespaces   #-}
{-# LANGUAGE UndecidableInstances #-}

module Servant.Zeppelin.Client
  ( projectDependency
  , DepClient(..)
  -- * Re-exports
  , SideLoaded(..)
  , SideLoad
  , SBool
  ) where

import           Data.Aeson
import           Data.Functor.Identity
import           Data.Kind
import           Data.Proxy
import           Data.Singletons.Prelude hiding ((:>))
import           Data.Singletons.TypeLits
import qualified Data.Text                as T
import           Servant.API
import           Servant.Client
import           Servant.Common.Req

import           Servant.Zeppelin
import           Servant.Zeppelin.Internal.Types

--------------------------------------------------------------------------------
-- FromJSON Instances
--------------------------------------------------------------------------------

instance FromJSON (DependencyList Identity '[] '[]) where
  parseJSON (Object _) = return NilDeps
  -- this can't actually happen.
  parseJSON _ = fail "Nil dependency list should be the empty object."

instance ( FromJSON (DependencyList Identity ds ds)
         , KnownSymbol (NamedDependency d)
         , FromJSON d
         ) => FromJSON (DependencyList Identity (d : ds) (d : ds)) where
  parseJSON o@(Object v) = do
    d <- v .: (T.pack . symbolVal $ Proxy @(NamedDependency d))
    ds <- parseJSON o
    return $ d :&: ds
  parseJSON _  = fail "Failed to parse a dependency."

instance ( FromJSON (DependencyList Identity ds ds)
         , FromJSON a
         ) => FromJSON (SideLoaded a ds) where
  parseJSON (Object v') = do
        a <- v' .: "data"
        ds <- v' .: "dependencies"
        return $ SideLoaded a ds
  parseJSON _ = fail "Could not parse dependencies."

--------------------------------------------------------------------------------
-- HList Accessors
--------------------------------------------------------------------------------

-- | 'ProjectDependency' @bs b' allows you to project to a dependency type from
-- a 'DependencyList'. If 'b' in 'bs', type inference is used to project to 'b'.
-- For example:
--
-- > let (SideLoaded a deps) = s :: SideLoaded Album '[Person, [Photo]]
-- > personId . projectDependency $ deps :: PersonId
class ProjectDependency bs b where
  projectDependency :: forall fs m . DependencyList m bs fs -> b

instance {-# OVERLAPPING #-} ProjectDependency (b : bs) b where
  projectDependency (b :&: _) = b

instance {-# OVERLAPPABLE #-} ProjectDependency bs b =>  ProjectDependency (a : bs) b where
  projectDependency (_ :&: bs ) = projectDependency bs

--------------------------------------------------------------------------------
-- Dependent Client
--------------------------------------------------------------------------------

-- | 'DependentClient' is a wrapper around a dependently typed function that when
-- given a singleton 'STrue' has return type 'SideLoaded' @a deps@, and
-- when given 'SFalse' has return type @a@. For example:
--
-- > data Person =
-- >   Person { personId   :: PersonId
-- >          , personName :: String
-- >          } deriving (Eq, Show, Generic)
-- >
-- > instance FromJSON Person
-- >
-- > data Photo =
-- >   Photo { photoId      :: PhotoId
-- >         , photoCaption :: String
-- >         , artistId     :: PersonId
-- >         } deriving (Eq, Show, Generic)
-- >
-- > instance FromJSON Photo
-- >
-- > data Album =
-- >   Album { albumId     :: AlbumId
-- >         , albumName   :: String
-- >         , albumOwner  :: PersonId
-- >         , albumPhotos :: [PhotoId]
-- >         } deriving (Eq, Show, Generic)
-- >
-- > instance FromJSON Album
-- >
-- > type API = "albums" :> Capture "albumId" AlbumId
-- >                     :> Get '[JSON, PlainText] Album
-- >                     :> SideLoad '[Person, [Photo]]
-- >
-- > type AlbumDeps =  '[Person, [Photo]]
-- >
-- > getAlbumClientFull :: Manager
-- >                    -> BaseUrl
-- >                    -> AlbumId
-- >                    -> IO (Either ServantError (SideLoaded Album AlbumDeps))
-- > getAlbumClientFull m burl aid =
-- >   flip runClientM (ClientEnv m burl) $
-- >     runDepClient (client api aid) STrue
-- >
-- > getAlbumClient :: Manager
-- >                -> BaseUrl
-- >                -> AlbumId
-- >                -> IO (Either ServantError Album)
-- > getAlbumClient m burl aid =
-- >   flip runClientM (ClientEnv m burl) $
-- >     runDepClient (client api aid) SFalse

newtype DepClient (ix :: Bool -> *) (f :: Bool ~> Type) =
    DepClient {runDepClient :: forall (b :: Bool) . ix b -> Client (Apply f b)}

data SideLoadTerminal :: method -> status -> cts -> a -> deps -> (Bool ~> Type) where
  SideLoadTerminal :: SideLoadTerminal method status cts a deps b

type instance Apply (SideLoadTerminal method status cts a deps) b =
  If b (Verb method status cts (SideLoaded a deps)) (Verb method status cts a)

instance {-# OVERLAPPABLE #-}
         ( MimeUnrender JSON a
         , MimeUnrender JSON (SideLoaded a deps)
         , ReflectMethod method
         ) => HasClient (Verb method status cts a :> SideLoad deps) where

  type Client (Verb method status cts a :> SideLoad deps) = DepClient SBool (SideLoadTerminal method status cts a deps)
  clientWithRoute Proxy req = DepClient $ \sb ->
    case sb of
      STrue -> let req' = appendToQueryString "sideload" (Just "true") req
               in snd <$> performRequestCT (Proxy @JSON) method req'
      SFalse -> snd <$> performRequestCT (Proxy @JSON) method req
    where method = reflectMethod (Proxy @method)