content: {-# LANGUAGE DataKinds             #-}
  {-# LANGUAGE FlexibleContexts      #-}
  {-# LANGUAGE FlexibleInstances     #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE OverloadedStrings     #-}
  {-# LANGUAGE ScopedTypeVariables   #-}
  {-# LANGUAGE TypeOperators         #-}
  
  module Servant.PureScript.CodeGen where
  
  import           Control.Lens                       hiding (List)
  import qualified Data.Map                           as Map
  import           Data.Maybe                         (mapMaybe, maybeToList)
  import qualified Data.Set                           as Set
  import           Data.Text                          (Text)
  import qualified Data.Text.Encoding                 as T
  import           Language.PureScript.Bridge
  import           Language.PureScript.Bridge.PSTypes (psString)
  import           Network.HTTP.Types.URI             (urlEncode)
  import           Servant.Foreign
  import           Servant.PureScript.Internal
  import           Text.PrettyPrint.Mainland
  
  genModule :: Settings -> [Req PSType] -> Doc
  genModule opts reqs = let
      allParams  = concatMap reqToParams reqs
      rParams    = getReaderParams opts allParams
      apiImports = reqsToImportLines reqs
      imports    = mergeImportLines (_standardImports opts) apiImports
    in
      genModuleHeader (_apiModuleName opts) imports
      </> genParamSettings rParams <> line
      </> (docIntercalate line . map (genFunction rParams)) reqs
  
  genModuleHeader :: Text -> ImportLines -> Doc
  genModuleHeader moduleName imports = let
      importLines = map (strictText . importLineToText) . Map.elems $ imports
    in
          "-- File auto generated by servant-purescript! --"
      </> "module" <+> strictText moduleName <+> "where" <> line
      </> "import Prelude" <> line
      </> docIntercalate line importLines <> line
  
  getReaderParams :: Settings -> [PSParam] -> [PSParam]
  getReaderParams opts allParams = let
      isReaderParam      = (`Set.member` _readerParams opts) . _pName
      rParamsDirty       = filter isReaderParam allParams
      rParamsMap         = Map.fromListWith useOld . map toPair $ rParamsDirty
      rParams            = map fromPair . Map.toList $ rParamsMap
      -- Helpers
      toPair (Param n t) = (n, t)
      fromPair (n, t) = Param n t
      useOld            = flip const
    in
      rParams
  
  genParamSettings :: [PSParam]-> Doc
  genParamSettings rParams = let
      genEntry arg = arg ^. pName ^. to psVar <+> "::" <+> arg ^. pType ^. typeName ^. to strictText
      genEntries   = docIntercalate (line <> ", ") . map genEntry
    in
      "newtype SPParams_ = SPParams_" <+/> align (
                lbrace
            <+> genEntries rParams
            </> rbrace
            )
  
  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 (req ^. reqReturnType)
      body = genFnHead fnName pNames <+> genFnBody rParams req
    in signature </> body
  
  
  genGetReaderParams :: [PSParam] -> Doc
  genGetReaderParams = stack . map (genGetReaderParam . psVar . _pName)
    where
      genGetReaderParam pName' = "let" <+> pName' <+> "= spParams_." <> pName'
  
  
  genSignature :: Text -> [PSType] -> Maybe PSType -> Doc
  genSignature = genSignatureBuilder $ "forall eff m." <+/> "MonadAsk (SPSettings_ SPParams_) m => MonadError AjaxError m => MonadAff ( ajax :: AJAX | eff) m" <+/> "=>"
  
  genSignatureBuilder :: Doc -> Text -> [PSType] -> Maybe PSType -> Doc
  genSignatureBuilder constraint fnName params mRet = fName <+> "::" <+> align (constraint <+/> parameterString)
    where
      fName = strictText fnName
      retName = maybe "Unit" (strictText . typeInfoToText False) mRet
      retString = "m" <+> retName
      typeNames = map (strictText . typeInfoToText True) params
      parameterString = docIntercalate (softline <> "-> ") (typeNames <> [retString])
  
  genFnHead :: Text -> [Text] -> Doc
  genFnHead fnName params = fName <+> align (docIntercalate softline docParams <+> "=")
    where
      docParams = map psVar params
      fName = strictText fnName
  
  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))
        </> genBuildQueryArgs (req ^. reqUrl ^. queryStr)
        </> hang 6 ("let reqUrl ="     <+> genBuildURL (req ^. reqUrl))
        </> "let reqHeaders =" </> indent 6 (req ^. reqHeaders ^. to genBuildHeaders)
        </> case req ^. reqBody of
               Nothing -> ""
               Just _ -> "let encodeJson = case spOpts_.encodeJson of SPSettingsEncodeJson_ e -> e"
        </> "let affReq =" <+> hang 2 ( "defaultRequest" </>
              "{ method ="  <+> "httpMethod"
          </> ", url ="     <+> "reqUrl"
          </> ", headers =" <+> "defaultRequest.headers <> reqHeaders"
          </> case req ^. reqBody of
                Nothing -> "}"
                Just _  -> ", content =" <+> "toNullable <<< Just <<< stringify <<< encodeJson $ reqBody" </> "}"
        )
        </> if shallParseBody (req^.reqReturnType)
            then "affResp <- affjax affReq"
             </> "let decodeJson = case spOpts_.decodeJson of SPSettingsDecodeJson_ d -> d"
             </> "getResult affReq decodeJson affResp"
            else "_ <- affjax affReq"
             </> "pure unit"
      ) <> line
    where
      shallParseBody Nothing = False
      shallParseBody (Just t) = t^.typeName /= "Unit"
  
  genBuildURL :: Url PSType -> Doc
  genBuildURL url = psVar baseURLId <+> "<>"
      <+> genBuildPath (url ^. path ) <+> "<>" <+> "queryString"
  
  ----------
  genBuildPath :: Path PSType -> Doc
  genBuildPath = docIntercalate (softline <> "<> \"/\" <> ") . map (genBuildSegment . unSegment)
  
  genBuildSegment :: SegmentType PSType -> Doc
  genBuildSegment (Static (PathSegment seg)) = dquotes $ strictText (textURLEncode False seg)
  genBuildSegment (Cap arg) = "encodeURLPiece spOpts_'" <+> arg ^. argName ^. to unPathSegment ^. to psVar
  
  genBuildQueryArgs :: [QueryArg PSType] -> Doc
  genBuildQueryArgs [] = "let queryString = \"\""
  genBuildQueryArgs args = "let queryArgs = catMaybes [" </> (indent 2 (docIntercalate ("," <> softline) . map genBuildQueryArg $ args)) </> "]"
                    </> "let queryString = if null queryArgs then \"\" else \"?\" <> (joinWith \"&\" queryArgs)"
  
  ----------
  genBuildQueryArg :: QueryArg PSType -> Doc
  genBuildQueryArg arg = case arg ^. queryArgType of
      Normal -> genQueryEncoding "encodeQueryItem spOpts_'" "<$>"
      Flag   -> genQueryEncoding "encodeQueryItem spOpts_'" "<$> Just"
      List   -> genQueryEncoding "encodeListQuery spOpts_'" "<$> Just"
    where
      argText = arg ^. queryArgName ^. argName ^. to unPathSegment
      encodedArgName = strictText . textURLEncode True $ argText
      genQueryEncoding fn op = fn <+> dquotes encodedArgName <+> op <+> psVar argText
  
  -----------
  
  genBuildHeaders :: [HeaderArg PSType] -> Doc
  genBuildHeaders = list . map genBuildHeader
  
  genBuildHeader :: HeaderArg PSType -> Doc
  genBuildHeader (HeaderArg arg) = let
      argText = arg ^. argName ^. to unPathSegment
      encodedArgName = strictText . textURLEncode True $ argText
    in
      align $ "{ field : " <> dquotes encodedArgName
        <+/> comma <+> "value :"
        <+> "encodeHeader spOpts_'" <+> psVar argText
        </> "}"
  genBuildHeader (ReplaceHeaderArg _ _) = error "ReplaceHeaderArg - not yet implemented!"
  
  reqsToImportLines :: [Req PSType] -> ImportLines
  reqsToImportLines = typesToImportLines Map.empty . Set.fromList . concatMap reqToPSTypes
  
  reqToPSTypes :: Req PSType -> [PSType]
  reqToPSTypes req = map _pType (reqToParams req) ++ maybeToList (req ^. reqReturnType)
  
  -- | Extract all function parameters from a given Req.
  reqToParams :: Req PSType -> [Param PSType]
  reqToParams req = Param baseURLId psString
                 : fmap headerArgToParam (req ^. reqHeaders)
                 ++ maybeToList (reqBodyToParam (req ^. reqBody))
                 ++ urlToParams (req ^. reqUrl)
  
  urlToParams :: Url PSType -> [Param PSType]
  urlToParams url = mapMaybe (segmentToParam . unSegment) (url ^. path) ++ map queryArgToParam (url ^. queryStr)
  
  segmentToParam :: SegmentType f -> Maybe (Param f)
  segmentToParam (Static _) = Nothing
  segmentToParam (Cap arg) = Just Param {
      _pType = arg ^. argType
    , _pName = arg ^. argName ^. to unPathSegment
    }
  
  mkPsMaybe :: PSType -> PSType
  mkPsMaybe t = TypeInfo "" "" "Maybe" [t]
  
  queryArgToParam :: QueryArg PSType -> Param PSType
  queryArgToParam arg = Param {
      _pType = pType
    , _pName = arg ^. queryArgName ^. argName ^. to unPathSegment
    }
    where
      pType = case arg ^. queryArgType of
        Normal -> mkPsMaybe (arg ^. queryArgName ^. argType)
        _ -> arg ^. queryArgName ^. argType
  
  headerArgToParam :: HeaderArg f -> Param f
  headerArgToParam (HeaderArg arg) = Param {
      _pName = arg ^. argName ^. to unPathSegment
    , _pType = arg ^. argType
    }
  headerArgToParam _ = error "We do not support ReplaceHeaderArg - as I have no idea what this is all about."
  
  reqBodyToParam :: Maybe f -> Maybe (Param f)
  reqBodyToParam = fmap (Param "reqBody")
  
  docIntercalate :: Doc -> [Doc] -> Doc
  docIntercalate i = mconcat . punctuate i
  
  
  textURLEncode :: Bool -> Text -> Text
  textURLEncode spaceIsPlus = T.decodeUtf8 . urlEncode spaceIsPlus . T.encodeUtf8
  
  -- | Little helper for generating valid variable names
  psVar :: Text -> Doc
  psVar = strictText . toPSVarName
  