content: {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  module TW.CodeGen.Haskell
      ( makeFileName, makeModule
      , libraryInfo
      )
  where
  
  import TW.Ast
  import TW.BuiltIn
  import TW.JsonRepr
  import TW.Types
  import TW.Utils
  
  import Data.Char
  import Data.Maybe
  import Data.Monoid
  import System.FilePath
  import qualified Data.List as L
  import qualified Data.Text as T
  
  libraryInfo :: LibraryInfo
  libraryInfo = LibraryInfo "Haskell" "typed-wire-utils" "0.1.0.0"
  
  aesonQual :: T.Text
  aesonQual = "Data_Aeson_Lib"
  
  aeson :: T.Text -> T.Text
  aeson x = aesonQual <> "." <> x
  
  makeFileName :: ModuleName -> FilePath
  makeFileName (ModuleName parts) =
      (L.foldl' (</>) "" $ map T.unpack parts) ++ ".hs"
  
  makeModule :: Module -> T.Text
  makeModule m =
      T.unlines
      [ "{-# OPTIONS_GHC -fno-warn-unused-imports #-}"
      , "{-# LANGUAGE OverloadedStrings #-}"
      , "-- | This file was auto generated by typed-wire. Do not modify by hand"
      , "module " <> printModuleName (m_name m) <> " where"
      , ""
      , T.intercalate "\n" (map makeImport $ m_imports m)
      , ""
      , "import qualified Text.TypedWire as HLib"
      , "import Control.Applicative"
      , "import Control.Monad (join)"
      , "import Data.Time"
      , "import qualified Data.Aeson as " <> aesonQual
      , "import qualified Data.Text as T"
      , "import qualified Data.Vector as V"
      , if not (null (m_apis m)) then "import Web.Spock\nimport Control.Monad.Trans" else ""
      , ""
      , T.intercalate "\n" (map makeTypeDef $ m_typeDefs m)
      , T.intercalate "\n" (map makeApiDef $ m_apis m)
      ]
  
  makeImport :: ModuleName -> T.Text
  makeImport m =
      "import qualified " <> printModuleName m
  
  makeApiDef :: ApiDef -> T.Text
  makeApiDef ad =
      T.unlines
      [ "data " <> handlerType <> " m"
      , "   = " <> handlerType
      , "   { " <> T.intercalate "\n   , " (map makeEndPoint $ ad_endpoints ad)
      , "   }"
      , fromMaybe "" $ makeHeaderDef apiHeaderType ahprefix (ad_headers ad)
      , T.intercalate "\n" (mapMaybe (\ep -> makeHeaderDef (headerType ep) (hprefix ep) (aed_headers ep)) $ ad_endpoints ad)
      , "wire" <> apiCapitalized <> " :: MonadIO m => " <> handlerType <> " (ActionCtxT ctx m) -> SpockCtxT ctx m ()"
      , "wire" <> apiCapitalized <> " handler ="
      , "    do " <> T.intercalate "\n       " (map makeEndPointImpl $ ad_endpoints ad)
      ]
      where
        apiCapitalized = capitalizeText (unApiName $ ad_name ad)
        handlerType = "ApiHandler" <> apiCapitalized
        apiHeaderType = handlerType <> "Headers"
        headerType ep = handlerType <> capitalizeText (unEndpointName (aed_name ep)) <> "Headers"
        hprefix ep = makeFieldPrefix $ TypeName (headerType ep)
        ahprefix = makeFieldPrefix $ TypeName apiHeaderType
        prefix = makeFieldPrefix $ TypeName handlerType
        makeHeaderDef tyName tyPrefix headerList =
          case headerList of
            [] -> Nothing
            _ ->
              Just $ T.unlines
              [ "data " <> tyName
              , "   = " <> tyName
              , "   { " <> T.intercalate "\n   , " (mapMaybe makeHeaderField headerList)
              , "   }"
              ]
          where
            makeHeaderField h =
              case ah_value h of
                ApiHeaderValueStatic _ -> Nothing
                ApiHeaderValueDynamic ->
                  Just $
                  tyPrefix <> makeSafePrefixedFieldName (ah_name h) <> " :: !T.Text"
        makeEndPoint ep =
          prefix <> unEndpointName (aed_name ep) <> " :: "
          <> (if not (null $ ad_headers ad) then apiHeaderType <> " -> " else "")
          <> (if not (null $ aed_headers ep) then headerType ep <> " -> " else "")
          <> T.intercalate " -> " (map makeType pathTypes)
          <> (if not (null pathTypes) then " -> " else "")
          <> maybe "" (\x -> makeType x <> " -> ") (aed_req ep)
          <> "m " <> makeType (aed_resp ep) <> ""
          where
            pathTypes =
              flip mapMaybe (aed_route ep) $ \x ->
              case x of
                ApiRouteDynamic dyn -> Just dyn
                _ -> Nothing
        makeHeaderLoader tyName headerList =
          "do {"
          <> T.intercalate "" (map makeGetter headerList)
          <> T.intercalate "" (mapMaybe makeChecker headerList)
          <> "return (" <> tyName <> " " <> T.intercalate " " (mapMaybe makeSetter headerList) <> ");"
          <> "}"
          where
            varName h = "hp" <> makeSafePrefixedFieldName (ah_name h)
            makeGetter h =
              varName h <> " <- header " <> T.pack (show (ah_name h)) <> " >>= maybe jumpNext return;"
            makeChecker h =
              case ah_value h of
                ApiHeaderValueStatic val ->
                  Just $ "when (" <> varName h <> " /= " <> T.pack (show val) <> ") jumpNext; "
                _ -> Nothing
            makeSetter h =
              case ah_value h of
                ApiHeaderValueDynamic -> Just (varName h)
                _ -> Nothing
        makeEndPointImpl ep =
          "hookRoute " <> (T.pack $ show $ aed_verb ep)  <> " ("
          <> T.intercalate " <//> " (map makePathComp  $ aed_route ep) <> ") $ "
          <> (if not (null pathVars) then "\\" <> T.intercalate " " pathVars <> " -> " else "")
          <> "do {"
          <> (if not (null (ad_headers ad)) then "apiHeaders <- " <> makeHeaderLoader apiHeaderType (ad_headers ad) <> "; " else "")
          <> (if not (null (aed_headers ep)) then "localHeaders <- " <> makeHeaderLoader (headerType ep) (aed_headers ep) <> "; " else "")
          <> maybe "" (const "reqVal <- jsonBody';") (aed_req ep)
          <> "out <- " <> prefix <> unEndpointName (aed_name ep) <> " handler "
          <> (if not (null (ad_headers ad)) then "apiHeaders " else "")
          <> (if not (null (aed_headers ep)) then "localHeaders " else "")
          <> T.intercalate " " pathVars
          <> " "
          <> maybe "" (const "reqVal ") (aed_req ep)
          <> ";"
          <> "json out;"
          <> "}"
          where
            pathVars =
              map ((\(i :: Int) -> T.pack $ "pv" ++ show i) . snd) $
              flip zip [0..] $
              flip mapMaybe (aed_route ep) $ \x ->
              case x of
                ApiRouteDynamic _ -> Just ()
                _ -> Nothing
            makePathComp pc =
              case pc of
                ApiRouteStatic str -> T.pack (show str)
                ApiRouteDynamic _ -> "var"
  
  makeTypeDef :: TypeDef -> T.Text
  makeTypeDef td =
      case td of
        TypeDefEnum ed ->
            makeEnumDef ed
        TypeDefStruct sd ->
            makeStructDef sd
  
  makeFieldPrefix :: TypeName -> T.Text
  makeFieldPrefix (TypeName name) =
      (T.toLower $ T.filter isUpper name) <> "_"
  
  makeStructDef :: StructDef -> T.Text
  makeStructDef sd =
      T.unlines
      [ "data " <> fullType
      , "   = " <> unTypeName (sd_name sd)
      , "   { " <> T.intercalate "\n   , " (map (makeStructField (makeFieldPrefix $ sd_name sd)) $ sd_fields sd)
      , "   } deriving (Show, Read, Eq, Ord)"
      , ""
      , "instance " <> aesonPreds (sd_args sd) (aeson "ToJSON") <> aeson "ToJSON" <> " (" <> fullType <> ") where"
      , "    toJSON (" <> unTypeName (sd_name sd) <> " " <> funArgs <> ") ="
      , "        " <> aeson "object"
      , "        [ " <> T.intercalate "\n        , " (map makeToJsonFld $ sd_fields sd)
      , "        ]"
      , "instance " <> aesonPreds (sd_args sd) (aeson "FromJSON") <> aeson "FromJSON" <> " (" <> fullType <> ") where"
      , "    parseJSON ="
      , "        " <> aeson "withObject" <> " " <> T.pack (show $ unTypeName (sd_name sd)) <> " $ \\obj ->"
      , "        " <> unTypeName (sd_name sd)
      , "        <$> " <> T.intercalate "\n        <*> " (map makeFromJsonFld $ sd_fields sd)
      ]
      where
        jArg fld = "j_" <> (unFieldName $ sf_name fld)
        makeFromJsonFld fld =
            let name = unFieldName $ sf_name fld
            in case sf_type fld of
                 (TyCon q _) | q == (bi_name tyMaybe) ->
                    "(join <$> (obj " <> aeson ".:?" <> " " <> T.pack (show name) <> "))"
                 _ -> "obj " <> aeson ".:" <> " " <> T.pack (show name)
        makeToJsonFld fld =
            let name = unFieldName $ sf_name fld
                argName = jArg fld
            in "(" <> T.pack (show name) <> " " <> aeson ".=" <> " " <> argName <> ")"
        funArgs =
            T.intercalate " " $ map jArg (sd_fields sd)
        fullType =
            unTypeName (sd_name sd) <> " " <> T.intercalate " " (map unTypeVar $ sd_args sd)
  
  aesonPreds :: [TypeVar] -> T.Text -> T.Text
  aesonPreds args tyClass =
      if null args
      then ""
      else let mkPred (TypeVar tv) =
                   tyClass <> " " <> tv
           in "(" <> T.intercalate "," (map mkPred args) <> ") => "
  
  makeEnumDef :: EnumDef -> T.Text
  makeEnumDef ed =
      T.unlines
      [ "data " <> fullType
      , "   = " <> T.intercalate "\n   | " (map makeEnumChoice $ ed_choices ed)
      , "     deriving (Show, Read, Eq, Ord)"
      , ""
      , "instance " <> aesonPreds (ed_args ed) (aeson "ToJSON") <> aeson "ToJSON" <> " (" <> fullType <> ") where"
      , "    toJSON x ="
      , "        case x of"
      , "          " <> T.intercalate "\n          " (map mkToJsonChoice $ ed_choices ed)
      , "instance " <> aesonPreds (ed_args ed) (aeson "FromJSON") <> aeson "FromJSON" <> " (" <> fullType <> ") where"
      , "    parseJSON = "
      , "        " <> aeson "withObject" <> " " <> T.pack (show $ unTypeName (ed_name ed)) <> " $ \\obj ->"
      , "        " <> T.intercalate "\n        <|> " (map mkFromJsonChoice $ ed_choices ed)
      ]
      where
        mkFromJsonChoice ec =
            let constr = unChoiceName $ ec_name ec
                tag = camelTo2 '_' $ T.unpack constr
                (op, opEnd) =
                    case ec_arg ec of
                      Nothing -> ("<$ (HLib.eatBool <$> (", "))")
                      Just _ -> ("<$>", "")
            in "(" <> constr <> " " <> op <> " obj " <> (aeson ".:") <> " " <> T.pack (show tag) <> opEnd <> ")"
        mkToJsonChoice ec =
            let constr = unChoiceName $ ec_name ec
                tag = camelTo2 '_' $ T.unpack constr
                (argParam, argVal) =
                    case ec_arg ec of
                      Nothing -> ("", "True")
                      Just _ -> ("y", "y")
            in constr <> " " <> argParam <> " -> " <> aeson "object"
               <> " [" <> T.pack (show tag) <> " " <> aeson ".=" <> " " <> argVal <> "]"
        fullType =
            unTypeName (ed_name ed) <> " " <> T.intercalate " " (map unTypeVar $ ed_args ed)
  
  makeEnumChoice :: EnumChoice -> T.Text
  makeEnumChoice ec =
      (unChoiceName $ ec_name ec) <> fromMaybe "" (fmap ((<>) " !" . makeType) $ ec_arg ec)
  
  
  makeStructField :: T.Text -> StructField -> T.Text
  makeStructField prefix sf =
      prefix <> (unFieldName $ sf_name sf) <> " :: !" <> (makeType $ sf_type sf)
  
  makeType :: Type -> T.Text
  makeType t =
      case isBuiltIn t of
        Nothing ->
            case t of
              TyVar (TypeVar x) -> x
              TyCon qt args ->
                  let ty = makeQualTypeName qt
                  in case args of
                       [] -> ty
                       _ -> "(" <> ty <> " " <> T.intercalate " " (map makeType args) <> ")"
        Just (bi, tvars)
            | bi == tyString -> "T.Text"
            | bi == tyInt -> "Int"
            | bi == tyBool -> "Bool"
            | bi == tyFloat -> "Double"
            | bi == tyMaybe -> "(Maybe " <> T.intercalate " " (map makeType tvars) <> ")"
            | bi == tyBytes -> "HLib.AsBase64"
            | bi == tyList -> "(V.Vector " <> T.intercalate " " (map makeType tvars) <> ")"
            | bi == tyDateTime -> "UTCTime"
            | bi == tyTime -> "TimeOfDay"
            | bi == tyDate -> "Day"
            | otherwise ->
                error $ "Haskell: Unimplemented built in type: " ++ show t
  
  makeQualTypeName :: QualTypeName -> T.Text
  makeQualTypeName qtn =
      case unModuleName $ qtn_module qtn of
        [] -> ty
        _ -> printModuleName (qtn_module qtn) <> "." <> ty
      where
        ty = unTypeName $ qtn_type qtn
  