content: {-# LANGUAGE
      CPP
    , DoAndIfThenElse
    , LambdaCase
    , PatternGuards
    , TemplateHaskell
    , ViewPatterns
    #-}
  module Rest.Gen.Haskell
    ( HaskellContext (..)
    , mkHsApi
    ) where
  
  import Control.Applicative
  import Control.Arrow (first, second)
  import Control.Category
  import Control.Monad
  import Data.Label (modify, set)
  import Data.Label.Derive (mkLabelsNamed)
  import Data.List
  import Data.Maybe
  import Prelude hiding (id, (.))
  import Safe
  import System.Directory
  import System.FilePath
  import qualified Data.Generics.Uniplate.Data                 as U
  import qualified Data.Label.Total                            as L
  import qualified Data.List.NonEmpty                          as NList
  import qualified Distribution.ModuleName                     as Cabal
  import qualified Distribution.Package                        as Cabal
  import qualified Distribution.PackageDescription             as Cabal
  import qualified Distribution.PackageDescription.Parse       as Cabal
  import qualified Distribution.PackageDescription.PrettyPrint as Cabal
  import qualified Distribution.Simple.Utils                   as Cabal
  import qualified Distribution.Verbosity                      as Cabal
  import qualified Distribution.Version                        as Cabal
  import qualified Language.Haskell.Exts.Pretty                as H
  import qualified Language.Haskell.Exts.Syntax                as H
  
  import Rest.Api (Router, Version)
  
  import Rest.Gen.Base
  import Rest.Gen.Types
  import Rest.Gen.Utils
  import qualified Rest.Gen.NoAnnotation          as N
  import qualified Rest.Gen.Base.ActionInfo.Ident as Ident
  
  mkLabelsNamed ("_" ++) [''Cabal.GenericPackageDescription, ''Cabal.CondTree, ''Cabal.Library]
  
  data HaskellContext =
    HaskellContext
      { apiVersion     :: Version
      , targetPath     :: String
      , wrapperName    :: String
      , includePrivate :: Bool
      , sources        :: [N.ModuleName]
      , imports        :: [N.ImportDecl]
      , rewrites       :: [(N.ModuleName, N.ModuleName)]
      , namespace      :: [String]
      }
  
  mkHsApi :: HaskellContext -> Router m s -> IO ()
  mkHsApi ctx r =
    do let tree = sortTree . (if includePrivate ctx then id else noPrivate) . apiSubtrees $ r
       mkCabalFile ctx tree
       mapM_ (writeRes ctx) $ allSubTrees tree
  
  mkCabalFile :: HaskellContext -> ApiResource -> IO ()
  mkCabalFile ctx tree =
    do cabalExists <- doesFileExist cabalFile
       gpkg <-
         if cabalExists
         then updateExposedModules modules <$> Cabal.readPackageDescription Cabal.normal cabalFile
         else return (mkGenericPackageDescription (wrapperName ctx) modules)
       writeCabalFile cabalFile gpkg
    where
      cabalFile = targetPath ctx </> wrapperName ctx ++ ".cabal"
      modules   = map (Cabal.fromString . unModuleName) (sources ctx)
               ++ map (Cabal.fromString . qualModName . (namespace ctx ++)) (allSubResourceIds tree)
  
  writeCabalFile :: FilePath -> Cabal.GenericPackageDescription -> IO ()
  writeCabalFile path = Cabal.writeUTF8File path . unlines . filter emptyField . lines . Cabal.showGenericPackageDescription
    where emptyField = (/= "\"\" ") . takeWhile (/= ':') . reverse
  
  updateExposedModules :: [Cabal.ModuleName] -> Cabal.GenericPackageDescription -> Cabal.GenericPackageDescription
  updateExposedModules modules = modify _condLibrary (Just . maybe (mkCondLibrary modules) (set (_exposedModules . _condTreeData) modules))
  
  mkGenericPackageDescription :: String -> [Cabal.ModuleName] -> Cabal.GenericPackageDescription
  mkGenericPackageDescription name modules =
  #if MIN_VERSION_Cabal(2,0,0)
    Cabal.GenericPackageDescription pkg [] (Just (mkCondLibrary modules)) [] [] [] [] []
  #else
    Cabal.GenericPackageDescription pkg [] (Just (mkCondLibrary modules)) [] [] []
  #endif
    where
      pkg = Cabal.emptyPackageDescription
        { Cabal.package        = Cabal.PackageIdentifier (cabalPackageName name) (cabalVersion [0, 1])
        , Cabal.buildType      = Just Cabal.Simple
        , Cabal.specVersionRaw = Right (Cabal.orLaterVersion (cabalVersion [1, 8]))
        }
  
  mkCondLibrary :: [Cabal.ModuleName] -> Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.Library
  mkCondLibrary modules = Cabal.CondNode
    { Cabal.condTreeData        = cabalLibrary modules
    , Cabal.condTreeConstraints =
       [ Cabal.Dependency (cabalPackageName "base")        (Cabal.withinVersion $ cabalVersion [4]      )
       , Cabal.Dependency (cabalPackageName "rest-types")  (Cabal.withinVersion $ cabalVersion [1, 10]  )
       , Cabal.Dependency (cabalPackageName "rest-client") (Cabal.withinVersion $ cabalVersion [0, 5, 2])
       ]
    , Cabal.condTreeComponents  = []
    }
  
  cabalLibrary :: [Cabal.ModuleName] -> Cabal.Library
  #if MIN_VERSION_Cabal(2,0,0)
  cabalLibrary mods = Cabal.emptyLibrary
    { Cabal.exposedModules = mods
    , Cabal.libBuildInfo = (Cabal.libBuildInfo Cabal.emptyLibrary) { Cabal.hsSourceDirs = ["src"] }
    }
  #else
  #if MIN_VERSION_Cabal(1,22,0)
  cabalLibrary mods = Cabal.Library mods [] [] [] True Cabal.emptyBuildInfo { Cabal.hsSourceDirs = ["src"] }
  #else
  cabalLibrary mods = Cabal.Library mods True Cabal.emptyBuildInfo { Cabal.hsSourceDirs = ["src"] }
  #endif
  #endif
  
  cabalVersion :: [Int] -> Cabal.Version
  #if MIN_VERSION_Cabal(2,0,0)
  cabalVersion = Cabal.mkVersion
  #else
  cabalVersion v = Cabal.Version v []
  #endif
  
  cabalPackageName :: String -> Cabal.PackageName
  #if MIN_VERSION_Cabal(2,0,0)
  cabalPackageName =  Cabal.mkPackageName
  #else
  cabalPackageName = Cabal.PackageName
  #endif
  
  writeRes :: HaskellContext -> ApiResource -> IO ()
  writeRes ctx node =
    do createDirectoryIfMissing True (targetPath ctx </> "src" </> modPath (namespace ctx ++ resParents node))
       writeFile (targetPath ctx </> "src" </> modPath (namespace ctx ++ resId node) ++ ".hs") (mkRes ctx node)
  
  mkRes :: HaskellContext -> ApiResource -> String
  mkRes ctx node = H.prettyPrint $ buildHaskellModule ctx node pragmas Nothing
    where
      pragmas :: [N.ModulePragma]
      pragmas = [ H.LanguagePragma () [H.Ident () "OverloadedStrings"]
                , H.OptionsPragma () (Just H.GHC) "-fno-warn-unused-imports"
                ]
      _warningText = "Warning!! This is automatically generated code, do not modify!"
  
  buildHaskellModule :: HaskellContext -> ApiResource ->
                        [N.ModulePragma] -> Maybe N.WarningText ->
                        N.Module
  buildHaskellModule ctx node pragmas warningText =
    rewriteModuleNames (rewrites ctx) $
       H.Module () (Just $ H.ModuleHead () name warningText exportSpecs) pragmas importDecls decls
    where
      name :: N.ModuleName
      name = H.ModuleName () $ qualModName $ namespace ctx ++ resId node
      exportSpecs :: Maybe N.ExportSpecList
      exportSpecs = Nothing
      importDecls :: [N.ImportDecl]
      importDecls = nub $ namedImport "Rest.Client.Internal"
                        : extraImports
                       ++ parentImports
                       ++ dataImports
                       ++ idImports
      decls :: [N.Decl]
      decls = idData node ++ concat funcs
  
      extraImports :: [N.ImportDecl]
      extraImports = imports ctx
      parentImports :: [N.ImportDecl]
      parentImports = map mkImport . tail . inits . resParents $ node
      dataImports :: [N.ImportDecl]
      dataImports = map (qualImport . unModuleName) datImp
      idImports :: [N.ImportDecl]
      idImports = concat . mapMaybe (return . map (qualImport . unModuleName) . Ident.haskellModules <=< snd) . resAccessors $ node
  
      funcs :: [[N.Decl]]
      datImp :: [N.ModuleName]
      (funcs, datImp) = second (nub . concat) . unzip . map (mkFunction (apiVersion ctx) . resName $ node) $ resItems node
      mkImport :: [String] -> N.ImportDecl
      mkImport p = (namedImport importName)
                     { H.importQualified = True
                     , H.importAs        = importAs'
                     }
        where
          importName :: String
          importName = qualModName $ namespace ctx ++ p
          importAs' :: Maybe N.ModuleName
          importAs' = fmap (H.ModuleName () . modName) . lastMay $ p
  
  rewriteModuleNames :: [(N.ModuleName, N.ModuleName)] -> N.Module -> N.Module
  rewriteModuleNames rews = U.transformBi $ \m -> lookupJustDef m m rews
  
  noBinds :: Maybe N.Binds
  noBinds = Nothing
  
  use :: N.Name -> N.Exp
  use = H.Var () . H.UnQual ()
  
  useMQual :: Maybe N.ModuleName -> N.Name -> N.Exp
  useMQual Nothing = use
  useMQual (Just qual) = H.Var () . H.Qual () qual
  
  mkFunction :: Version -> String -> ApiAction -> ([N.Decl], [N.ModuleName])
  mkFunction ver res (ApiAction _ lnk ai) =
    ([H.TypeSig () [funName] fType,
      H.FunBind () [H.Match () funName fParams rhs noBinds]],
      responseModules errorI ++ responseModules output ++ maybe [] inputModules mInp)
       where
         funName :: N.Name
         funName = mkHsName ai
         fParams :: [N.Pat]
         fParams = map (H.PVar ()) $ lPars
                             ++ maybe [] ((:[]) . hsName . cleanName . description) (ident ai)
                             ++ maybe [] (const [input]) mInp
                             ++ (if null (params ai) then [] else [pList])
         lUrl :: N.Exp
         lPars :: [N.Name]
         (lUrl, lPars) = linkToURL res lnk
         mInp :: Maybe InputInfo
         mInp = fmap (inputInfo . L.get desc . chooseType) . NList.nonEmpty . inputs $ ai
         fType :: N.Type
         fType = H.TyForall () Nothing (Just ctx) $ fTypify tyParts
           where
             ctx :: N.Context
             ctx = H.CxSingle () $ H.ClassA () (H.UnQual () cls) [m]
             cls :: N.Name
             cls = H.Ident () "ApiStateC"
             m :: N.Type
             m = H.TyVar () $ H.Ident () "m"
             fTypify :: [N.Type] -> N.Type
             fTypify = \case
               []          -> error "Rest.Gen.Haskell.mkFunction.fTypify - expects at least one type"
               [ty1]       -> ty1
               [ty1, ty2]  -> H.TyFun () ty1 ty2
               (ty1 : tys) -> H.TyFun () ty1 (fTypify tys)
             tyParts :: [N.Type]
             tyParts = map qualIdent lPars
                    ++ maybe [] (return . Ident.haskellType) (ident ai)
                    ++ inp
                    ++ (if null (params ai)
                        then []
                        else [H.TyList ()
                                (H.TyTuple () H.Boxed
                                  [ haskellStringType
                                  , haskellStringType
                                  ])])
                    ++ [H.TyApp () m
                          (H.TyApp ()
                            (H.TyApp ()
                              (H.TyCon () $ H.UnQual () (H.Ident () "ApiResponse"))
                              (responseHaskellType errorI))
                            (responseHaskellType output))]
             qualIdent :: N.Name -> N.Type
             qualIdent = \case
               (H.Ident _ s)
                 | s == cleanHsName res -> H.TyCon () $ H.UnQual () tyIdent
                 | otherwise            -> H.TyCon () $ H.Qual () (H.ModuleName () $ modName s) tyIdent
               H.Symbol{}               -> error "Rest.Gen.Haskell.mkFunction.qualIdent - not expecting a Symbol"
             inp :: [N.Type]
             inp | Just i <- mInp
                 , i' <- inputHaskellType i = [i']
                 | otherwise = []
         input :: N.Name
         input = H.Ident () "input"
         pList :: N.Name
         pList = H.Ident () "pList"
         rhs :: N.Rhs
         rhs = H.UnGuardedRhs () $ H.Let () binds expr
           where
             binds :: N.Binds
             binds = H.BDecls () [rHeadersBind, requestBind]
             rHeadersBind :: N.Decl
             rHeadersBind =
               H.PatBind () (H.PVar () rHeaders)
                 (H.UnGuardedRhs () $
                   H.List ()
                     [ H.Tuple () H.Boxed
                       [ use hAccept
                       , stringLit $ dataTypesToAcceptHeader JSON $ responseAcceptType responseType
                       ]
                     , H.Tuple () H.Boxed
                       [ use hContentType
                       , stringLit $ maybe "text/plain" inputContentType mInp
                       ]])
                 noBinds
  
             rHeaders     :: N.Name
             rHeaders     = H.Ident () "rHeaders"
             hAccept      :: N.Name
             hAccept      = H.Ident () "hAccept"
             hContentType :: N.Name
             hContentType = H.Ident () "hContentType"
             doRequest    :: N.Name
             doRequest    = H.Ident () "doRequest"
  
             requestBind :: N.Decl
             requestBind =
               H.PatBind () (H.PVar () request)
                  (H.UnGuardedRhs () $
                    appLast
                      (H.App ()
                        (H.App ()
                          (H.App ()
                            (H.App () (H.App () (use makeReq) (stringLit str)) (stringLit ve))
                            url)
                          (if null (params ai) then H.List () [] else use pList))
                        (use rHeaders))) noBinds
               where
                 str = show $ method ai
             appLast :: N.Exp -> N.Exp
             appLast e
               | Just i <- mInp = H.App () e (H.App () (use $ H.Ident () $ inputFunc i) (use input))
               | otherwise = H.App () e (stringLit "")
             makeReq :: N.Name
             makeReq = H.Ident () "makeReq"
             request :: N.Name
             request = H.Ident () "request"
  
             expr :: N.Exp
             expr = H.App () (H.App () (H.App () (use doRequest)
                                        (use . H.Ident () $ responseFunc errorI))
                                        (use . H.Ident () $ responseFunc output))
                                        (use request)
  
         ve :: String
         url :: N.Exp
         (ve, url) = ("v" ++ show ver, lUrl)
         errorI :: ResponseInfo
         errorI = errorInfo responseType
         output :: ResponseInfo
         output = outputInfo responseType
         responseType :: ResponseType
         responseType = chooseResponseType ai
  
  linkToURL :: String -> Link -> (N.Exp, [N.Name])
  linkToURL res lnk = first (H.List ()) $ urlParts res lnk ([], [])
  
  urlParts :: String -> Link -> ([N.Exp], [N.Name]) -> ([N.Exp], [N.Name])
  urlParts res lnk ac@(rlnk, pars) =
    case lnk of
      [] -> ac
      (LResource r : a@(LAccess _) : xs)
        | not (hasParam a) -> urlParts res xs (rlnk ++ [H.List () [stringLit r]], pars)
        | otherwise -> urlParts res xs (rlnk', pars ++ [H.Ident () . cleanHsName $ r])
             where
               rlnk' = rlnk ++ (H.List () [stringLit r] : tailed)
               tailed = [H.App () (useMQual qual $ H.Ident () "readId")
                               (use . hsName $ cleanName r)]
                 where
                   qual :: Maybe N.ModuleName
                   qual | r == res  = Nothing
                        | otherwise = Just . H.ModuleName () $ modName r
      (LParam p : xs) -> urlParts res xs (rlnk ++ [H.List () [H.App () (use $ H.Ident () "showUrl")
                                                            (use $ hsName (cleanName p))]], pars)
      (i : xs) -> urlParts res xs (rlnk ++ [H.List () [stringLit $ itemString i]], pars)
  
  idData :: ApiResource -> [N.Decl]
  idData node =
    case resAccessors node of
      [] -> []
      [(_pth, Nothing)] -> []
      [(pth, Just i)] ->
        let pp xs | null pth = xs
                  | otherwise = stringLit pth : xs
        in [ H.TypeDecl () (H.DHead () tyIdent) (Ident.haskellType i),
             H.TypeSig () [funName] fType,
             H.FunBind () [ H.Match () funName [H.PVar () x]
                              (H.UnGuardedRhs () $ H.List () $ pp [showURLx])
                              noBinds
                          ]
           ]
      ls ->
        let ctor :: (String, Maybe Ident) -> N.QualConDecl
            ctor (pth,mi) =
              H.QualConDecl () Nothing Nothing (H.ConDecl () (H.Ident () (dataName pth)) $ maybe [] f mi)
                where
                  f ty = [Ident.haskellType ty]
            fun :: (String, Maybe Ident) -> [N.Decl]
            fun (pth, mi) = [H.FunBind () [H.Match () funName fparams rhs noBinds]]
              where
                (fparams, rhs) =
                  case mi of
                    Nothing ->
                      ( [H.PVar () . H.Ident () $ dataName pth]
                      , H.UnGuardedRhs () $ H.List () [stringLit pth]
                      )
                    Just{}  ->  -- Pattern match with data constructor
                      ([H.PParen () $ H.PApp () (H.UnQual () $ H.Ident () (dataName pth)) [H.PVar () x]],
                       H.UnGuardedRhs () $ H.List () [stringLit pth, showURLx])
        in [ H.DataDecl () (H.DataType ()) Nothing (H.DHead () tyIdent) (map ctor ls) []
           , H.TypeSig () [funName] fType
           ] ++ concatMap fun ls
      where
        x        :: N.Name
        x        = H.Ident () "x"
        fType    :: N.Type
        fType    = H.TyFun () (H.TyCon () $ H.UnQual () tyIdent) (H.TyList () haskellStringType)
        funName  :: N.Name
        funName  = H.Ident () "readId"
        showURLx :: N.Exp
        showURLx = H.App () (H.Var () $ H.UnQual () $ H.Ident () "showUrl") (H.Var () $ H.UnQual () x)
  
  tyIdent :: N.Name
  tyIdent = H.Ident () "Identifier"
  
  mkHsName :: ActionInfo -> N.Name
  mkHsName ai = hsName $ concatMap cleanName parts
    where
        parts = case actionType ai of
          Retrieve   -> case nm of
            [] -> ["access"]
            _  -> nm
            where
              nm = get ++ by ++ target
          Create     -> ["create"] ++ by ++ target
          -- Should be delete, but delete is a JS keyword and causes problems in collect.
          Delete     -> ["remove"] ++ by ++ target
          DeleteMany -> ["removeMany"] ++ by ++ target
          List       -> ["list"] ++ by ++ target
          Update     -> ["save"] ++ by ++ target
          UpdateMany -> ["saveMany"] ++ by ++ target
          Modify   -> if resDir ai == "" then ["do"] else [resDir ai]
  
        target = if resDir ai == "" then maybe [] ((:[]) . description) (ident ai) else [resDir ai]
        by     = ["by" | target /= [] && (isJust (ident ai) || actionType ai == UpdateMany)]
        get    = ["get" | not (isAccessor ai)]
  
  hsName :: [String] -> N.Name
  hsName []       = H.Ident () ""
  hsName (x : xs) = H.Ident () $ cleanHsName $ downFirst x ++ concatMap upFirst xs
  
  cleanHsName :: String -> String
  cleanHsName s =
    if s `elem` reservedNames
      then s ++ "_"
      else intercalate "" . cleanName $ s
    where
      reservedNames =
        ["as","case","class","data","instance","default","deriving","do"
        ,"foreign","if","then","else","import","infix","infixl","infixr","let"
        ,"in","module","newtype","of","qualified","type","where"]
  
  qualModName :: ResourceId -> String
  qualModName = intercalate "." . map modName
  
  modPath :: ResourceId -> String
  modPath = intercalate "/" . map modName
  
  dataName :: String -> String
  dataName = modName
  
  modName :: String -> String
  modName = concatMap upFirst . cleanName
  
  data InputInfo = InputInfo
    { inputModules     :: [N.ModuleName]
    , inputHaskellType :: N.Type
    , inputContentType :: String
    , inputFunc        :: String
    } deriving (Eq, Show)
  
  inputInfo :: DataDesc -> InputInfo
  inputInfo dsc =
    case L.get dataType dsc of
      String -> InputInfo [] haskellStringType "text/plain" "toLbs"
      XML    -> InputInfo (L.get haskellModules dsc) (L.get haskellType dsc) "text/xml" "toXML"
      JSON   -> InputInfo (L.get haskellModules dsc) (L.get haskellType dsc) "text/json" "toJSON"
      File   -> InputInfo [] haskellByteStringType "application/octet-stream" "id"
      Other  -> InputInfo [] haskellByteStringType "text/plain" "id"
  
  data ResponseInfo = ResponseInfo
    { responseModules     :: [N.ModuleName]
    , responseHaskellType :: N.Type
    , responseFunc        :: String
    } deriving (Eq, Show)
  
  outputInfo :: ResponseType -> ResponseInfo
  outputInfo r =
    case outputType r of
      Nothing -> ResponseInfo [] haskellUnitType "(const ())"
      Just t -> case L.get dataType t of
        String -> ResponseInfo [] haskellStringType "toString"
        XML    -> ResponseInfo (L.get haskellModules t) (L.get haskellType t) "fromXML"
        JSON   -> ResponseInfo (L.get haskellModules t) (L.get haskellType t) "fromJSON"
        File   -> ResponseInfo [] haskellByteStringType "id"
        Other  -> ResponseInfo [] haskellByteStringType "id"
  
  errorInfo :: ResponseType -> ResponseInfo
  errorInfo r =
    case errorType r of
      -- Rest only has XML and JSON instances for errors, so we need to
      -- include at least one of these in the accept header. We don't
      -- want to make assumptions about the response type if there is no
      -- accept header so in that case we force it to be JSON.
      Nothing -> fromJustNote ("rest-gen bug: toResponseInfo' was called with a data type other than XML or JSON, responseType: " ++ show r)
               . toResponseInfo' . defaultErrorDataDesc . maybe JSON (\x -> case x of { XML -> XML; _ -> JSON })
               . fmap (L.get dataType) . outputType
               $ r
      Just t -> toResponseInfo [t]
    where
      toResponseInfo :: [DataDesc] -> ResponseInfo
      toResponseInfo xs
        = fromMaybe (error $ "Unsupported error formats: " ++ show xs ++ ", this is a bug in rest-gen.")
        . headMay
        . mapMaybe toResponseInfo'
        $ xs
      toResponseInfo' :: DataDesc -> Maybe ResponseInfo
      toResponseInfo' t = case L.get dataType t of
        XML  -> Just $ ResponseInfo (L.get haskellModules t) (L.get haskellType t) "fromXML"
        JSON -> Just $ ResponseInfo (L.get haskellModules t) (L.get haskellType t) "fromJSON"
        _    -> Nothing
  
  defaultErrorDataDesc :: DataType -> DataDesc
  defaultErrorDataDesc dt =
    DataDesc
      { _dataType       = dt
      , _haskellType    = haskellVoidType
      , _haskellModules = [ModuleName () "Rest.Types.Void"]
      }
  
  stringLit :: String -> N.Exp
  stringLit s = H.Lit () $ H.String () s s
  