{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeOperators         #-}

-- TODO: This module duplicates quite a lot of code from CodeGen.hs.
module Servant.PureScript.MakeRequests where

import           Control.Lens                       hiding (List)
import           Data.Map                           (Map)
import           Data.Proxy                         (Proxy (Proxy))
import qualified Data.Set                           as Set
import           Data.Text                          (Text)
import qualified Data.Text                          as T
import qualified Data.Text.Encoding                 as T
import           Language.PureScript.Bridge         (ImportLine (..),
                                                     PSType,
                                                     buildBridge,
                                                     defaultBridge,
                                                     importsFromList,
                                                     mergeImportLines,
                                                     mkTypeInfo)
import           Servant.Foreign
import           Servant.PureScript.CodeGen         hiding (genBuildHeader,
                                                     genBuildHeaders,
                                                     genBuildPath,
                                                     genBuildQuery,
                                                     genBuildQueryArg,
                                                     genBuildSegment, genFnBody,
                                                     genFunction, genModule,
                                                     genSignature)
import           Servant.PureScript.Internal
import           Servant.Subscriber.Request         (HttpRequest)
import           Text.PrettyPrint.Mainland

subscriberImportLines :: Map Text ImportLine
subscriberImportLines = importsFromList
  [
    ImportLine "Servant.Subscriber.Subscriptions" (Set.fromList [ "Subscriptions"
                                                                , "makeSubscriptions"
                                                                ])
  , ImportLine "Servant.Subscriber.Util" (Set.fromList [ "toUserType"
                                                       , "subGenNormalQuery"
                                                       , "subGenListQuery"
                                                       , "subGenFlagQuery"
                                                       , "TypedToUser"
                                                       ])
  , ImportLine "Servant.Subscriber" (Set.fromList ["ToUserType"])
  , ImportLine "Servant.Subscriber.Request" (Set.fromList ["HttpRequest(..)"])
  , ImportLine "Servant.Subscriber.Types" (Set.fromList ["Path(..)"])
  , ImportLine "Data.Tuple" (Set.fromList ["Tuple(..)"])
  ]

genModule :: Settings -> [Req PSType] -> Doc
genModule opts reqs = let
    allParams  = concatMap reqToParams reqs
    rParams    = getReaderParams opts allParams
    apiImports = reqsToImportLines reqs
    webAPIImports = importsFromList [
        ImportLine (opts ^. apiModuleName) (Set.fromList ["SPParams_(..)"])
      ]
    imports    = _standardImports opts
                  `mergeImportLines` apiImports
                  `mergeImportLines` subscriberImportLines
                  `mergeImportLines` webAPIImports
    moduleName = _apiModuleName opts <> ".MakeRequests"
  in
    genModuleHeader moduleName imports
    </> (docIntercalate line . map (genFunction rParams)) reqs

genFunction :: [PSParam] -> Req PSType -> Doc
genFunction allRParams req = let
    rParamsSet = Set.fromList allRParams
    fnName = req ^. reqFuncName ^. jsCamelCaseL
    allParamsList = baseURLParam : reqToParams req
    allParams = Set.fromList allParamsList
    fnParams = filter (not . flip Set.member rParamsSet) allParamsList -- Use list not set, as we don't want to change order of parameters
    rParams = Set.toList $ rParamsSet `Set.intersection` allParams

    pTypes = map _pType fnParams
    pNames = map _pName fnParams
    signature = genSignature fnName pTypes (Just psHttpRequest)
    body = genFnHead fnName pNames <+> genFnBody rParams req
  in signature </> body


genSignature :: Text -> [PSType] -> Maybe PSType -> Doc
genSignature = genSignatureBuilder $ "forall m." <+/> "MonadAsk (SPSettings_ SPParams_) m" <+/> "=>"

genFnBody :: [PSParam] -> Req PSType -> Doc
genFnBody rParams req = "do"
    </> indent 2 (
          "spOpts_' <- ask"
      </> "let spOpts_ = case spOpts_' of SPSettings_ o -> o"
      </> "let spParams_ = case spOpts_.params of SPParams_ ps_ -> ps_"
      </> genGetReaderParams rParams
      </> hang 6 ("let httpMethod =" <+> dquotes (req ^. reqMethod ^. to T.decodeUtf8 ^. to strictText))
      </> hang 6 ("let reqPath ="     <+> genBuildPath (req ^. reqUrl . path))
      </> "let reqHeaders =" </> indent 6 (req ^. reqHeaders ^. to genBuildHeaders)
      </> "let reqQuery =" </> indent 6 (req ^. reqUrl ^. queryStr . to genBuildQuery)
      </> "let spReq = " <> hang 2 ("HttpRequest" </>
                                   "{ httpMethod:" <+> "httpMethod"
                               </> ", httpPath:" <+> "reqPath"
                               </> ", httpHeaders:" <+> "reqHeaders"
                               </> ", httpQuery:" <+> "reqQuery"
                               </> ", httpBody:" <+> case req ^. reqBody of
                                       Nothing -> "\"\""
                                       Just _ -> "stringify <<< encodeJson $ reqBody"
                               </> "}")
      </> "pure spReq"
    ) <> "\n"

----------
genBuildPath :: Path PSType -> Doc
genBuildPath p = "Path ["
  <> (docIntercalate (softline <> ", ") . map (genBuildSegment . unSegment)) p
  <> "]"

genBuildSegment :: SegmentType PSType -> Doc
genBuildSegment (Static (PathSegment seg)) = dquotes $ strictText seg
genBuildSegment (Cap arg) = "gDefaultToURLPiece" <+> arg ^. argName ^. to unPathSegment ^. to psVar

----------
genBuildQuery :: [QueryArg PSType] -> Doc
genBuildQuery []   = "[]"
genBuildQuery args = docIntercalate (softline <> "<> ") . map genBuildQueryArg $ args

genBuildQueryArg :: QueryArg PSType -> Doc
genBuildQueryArg arg = case arg ^. queryArgType of
    Normal -> genQueryEncoding "subGenNormalQuery"
    Flag   -> genQueryEncoding "subGenFlagQuery"
    List   -> genQueryEncoding "subGenListQuery"
  where
    argText = arg ^. queryArgName ^. argName ^. to unPathSegment
    argDoc = strictText argText
    genQueryEncoding fn = fn <+> dquotes argDoc <+> psVar argText

-----------

genBuildHeaders :: [HeaderArg PSType] -> Doc
genBuildHeaders = list . map genBuildHeader

genBuildHeader :: HeaderArg PSType -> Doc
genBuildHeader (HeaderArg arg) = let
    argText = arg ^. argName ^. to unPathSegment
    argDoc = strictText argText
  in
    align $ "Tuple" <+> dquotes argDoc <+> "(gDefaultToURLPiece" <+> psVar argText <> ")"
genBuildHeader (ReplaceHeaderArg _ _) = error "ReplaceHeaderArg - not yet implemented!"



psHttpRequest :: PSType
psHttpRequest = let
    haskType' = mkTypeInfo (Proxy :: Proxy HttpRequest)
    bridge = buildBridge defaultBridge
 in
    bridge haskType'