{-# LANGUAGE
    DoAndIfThenElse
  , TemplateHaskell
  #-}
module Rest.Gen.Haskell.Generate
  ( 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 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 Code.Build
import Code.Build.Haskell
import Rest.Api (Router, Version)

import Rest.Gen.Base
import Rest.Gen.Types
import Rest.Gen.Utils
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        :: [ModuleName]
    , imports        :: [Import]
    , rewrites       :: [(ModuleName, 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 = Cabal.GenericPackageDescription pkg [] (Just (mkCondLibrary modules)) [] [] []
  where
    pkg = Cabal.emptyPackageDescription
      { Cabal.package        = Cabal.PackageIdentifier (Cabal.PackageName name) (Cabal.Version [0, 1] [])
      , Cabal.buildType      = Just Cabal.Simple
      , Cabal.specVersionRaw = Right (Cabal.orLaterVersion (Cabal.Version [1, 8] []))
      }

mkCondLibrary :: [Cabal.ModuleName] -> Cabal.CondTree Cabal.ConfVar [Cabal.Dependency] Cabal.Library
mkCondLibrary modules = Cabal.CondNode
  { Cabal.condTreeData        = Cabal.Library modules True Cabal.emptyBuildInfo
  , Cabal.condTreeConstraints = []
  , Cabal.condTreeComponents  = []
  }

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 =
  showCode $
      "{-# LANGUAGE OverloadedStrings #-}\n{-# OPTIONS_GHC -fno-warn-unused-imports #-}\n{- Warning!! This is automatically generated code, do not modify! -}"
  <-> hsModule (qualModName $ namespace ctx ++ resId node)
       [ mkImports ctx node mods
       , idData node
       , mkStack funcs
       ]
  where
    (funcs, mods) = second (nub . concat) . unzip . map (mkFunction (apiVersion ctx) . resName $ node) $ resItems node

mkImports :: HaskellContext -> ApiResource -> [ModuleName] -> Code
mkImports ctx node datImp
  = mkStack . nub . map (rewriteImport $ rewrites ctx)
  $    [Import UnQualified (ModuleName "Rest.Client.Internal") Nothing Nothing]
    ++ extraImports
    ++ parentImports
    ++ dataImports
    ++ idImports
  where
    extraImports  = imports ctx
    parentImports = map mkImport . tail . inits . resParents $ node
    dataImports   = map qualImp datImp
    idImports     = concat . mapMaybe (return . map qualImp . Ident.haskellModules <=< snd) . resAccessors $ node
    -- We need the `as' name to be explicit here even though it's the same, see comment below.
    qualImp v     = Import Qualified v (Just v) Nothing
    mkImport p    = Import Qualified (ModuleName . qualModName $ namespace ctx ++ p) (Just . ModuleName . modName . last $ p) Nothing
    rewriteImport :: [(ModuleName, ModuleName)] -> Import -> Import
    rewriteImport rws i = case i of
      -- We don't rewrite the `as` part of the import so if you have a
      -- rewrite ("Data.Text.Internal.Lazy", "Data.Text.Lazy") the
      -- import will become `import qualified Data.Text as
      -- Data.Text.Internal.Lazy', this is because mkFunction produces
      -- types through strings and doesn't take rewrites into
      -- account. mkFunction should be changed to do this.
      Import q m mas l -> Import q (look m) mas l
      where
       look m = lookupJustDef m m rws

mkFunction :: Version -> String -> ApiAction -> (Code, [ModuleName])
mkFunction ver res (ApiAction _ lnk ai) =
  let mInp     = fmap inputInfo $ chooseType $ inputs ai
      defaultErrorConversion = if fmap dataType (chooseType (outputs ai)) == Just JSON then "fromJSON" else "fromXML"
      (oMod, oType, oCType, oFunc) = maybe ([], "()", "text/plain", "(const ())") outputInfo $ chooseType $ outputs ai
      (eMod, eType, eFunc) = headDef (([], "()", defaultErrorConversion))
                           . map errorInfo
                           . catMaybes
                           . map (\v -> find ((v ==) . dataType) $ errors ai)
                           $ maybeToList (fmap dataType $ chooseType (outputs ai)) ++ [XML, JSON]
      (lUrl, lPars) = linkToURL res lnk
      url      = string ("v" <+> show ver <+> "/") <++> "++" <++> lUrl
      fParams  = map (hsName . cleanName) lPars
              ++ maybe [] ((:[]) . hsName . cleanName . description) (ident ai)
              ++ maybe [] (const ["input"]) mInp
              ++ (if null (params ai) then [] else ["pList"])
      fType    = "ApiStateC m => "
              ++ (hsType $ map (\p -> (if p == res then "" else modName p ++ ".") ++ "Identifier") lPars
                       ++ maybe [] (return . Ident.haskellType) (ident ai)
                       ++ maybe [] (\(_,v,_,_) -> [v]) mInp
                       ++ (if null (params ai) then [] else ["[(String, String)]"])
                       ++ ["m (ApiResponse (" ++ eType ++ ") (" ++ oType ++ "))"])
  in ( mkStack $
        [ function (mkHsName ai) fType
        , hsDecl (mkHsName ai) fParams $
           hsLet
              [ "rHeaders" .=. hsArray [ hsTuple [code "hAccept", string oCType]
                                       , hsTuple [code "hContentType", string (maybe "text/plain" (\(_,_,v,_) -> v) mInp)]
                                       ]
              , "request" .=. "ApiRequest"
                                  <++> string (show (method ai))
                                  <++> parenthesis url
                                  <++> (if null (params ai) then "[]" else "pList")
                                  <++> "rHeaders"
                                  <++> "$"
                                  <++> maybe "\"\"" ((++ " input") . (\(_,_,_,v) -> v)) mInp
              ]
              $ "liftM (parseResult" <++> eFunc <++> oFunc <+> ") . doRequest $ request"
        ]
     , map ModuleName $ eMod ++ oMod ++ maybe [] (\(m,_,_,_) -> m) mInp
     )

linkToURL :: String -> Link -> (Code, [String])
linkToURL res lnk = first (\v -> "intercalate" <++> string "/" <++> parenthesis ("map encode $ concat" <++> hsArray v)) $ urlParts res lnk ([], [])

urlParts :: String -> Link -> ([Code], [String]) -> ([Code], [String])
urlParts res lnk ac@(rlnk, pars) =
  case lnk of
    [] -> ac
    (LResource r : a@(LAccess _) : xs) | not (hasParam a) -> urlParts res xs (rlnk ++ [hsArray [string r]], pars)
                                       | otherwise ->
      urlParts res xs
            ( rlnk ++ [ hsArray [string r]
                      , (if r == res then noCode else modName r <+> ".") <+> "readId" <++> hsName (cleanName r)
                      ]
            , pars ++ [r]
            )
    (LParam p : xs) -> urlParts res xs (rlnk ++ [hsArray ["showUrl" <++> hsName (cleanName p)]], pars)
    (i : xs) -> urlParts res xs (rlnk ++ [hsArray [string $ itemString i]], pars)

idData :: ApiResource -> Code
idData node =
  case resAccessors node of
    []  -> noCode
    [(pth,mi)] -> maybe noCode
           (\i -> mkStack
            [ code "type Identifier = " <++> Ident.haskellType i
            , function "readId" "Identifier -> [String]"
            , hsDecl "readId" ["x"] (hsArray $ if pth /= ""
                                               then [string pth, code "showUrl x"]
                                               else [code "showUrl x"]
                                    )
            ]
           )
           mi
    ls  -> mkStack $
            [ hsData "Identifier" $ map (\(pth,mi) -> dataName pth ++ maybe "" (\x -> " (" ++ Ident.haskellType x ++ ")") mi) ls
            , function "readId" "Identifier -> [String]"
            , mkStack $
                map (\(pth,mi) ->
                        if isJust mi
                          then hsDecl "readId" ["(" ++ dataName pth ++ " x" ++ ")"] $ hsArray [string pth, code "showUrl x"]
                          else hsDecl "readId" [dataName pth] $ hsArray [string pth]
                    ) ls
            ]

mkHsName :: ActionInfo -> String
mkHsName ai = hsName $ concatMap cleanName parts
  where
      parts = case actionType ai of
                Retrieve   -> let nm = get ++ by ++ target
                              in if null nm then ["access"] else nm
                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     = if target /= [] && (isJust (ident ai) || actionType ai == UpdateMany) then ["by"] else []
      get    = if isAccessor ai then [] else ["get"]

hsName :: [String] -> String
hsName []       = ""
hsName (x : xs) = clean $ downFirst x ++ concatMap upFirst xs
  where
    clean s = if s `elem` reservedNames then s ++ "_" else s
    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

modName :: String -> String
modName = concatMap upFirst . cleanName

dataName :: String -> String
dataName = modName

inputInfo :: DataDescription -> ([String], String, String, String)
inputInfo ds =
  case dataType ds of
    String -> ([], "String", "text/plain", "fromString")
    XML    -> (haskellModule ds, haskellType ds, "text/xml", "toXML")
    JSON   -> (haskellModule ds, haskellType ds, "text/json", "toJSON")
    File   -> ([], "ByteString", "application/octet-stream", "id")
    Other  -> ([], "ByteString", "text/plain", "id")

outputInfo :: DataDescription -> ([String], String, String, String)
outputInfo ds =
  case dataType ds of
    String -> ([], "String", "text/plain", "toString")
    XML    -> (haskellModule ds, haskellType ds, "text/xml", "fromXML")
    JSON   -> (haskellModule ds, haskellType ds, "text/json", "fromJSON")
    File   -> ([], "ByteString", "*", "id")
    Other  -> ([], "ByteString", "text/plain", "id")

errorInfo :: DataDescription -> ([String], String, String)
errorInfo ds =
  case dataType ds of
    String -> (haskellModule ds, haskellType ds, "fromXML")
    XML    -> (haskellModule ds, haskellType ds, "fromXML")
    JSON   -> (haskellModule ds, haskellType ds, "fromJSON")
    File   -> (haskellModule ds, haskellType ds, "fromXML")
    Other  -> (haskellModule ds, haskellType ds, "fromXML")