{-# LANGUAGE
    CPP
  , DataKinds
  , FlexibleContexts
  , GADTs
  , GeneralizedNewtypeDeriving
  , KindSignatures
  , ScopedTypeVariables
  , StandaloneDeriving
  , TemplateHaskell
  , TypeFamilies
  , TypeOperators
  , UndecidableInstances
  #-}
module Rest.Dictionary.Types
  (
  -- * Possible I/O formats.

    Format (..)

  -- * The dictionary type.

  , Dict
  , headers
  , params
  , inputs
  , outputs
  , errors

  , empty
  , Modifier

  -- * Dictionary aspects.

  , Ident (..)
  , Header (..)
  , Param (..)
  , Input (..)
  , Output (..)
  , Error (..)
  , Xml (..)
  , Json (..)

  -- * Plural dictionaries.

  , Dicts (..)
  , dicts
  , getDicts
  , getDicts_
  , modDicts
  , Inputs
  , Outputs
  , Errors
  , SomeError (..)

  , FromMaybe

  )

where

import Data.Aeson
import Data.ByteString.Lazy (ByteString)
import Data.JSON.Schema
import Data.Label ((:->), lens)
import Data.Label.Derive
import Data.Text.Lazy (Text)
import Data.Typeable
import Network.Multipart (BodyPart)
import Text.XML.HXT.Arrow.Pickle

import Rest.Error
import Rest.Info
import Rest.Types.Void

-- | The `Format` datatype enumerates all input and output formats we might recognize.

data Format
  = XmlFormat
  | JsonFormat
  | StringFormat
  | FileFormat
  | MultipartFormat
  | NoFormat
  deriving (Eq, Ord, Enum, Bounded, Show)

-- | The explicit dictionary `Ident` describes how to translate a resource
-- identifier (originating from a request URI) to a Haskell value. We allow
-- plain `String` identifiers or all Haskell types that have a `Read` instance.

data Ident id where
  ReadId   :: (Info id, Read id) => Ident id
  StringId ::                       Ident String

deriving instance Show (Ident id)

-- | The explicit dictionary `Header` describes how to translate HTTP request
-- headers to some Haskell value. The first field in the `Header` constructor
-- is a white list of headers we can recognize, used in generic validation and
-- for generating documentation. The second field is a custom parser that can
-- fail with a `DataError` or can produce a some value. When explicitly not
-- interested in the headers we can use `NoHeader`.

data Header h where
  NoHeader    ::                                                       Header ()
  Header      :: [String] -> ([Maybe String] -> Either DataError h) -> Header h
  TwoHeaders  :: Header h -> Header k                               -> Header (h,k)

instance Show (Header h) where
  showsPrec _ NoHeader         = showString "NoHeader"
  showsPrec n (Header hs _)    = showParen (n > 9) (showString "Header " . showsPrec 10 hs)
  showsPrec n (TwoHeaders h k) = showParen (n > 9) ( showString "TwoHeaders "
                                                   . showsPrec 10 h
                                                   . showString " "
                                                   . showsPrec 10 k
                                                   )

-- | The explicit dictionary `Param` describes how to translate the request
-- parameters to some Haskell value. The first field in the `Param`
-- constructor is a white list of paramters we can recognize, used in generic
-- validation and for generating documentation. The second field is a custom
-- parser that can fail with a `DataError` or can produce a some value. When
-- explicitly not interested in the parameters we can use `NoParam`.

data Param p where
  NoParam   ::                                                       Param ()
  Param     :: [String] -> ([Maybe String] -> Either DataError p) -> Param p
  TwoParams :: Param p -> Param q                                 -> Param (p, q)

instance Show (Param p) where
  showsPrec _ NoParam         = showString "NoParam"
  showsPrec n (Param ns _)    = showParen (n > 9) (showString "Param " . showsPrec 10 ns)
  showsPrec n (TwoParams p q) = showParen (n > 9) ( showString "TwoParams "
                                                  . showsPrec 10 p
                                                  . showString " "
                                                  . showsPrec 10 q
                                                  )

-- | The explicit dictionary `Input` describes how to translate the request
-- body into some Haskell value. We currently use a constructor for every
-- combination of input type to output type. For example, we can use XML input
-- in multiple ways, parsed, as plain/text or as raw bytes, depending on the
-- needs of the backend resource.

data Input i where
  JsonI          :: (Typeable i, FromJSON i, JSONSchema i) => Input i
  ReadI          :: (Info i, Read i, Show i)               => Input i
  StringI        ::                                           Input String
  FileI          ::                                           Input ByteString
  XmlI           :: (Typeable i, XmlPickler i)             => Input i
  XmlTextI       ::                                           Input Text
  RawJsonI       ::                                           Input ByteString
  RawXmlI        ::                                           Input ByteString
  RawJsonAndXmlI ::                                           Input (Either Json Xml)

deriving instance Show (Input i)
deriving instance Eq   (Input i)
deriving instance Ord  (Input i)

-- | The explicit dictionary `Output` describes how to translate some Haskell
-- value to a response body. We currently use a constructor for every
-- combination of input type to output type.

data Output o where
  FileO          ::                                         Output (ByteString, String, Bool)
  RawJsonO       ::                                         Output ByteString
  RawXmlO        ::                                         Output ByteString
  JsonO          :: (Typeable o, ToJSON o, JSONSchema o) => Output o
  XmlO           :: (Typeable o, XmlPickler o)           => Output o
  StringO        ::                                         Output String
  RawJsonAndXmlO ::                                         Output ByteString
  MultipartO     ::                                         Output [BodyPart]

deriving instance Show (Output o)
deriving instance Eq   (Output o)
deriving instance Ord  (Output o)

-- | Newtype around ByteStrings used in `RawJsonAndXmlI` to add some
-- protection from parsing the input incorrectly.
newtype Xml = Xml { unXml :: ByteString }
  deriving (Eq, Show)

-- | Newtype around ByteStrings used in `RawJsonAndXmlI` to add some
-- protection from parsing the input incorrectly.
newtype Json = Json { unJson :: ByteString }
  deriving (Eq, Show)

-- | The explicit dictionary `Error` describes how to translate some Haskell
-- error value to a response body.

data Error e where
  JsonE   :: (ToResponseCode e, Typeable e, ToJSON e, JSONSchema e) => Error e
  XmlE    :: (ToResponseCode e, Typeable e, XmlPickler e)           => Error e

deriving instance Show (Error e)
deriving instance Eq   (Error e)
deriving instance Ord  (Error e)

type Inputs  i = Dicts Input  i
type Outputs o = Dicts Output o
type Errors  e = Dicts Error  e

data Dicts f a where
  None  :: Dicts f 'Nothing
  Dicts :: [f a] -> Dicts f ('Just a)

-- Needs UndecidableInstances
deriving instance Show (f (FromMaybe Void a)) => Show (Dicts f a)

#if GLASGOW_HASKELL < 708
type family FromMaybe d (m :: Maybe *) :: *
type instance FromMaybe b 'Nothing  = b
type instance FromMaybe b ('Just a) = a
#else
type family FromMaybe d (m :: Maybe *) :: * where
  FromMaybe b Nothing  = b
  FromMaybe b (Just a) = a
#endif

{-# DEPRECATED dicts "The modifier for this lens doesn't do anything when Dicts is None. Use getDicts and modDicts instead." #-}
dicts :: forall a o f. o ~ FromMaybe o a => Dicts f a :-> [f o]
dicts = lens get modify
  where
    get :: Dicts f a -> [f o]
    get None       = []
    get (Dicts ds) = ds
    modify :: ([f o] -> [f o]) -> Dicts f a -> Dicts f a
    modify _ None       = None
    modify f (Dicts ds) = Dicts (f ds)

-- | Get the list of dictionaries. If there are none, you get a [o].
-- If this is too polymorphic, try `getDicts_`.

getDicts :: o ~ FromMaybe o a => Dicts f a -> [f o]
getDicts None       = []
getDicts (Dicts ds) = ds

-- | Get the list of dictionaries. If there are none, you get a [()].
-- Sometimes useful to constraint the types if the element type of the
-- list isn't clear from the context.

getDicts_ :: o ~ FromMaybe () a => Dicts f a -> [f o]
getDicts_ None = []
getDicts_ (Dicts ds) = ds

modDicts :: (FromMaybe o i ~ o) => ([f o] -> [f o]) -> Dicts f i -> Dicts f ('Just o)
modDicts f None       = Dicts (f [])
modDicts f (Dicts ds) = Dicts (f ds)

-- | The `Dict` datatype containing sub-dictionaries for translation of
-- identifiers (i), headers (h), parameters (p), inputs (i), outputs (o), and
-- errors (e). Inputs, outputs and errors can have multiple associated
-- dictionaries.

fclabels [d|
  data Dict h p i o e = Dict
    { headers :: Header  h
    , params  :: Param   p
    , inputs  :: Inputs  i
    , outputs :: Outputs o
    , errors  :: Errors  e
    } deriving Show
  |]

-- | The empty dictionary, recognizing no types.

empty :: Dict () () 'Nothing 'Nothing 'Nothing
empty = Dict NoHeader NoParam None None None

-- | Custom existential packing an error together with a Reason.

data SomeError where
  SomeError :: Errors e -> Reason (FromMaybe Void e) -> SomeError

-- | Type synonym for dictionary modification.

type Modifier h p i o e = Dict () () 'Nothing 'Nothing 'Nothing -> Dict h p i o e