content: {-# LANGUAGE
      CPP
    , GADTs
    , LambdaCase
    , NoImplicitPrelude
    , ScopedTypeVariables
    , TemplateHaskell
    #-}
  #if MIN_VERSION_base(4,9,0)
  {-# OPTIONS_GHC -Wno-redundant-constraints #-}
  #endif
  module Rest.Gen.Base.ActionInfo
    ( Accessor
    , ActionInfo (..)
    , ActionType (..)
    , ActionTarget (..)
    , DataType (..)
    , ResourceId
    , accessLink
    , accessors
    , chooseType
  
    , DataDesc (..)
    , dataType
    , haskellType
    , haskellModules
  
    , DataMeta (..)
    , dataTypeDesc
    , dataSchema
    , dataExample
  
    , DataDescription (..)
    , desc
    , meta
  
    , ResponseType (..)
    , responseAcceptType
    , dataTypesToAcceptHeader
    , chooseResponseType
  
    , isAccessor
    , listGetterActionInfo
    , mkActionDescription
    , namedActionInfo
    , resourceToAccessors
    , resourceToActionInfo
    , selectActionInfo
    , singleActionInfo
    ) where
  
  import Prelude.Compat hiding (id, (.))
  
  import Control.Category
  import Control.Monad
  import Data.Foldable (find)
  import Data.Label.Derive
  import Data.List (intercalate, intersect, nub, sortBy)
  import Data.List.NonEmpty (NonEmpty)
  import Data.Maybe
  import Data.Ord
  import Data.Proxy
  import Data.Typeable
  import Safe
  import qualified Data.JSON.Schema             as J
  import qualified Data.Label.Total             as L
  import qualified Data.List.NonEmpty           as NList
  import qualified Language.Haskell.Exts.Parser as H
  import qualified Language.Haskell.Exts.Syntax as H
  
  import Rest.Dictionary (Error (..), Input (..), Output (..), Param (..))
  import Rest.Driver.Routing (mkListHandler, mkMultiHandler)
  import Rest.Gen.Types
  import Rest.Handler
  import Rest.Info
  import Rest.Resource hiding (description)
  import Rest.Schema
  import qualified Rest.Dictionary as Dict
  import qualified Rest.Resource   as Rest
  
  import Rest.Gen.Base.ActionInfo.Ident (Ident (Ident))
  import Rest.Gen.Base.Link
  import qualified Rest.Gen.Base.ActionInfo.Ident as Ident
  import qualified Rest.Gen.Base.JSON             as J
  import qualified Rest.Gen.Base.XML              as X
  import qualified Rest.Gen.NoAnnotation          as N
  
  --------------------
  -- * The types describing a resource's actions.
  
  -- | Representation of resource
  type ResourceId  = [String]
  
  -- | Intermediate data representation of Rest structure
  data RequestMethod = GET | POST | PUT | DELETE deriving (Show, Eq)
  
  data ActionType = Retrieve | Create | Delete | DeleteMany | List | Update | UpdateMany | Modify
    deriving (Show, Eq)
  
  data ActionTarget = Self | Any deriving (Show, Eq)
  
  data DataType = String | XML | JSON | File | Other deriving (Show, Eq)
  
  -- | Core information about the type of the input/output
  data DataDesc = DataDesc
    { _dataType       :: DataType
    , _haskellType    :: N.Type
    , _haskellModules :: [N.ModuleName]
    } deriving (Show, Eq)
  
  mkLabel ''DataDesc
  
  -- | Documentation information about the input/output
  data DataMeta = DataMeta
    { _dataTypeDesc :: String       -- ^ The name of the DataType, or a custom value if dataType is Other
    , _dataSchema   :: Maybe String -- ^ Just if dataType is XML
    , _dataExample  :: [String]     -- ^ Non empty if dataType is XML or JSON
    } deriving (Show, Eq)
  
  mkLabel ''DataMeta
  
  -- | Combines the core and documentation information for input/output
  data DataDescription = DataDescription
    { _desc :: DataDesc
    , _meta :: DataMeta
    } deriving (Show, Eq)
  
  mkLabel ''DataDescription
  
  data ActionInfo = ActionInfo
    { ident        :: Maybe Ident -- Requires extra identifier in url? e.g. page/<identifier>
    , postAction   :: Bool        -- Works on identified resources? e.g. uri/<uri>/action
    , actionType   :: ActionType
    , actionTarget :: ActionTarget
    , resDir       :: String      -- Resource directory
    , method       :: RequestMethod
    , inputs       :: [DataDescription]
    , outputs      :: [DataDescription]
    , errors       :: [DataDescription]
    , params       :: [String]
    , https        :: Bool
    , link         :: Link
    } deriving (Show, Eq)
  
  isAccessor :: ActionInfo -> Bool
  isAccessor ai = actionType ai == Retrieve && actionTarget ai == Self
  
  defaultDescription :: DataType -> String -> N.Type -> DataDescription
  defaultDescription typ typeDesc htype =
    DataDescription
      { _desc = DataDesc
          { _dataType       = typ
          , _haskellType    = htype
          , _haskellModules = []
          }
      , _meta = DataMeta
          { _dataTypeDesc = typeDesc
          , _dataSchema   = Nothing
          , _dataExample  = []
          }
      }
  
  chooseType :: NonEmpty DataDescription -> DataDescription
  chooseType ls = fromMaybe (NList.head ls) $ find ((JSON ==) . L.get (dataType . desc)) ls
  
  data ResponseType = ResponseType
    { errorType  :: Maybe DataDesc
    , outputType :: Maybe DataDesc
    } deriving Show
  
  responseAcceptType :: ResponseType -> [DataType] -- TODO make non empty list Maybe (NonEmpty DataType)
  responseAcceptType (ResponseType e o) = typs
    where
      typs :: [DataType]
      typs = nub $ f e ++ f o
        where
          f :: Maybe DataDesc -> [DataType]
          f = maybeToList . fmap (L.get dataType)
  
  -- | First argument is the default accept header to use if there is no
  -- output or errors, must be XML or JSON.
  dataTypesToAcceptHeader :: DataType -> [DataType] -> String
  dataTypesToAcceptHeader def = \case
    [] -> dataTypeToAcceptHeader def
    xs -> intercalate "," . map dataTypeToAcceptHeader . (xs ++) $
            [def | null (xs `intersect` [XML, JSON])]
  
  dataTypeToAcceptHeader :: DataType -> String
  dataTypeToAcceptHeader = \case
    String -> "text/plain"
    XML    -> "text/xml"
    JSON   -> "text/json"
    File   -> "application/octet-stream"
    Other  -> "text/plain"
  
  chooseResponseType :: ActionInfo -> ResponseType
  chooseResponseType ai = case (NList.nonEmpty $ outputs ai, NList.nonEmpty $ errors ai) of
    -- No outputs or errors defined
    (Nothing, Nothing) ->
      ResponseType
        { errorType  = Nothing
        , outputType = Nothing
        }
    -- Only an error type
    (Nothing, Just e ) ->
      ResponseType
        { errorType  = Just . L.get desc $ chooseType e
        , outputType = Nothing
        }
    -- Only an output type
    (Just o , Nothing) ->
      ResponseType
        { errorType  = Nothing
        , outputType = Just . L.get desc $ chooseType o
        }
    -- Output and error
    (Just o , Just e ) -> intersection o e
  
    where
  
      intersection :: NonEmpty DataDescription -> NonEmpty DataDescription -> ResponseType
      intersection o e =
        -- Try to find a response type that can be used for both output and error.
        case f o `intersect` f e of
          -- If the response types are disjoint we need to specify both.
          [] ->
            ResponseType
              { errorType  = Just . L.get desc $ chooseType e
              , outputType = Just . L.get desc $ chooseType o
              }
          xs ->
            ResponseType
              { errorType  = matching xs e
              , outputType = matching xs o
              }
          where
            f = map (L.get (dataType . desc)) . NList.toList
            matching :: [DataType] -> NonEmpty DataDescription -> Maybe DataDesc
            matching dts = fmap (L.get desc) . headMay
                         -- Prioritize formats
                         . sortBy (comparing cmp)
                         -- Pick only the data types in the intersection of outputs and errors
                         . filter ((`elem` dts) . L.get (dataType . desc))
                         . NList.toList
            -- When we have an intersection with multiple possible
            -- types, we prefer JSON over XML, and XML over the rest.
            cmp :: DataDescription -> Int
            cmp dt = case L.get (dataType . desc) dt of
              JSON -> 0
              XML  -> 1
              _    -> 2
  
  --------------------
  -- * Traverse a resource's Schema and Handlers to create a [ActionInfo].
  
  resourceToActionInfo :: forall m s sid mid aid. Resource m s sid mid aid -> [ActionInfo]
  resourceToActionInfo r =
    case schema r of
      Schema mTopLevel step -> foldMap (topLevelActionInfo r) mTopLevel
                            ++ stepActionInfo r step
                            ++ foldMap (return . createActionInfo) (Rest.create r)
                            ++ foldMap (return . removeActionInfo accLnk) (Rest.remove r)
                            ++ map (uncurry (selectActionInfo accLnk)) (Rest.selects r)
                            ++ map (uncurry (actionActionInfo accLnk)) (Rest.actions r)
        where
          accLnk = accessLink (accessors step)
  
  accessLink :: [Accessor] -> Link
  accessLink [] = []
  accessLink xs = [LAccess . map f $ xs]
    where
      f ("", x) = par x
      f (pth, x) = LAction pth : par x
      par = maybe [] (return . LParam . Ident.description)
  
  accessors :: Step sid mid aid -> [Accessor]
  accessors (Named hs) = mapMaybe (uncurry accessorsNamed) hs
    where
      accessorsNamed pth (Right (Single g)) = Just (pth, getId g)
      accessorsNamed _ _ = Nothing
      getId (Singleton _) = Nothing
      getId (By id_) = Just . idIdent $ id_
  accessors (Unnamed (Single id_)) = [("", Just . idIdent $ id_)]
  accessors (Unnamed (Many _)) = []
  
  type Accessor = (String, Maybe Ident)
  
  resourceToAccessors :: Resource m s sid mid aid -> [Accessor]
  resourceToAccessors r =
    case schema r of
      Schema _ step -> accessors step
  
  topLevelActionInfo :: Resource m s sid mid aid -> Cardinality sid mid -> [ActionInfo]
  topLevelActionInfo r            (Single _  ) = singleActionInfo r Nothing ""
  topLevelActionInfo r@Resource{} (Many   mid) = maybeToList
                                               . listActionInfo Nothing ""
                                               . Rest.list r
                                               $ mid
  
  stepActionInfo :: Resource m s sid mid aid -> Step sid mid aid -> [ActionInfo]
  stepActionInfo r (Named hs) = concatMap (uncurry (namedActionInfo r)) hs
  stepActionInfo r (Unnamed h) = unnamedActionInfo r h
  
  namedActionInfo :: Resource m s sid mid aid -> String -> Endpoint sid mid aid -> [ActionInfo]
  namedActionInfo r pth (Left aid) = [staticActionInfo pth (Rest.statics r aid)]
  namedActionInfo r pth (Right (Single g)) = getterActionInfo     r pth g
  namedActionInfo r pth (Right (Many   l)) = listGetterActionInfo r pth l
  
  unnamedActionInfo :: Resource m s sid mid aid -> Cardinality (Id sid) (Id mid) -> [ActionInfo]
  unnamedActionInfo r@Resource{} unnamed =
    case unnamed of
      Single id_             -> singleActionInfo r (Just id_) ""
      Many   id_@(Id _ midF) -> maybeToList $
        listActionInfo (Just id_) "" (Rest.list r (midF listIdErr))
  
  getterActionInfo :: Resource m s sid mid aid -> String -> Getter sid -> [ActionInfo]
  getterActionInfo r pth (Singleton _) = singleActionInfo r Nothing    pth
  getterActionInfo r pth (By id_     ) = singleActionInfo r (Just id_) pth
  
  listGetterActionInfo :: Resource m s sid mid aid -> String -> Getter mid -> [ActionInfo]
  listGetterActionInfo r@Resource{} pth getter = maybeToList $
    case getter of
      Singleton mid      -> listActionInfo Nothing    pth (Rest.list r mid)
      By id_@(Id _ midF) -> listActionInfo (Just id_) pth (Rest.list r (midF listIdErr))
  
  listIdErr :: mid
  listIdErr = error $ "Don't evaluate the fields of a list identifier unless in the body of the handler. "
                   ++ "They are undefined during generation of documentation and code."
  
  singleActionInfo :: Resource m s sid mid aid -> Maybe (Id sid) -> String -> [ActionInfo]
  singleActionInfo r@Resource{} mId pth
     = foldMap (return . getActionInfo         mId pth) (Rest.get     r)
    ++ foldMap (return . updateActionInfo      mId pth) (Rest.update  r)
    ++ maybeToList (join $ multiUpdateActionInfo <$> mId <*> pure pth <*> Rest.update r)
    ++ maybeToList (join $ multiRemoveActionInfo <$> mId <*> pure pth <*> Rest.remove r)
  
  --------------------
  -- * Smart constructors for ActionInfo.
  
  getActionInfo :: Maybe (Id sid) -> String -> Handler m -> ActionInfo
  getActionInfo mId pth = handlerActionInfo mId False Retrieve Self pth GET []
  
  updateActionInfo :: Maybe (Id sid) -> String -> Handler m -> ActionInfo
  updateActionInfo mId pth = handlerActionInfo mId False Update Any pth PUT []
  
  multiUpdateActionInfo :: Monad m => Id sid -> String -> Handler m -> Maybe ActionInfo
  multiUpdateActionInfo id_ pth h =  handlerActionInfo Nothing False UpdateMany Any pth PUT []
                                 <$> mkMultiHandler id_ (const id) h
  
  removeActionInfo :: Link -> Handler m -> ActionInfo
  removeActionInfo = handlerActionInfo Nothing True Delete Self "" DELETE
  
  multiRemoveActionInfo :: Monad m => Id sid -> String -> Handler m -> Maybe ActionInfo
  multiRemoveActionInfo id_ pth h =  handlerActionInfo Nothing False DeleteMany Any pth DELETE []
                                 <$> mkMultiHandler id_ (const id) h
  
  listActionInfo :: Monad m => Maybe (Id mid) -> String -> ListHandler m -> Maybe ActionInfo
  listActionInfo mId pth h = handlerActionInfo mId False List Self pth GET [] <$> mkListHandler h
  
  staticActionInfo :: String -> Handler m -> ActionInfo
  staticActionInfo pth = handlerActionInfo Nothing False Modify Any pth POST []
  
  createActionInfo :: Handler m -> ActionInfo
  createActionInfo = handlerActionInfo Nothing False Create Self "" POST []
  
  selectActionInfo :: Link -> String -> Handler m -> ActionInfo
  selectActionInfo lnk pth = handlerActionInfo Nothing True Retrieve Any pth GET lnk
  
  actionActionInfo :: Link -> String -> Handler m -> ActionInfo
  actionActionInfo lnk pth = handlerActionInfo Nothing True Modify Any pth POST lnk
  
  handlerActionInfo :: Maybe (Id id)
                    -> Bool
                    -> ActionType
                    -> ActionTarget
                    -> String
                    -> RequestMethod
                    -> Link
                    -> Handler m
                    -> ActionInfo
  handlerActionInfo mId postAct actType actTarget pth mth ac h = ActionInfo
    { ident        = id_
    , postAction   = postAct
    , actionType   = actType
    , actionTarget = actTarget
    , resDir       = pth
    , method       = mth
    , inputs       = handlerInputs  h
    , outputs      = handlerOutputs h
    , errors       = handlerErrors  h
    , params       = handlerParams  h
    , https        = secure         h
    , link         = makeLink
    }
    where
      id_ = idIdent <$> mId
      makeLink :: Link
      makeLink
        | postAct   = ac ++ dirPart ++ identPart
        | otherwise = dirPart ++ identPart
        where dirPart   = [LAction pth | pth /= ""]
              identPart = maybe [] ((:[]) . LParam . Ident.description) id_
  
  
  --------------------
  -- * Utilities for extraction information from Handlers.
  
  handlerParams :: GenHandler m f -> [String]
  handlerParams (GenHandler dict _ _) = paramNames (L.get Dict.params dict)
  
  -- | A `Param` can contain the same parameter multiple times. For
  -- example, 'offset' and 'count' are added in Rest.Handler.mkListing,
  -- and in Rest.Driver.Routing.mkListHandler. For that reason, we nub
  -- here.
  
  paramNames :: Param a -> [String]
  paramNames = nub . paramNames_
  
  paramNames_ :: Param a -> [String]
  paramNames_ NoParam = []
  paramNames_ (Param s _) = s
  paramNames_ (TwoParams p1 p2) = paramNames p1 ++ paramNames p2
  
  -- | Extract input description from handlers
  handlerInputs :: Handler m -> [DataDescription]
  handlerInputs (GenHandler dict _ _) = map (handlerInput Proxy) (Dict.getDicts_ . L.get Dict.inputs $ dict)
    where
      handlerInput :: Proxy i -> Input i -> DataDescription
      handlerInput d c = case c of
        ReadI          -> L.set (haskellModules . desc) (modString d)
                        $ defaultDescription Other (describe d) (toHaskellType d)
        StringI        -> defaultDescription String "String" haskellStringType
        XmlI           -> L.set (haskellModules . desc) (modString d)
                        . L.set (dataSchema     . meta) (pure . X.showSchema  . X.getXmlSchema $ d)
                        . L.set (dataExample    . meta) (pure . X.showExample . X.getXmlSchema $ d)
                        $ defaultDescription XML "XML" (toHaskellType d)
        XmlTextI       -> defaultDescription XML "XML" haskellStringType
        RawXmlI        -> defaultDescription XML "XML" haskellStringType
        JsonI          -> L.set (haskellModules . desc) (modString d)
                        . L.set (dataExample    . meta) (J.showExamples . J.schema $ d)
                        $ defaultDescription JSON "JSON" (toHaskellType d)
        RawJsonI       -> defaultDescription JSON "JSON" haskellStringType
        -- Picking JSON or XML is arbitrary here since both are possible
        -- so we stick with the convention of preferring JSON.
        RawJsonAndXmlI -> defaultDescription File "File" haskellByteStringType
        FileI          -> defaultDescription File "File" haskellByteStringType
  
  -- | Extract output description from handlers
  handlerOutputs :: Handler m -> [DataDescription]
  handlerOutputs (GenHandler dict _ _) = map (handlerOutput Proxy) (Dict.getDicts_ . L.get Dict.outputs $ dict)
    where
      handlerOutput :: Proxy a -> Output a -> DataDescription
      handlerOutput d c = case c of
        StringO        -> defaultDescription String "String" haskellStringType
        XmlO           -> L.set (haskellModules . desc) (modString d)
                        . L.set (dataSchema     . meta) (pure . X.showSchema  . X.getXmlSchema $ d)
                        . L.set (dataExample    . meta) (pure . X.showExample . X.getXmlSchema $ d)
                        $ defaultDescription XML "XML" (toHaskellType d)
        RawXmlO        -> defaultDescription XML "XML" haskellStringType
        JsonO          -> L.set (haskellModules . desc) (modString d)
                        . L.set (dataExample    . meta) (J.showExamples . J.schema $ d)
                        $ defaultDescription JSON "JSON" (toHaskellType d)
        RawJsonO       -> defaultDescription JSON "JSON" haskellStringType
        -- Picking JSON or XML is arbitrary here since both are possible
        -- so we stick with the convention of preferring JSON.
        RawJsonAndXmlO -> defaultDescription File "File" haskellStringType
        FileO          -> defaultDescription File "File" haskellByteStringType
        -- TODO: MultiPartO
  
  -- | Extract input description from handlers
  handlerErrors :: Handler m -> [DataDescription]
  handlerErrors (GenHandler dict _ _) = map (handleError Proxy) (Dict.getDicts_ . L.get Dict.errors $ dict)
    where
      handleError :: Proxy a -> Error a -> DataDescription
      handleError d c = case c of
        XmlE  -> L.set (dataSchema     . meta) (pure . X.showSchema  . X.getXmlSchema $ d)
               . L.set (dataExample    . meta) (pure . X.showExample . X.getXmlSchema $ d)
               . L.set (haskellModules . desc) (modString d)
               $ defaultDescription XML "XML" (toHaskellType d)
        JsonE -> L.set (dataExample    . meta) (J.showExamples . J.schema $ d)
               . L.set (haskellModules . desc) (modString d)
               $ defaultDescription JSON "JSON" (toHaskellType d)
  
  typeString :: forall a. Typeable a => Proxy a -> String
  typeString _ = typeString' . typeOf $ (undefined :: a)
    where typeString' tr =
            let (tyCon, subs) = splitTyConApp tr
                showTyCon _ "[]" r = "[" ++ r ++ "]"
                showTyCon _ "()" _ = "()"
                showTyCon m d s | take 4 m == "GHC." = d ++ s
                                | otherwise = m ++ "." ++ d ++ s
            in  showTyCon (tyConModule tyCon)
                          (tyConName tyCon)
                          (concatMap (\t -> " (" ++ typeString' t ++ ")") subs)
  
  modString :: forall a. Typeable a => Proxy a -> [N.ModuleName]
  modString _ = map (H.ModuleName ()) . filter (\v -> v /= "" && take 4 v /= "GHC.") . modString' . typeOf $ (undefined :: a)
    where modString' tr =
            let (tyCon, subs) = splitTyConApp tr
            in  tyConModule tyCon : concatMap modString' subs
  
  toHaskellType :: forall a. Typeable a => Proxy a -> N.Type
  toHaskellType ty =
    case H.parseType (typeString ty) of
      H.ParseOk parsedType -> void parsedType
      H.ParseFailed _loc msg -> error msg
  
  idIdent :: Id id -> Ident
  idIdent (Id idnt _) = actionIdent idnt
  
  actionIdent :: forall a. Dict.Ident a -> Ident
  actionIdent Dict.StringId
    = Ident
      { Ident.description    = "string"
      , Ident.haskellType    = haskellStringType
      , Ident.haskellModules = []
      }
  actionIdent Dict.ReadId
    = Ident
      { Ident.description    = describe proxy_
      , Ident.haskellType    = toHaskellType proxy_
      , Ident.haskellModules = modString proxy_
      }
    where
      proxy_ :: Proxy a
      proxy_ = Proxy
  
  mkActionDescription :: String -> ActionInfo -> String
  mkActionDescription res ai =
    let targetS =
          case actionTarget ai of
            Self -> res
            Any  -> "information"
    in case actionType ai of
        Retrieve   -> "Retrieve " ++ targetS ++ " data"
        Create     -> "Create " ++ targetS
        Delete     -> "Delete " ++ targetS
        DeleteMany -> "Delete many " ++ targetS
        List       -> "List " ++ targetS ++ "s"
        Update     -> "Update " ++ targetS
        UpdateMany -> "Update many " ++ targetS
        Modify     -> "Modify " ++ targetS
  