content: {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  module TW.CodeGen.PureScript
      ( makeFileName, makeModule
      , libraryInfo
      )
  where
  
  import TW.Ast
  import TW.BuiltIn
  import TW.JsonRepr
  import TW.Types
  import TW.Utils
  
  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 "Purescript" "purescript-typed-wire" "0.2.0"
  
  makeFileName :: ModuleName -> FilePath
  makeFileName (ModuleName parts) =
      (L.foldl' (</>) "" $ map T.unpack parts) ++ ".purs"
  
  makeModule :: Module -> T.Text
  makeModule m =
      T.unlines
      [ "module " <> printModuleName (m_name m) <> " where"
      , ""
      , T.intercalate "\n" (map makeImport $ m_imports m)
      , ""
      , "import Data.TypedWire.Prelude"
      , if not (null (m_apis m)) then "import Data.TypedWire.Api" else ""
      , ""
      , T.intercalate "\n" (map makeTypeDef $ m_typeDefs m)
      , T.intercalate "\n" (map makeApiDef $ m_apis m)
      ]
  
  makeApiDef :: ApiDef -> T.Text
  makeApiDef ad =
      T.unlines $
      catMaybes
      [ apiHeader
      , Just $ T.intercalate "\n" (map makeEndPoint (ad_endpoints ad))
      ]
      where
        apiHeader =
          case not (null (ad_headers ad)) of
            True -> Just $ makeHeaderType apiHeaderType (ad_headers ad)
            False -> Nothing
        apiCapitalized = capitalizeText (unApiName $ ad_name ad)
        handlerType = "ApiHandler" <> apiCapitalized
        apiHeaderType = handlerType <> "Headers"
        headerType ep = handlerType <> capitalizeText (unEndpointName (aed_name ep)) <> "Headers"
        makeHeaderName hdr = uncapitalizeText $ makeSafePrefixedFieldName (ah_name hdr)
        makeHeaderType ty headers =
          T.unlines
          [ "type " <> ty <> " = "
          , "    { " <> T.intercalate "\n    , " (map makeHeaderField headers)
          , "    }"
          ]
        makeHeaderField hdr =
          makeHeaderName hdr <> " :: String"
        makeEndPoint ep =
          T.unlines $
          catMaybes
          [ epHeader
          , Just $ funName <> " :: forall m. (Monad m) => "
            <> (maybe "" (const $ apiHeaderType <> " -> ") apiHeader)
            <> (maybe "" (const $ headerType ep <> " -> ") epHeader)
            <> urlParamSig
            <> (maybe "" (\t -> makeType t <> " -> ") $ aed_req ep)
            <> "ApiCall m " <> (maybe "Unit" makeType $ aed_req ep) <> " " <> makeType (aed_resp ep)
          , Just $ funName
            <> " "
            <> (maybe "" (const "apiHeaders ") apiHeader)
            <> (maybe "" (const "endpointHeaders ") epHeader)
            <> urlParams
            <> (maybe "" (const "reqBody ") $ aed_req ep)
            <> "runRequest = do"
          , Just $ "    let coreHeaders = [" <> T.intercalate ", " (map (headerPacker "apiHeaders") $ ad_headers ad) <> "]"
          , Just $ "    let fullHeaders = coreHeaders ++ [" <> T.intercalate ", " (map (headerPacker "endpointHeaders") $ aed_headers ep) <> "]"
          , Just $ "    let url = " <> T.intercalate " ++ \"/\" ++ " (map urlPacker routeInfo)
          , Just $ "    let method = " <> T.pack (show $ aed_verb ep)
          , Just $ "    let body = " <> (maybe "Nothing" (const "Just $ encodeJson reqBody") $ aed_req ep)
          , Just $ "    let req = { headers: fullHeaders, method: method, body: body, url: url }"
          , Just $ "    resp <- runRequest req"
          , Just $ "    return $ if (resp.statusCode /= 200) then Left \"Return code was not 200\" else decodeJson resp.body"
          ]
          where
            urlPacker (r, p) =
              case r of
                ApiRouteStatic t -> T.pack (show t)
                ApiRouteDynamic _ -> "toPathPiece p" <> T.pack (show p) <> ""
            headerPacker apiVar hdr =
               "{ key: " <> T.pack (show $ ah_name hdr) <> ", value: " <> apiVar <> "." <> makeHeaderName hdr <> " }"
            funName = unApiName (ad_name ad) <> capitalizeText (unEndpointName $ aed_name ep)
            routeInfo = zip (aed_route ep) ([0..] :: [Int])
            urlParams =
              T.concat $ flip mapMaybe routeInfo $ \(r,p) ->
              case r of
                ApiRouteStatic _ -> Nothing
                ApiRouteDynamic _ -> Just $ "p" <> T.pack (show p) <> " "
            urlParamSig =
              T.concat $ flip mapMaybe (aed_route ep) $ \r ->
              case r of
                ApiRouteStatic _ -> Nothing
                ApiRouteDynamic ty -> Just (makeType ty <> " -> ")
            epHeader =
              case not (null (aed_headers ep)) of
                True -> Just $ makeHeaderType (headerType ep) (aed_headers ep)
                False -> Nothing
  
  makeImport :: ModuleName -> T.Text
  makeImport m =
      "import qualified " <> printModuleName m <> " as " <> printModuleName m
  
  makeTypeDef :: TypeDef -> T.Text
  makeTypeDef td =
      case td of
        TypeDefEnum ed ->
            makeEnumDef ed
        TypeDefStruct sd ->
            makeStructDef sd
  
  decoderName :: TypeName -> T.Text
  decoderName ty = "dec" <> unTypeName ty
  
  encoderName :: TypeName -> T.Text
  encoderName ty = "enc" <> unTypeName ty
  
  eqName :: TypeName -> T.Text
  eqName ty = "eq" <> unTypeName ty
  
  showName :: TypeName -> T.Text
  showName ty = "show" <> unTypeName ty
  
  makeStructDef :: StructDef -> T.Text
  makeStructDef sd =
      T.unlines
      [ "data " <> fullType
      , "   = " <> unTypeName (sd_name sd)
      , "   { " <> T.intercalate "\n   , " (map makeStructField $ sd_fields sd)
      , "   }"
      , ""
      , "instance " <> eqName (sd_name sd) <> " :: "
        <> tcPreds (sd_args sd) ["Eq"] <> "Eq (" <> fullType <> ") where "
        <> "eq (" <> justType <> " a) (" <> justType <> " b) = "
        <> T.intercalate " && " (map makeFieldEq (sd_fields sd))
      , "instance " <> showName (sd_name sd) <> " :: "
        <> tcPreds (sd_args sd) ["Show"] <> "Show (" <> fullType <> ") where "
        <> "show (" <> justType <> " a) = " <> T.pack (show justType) <> " ++ \"{\" ++ "
        <> T.intercalate " ++ \", \" ++ " (map makeFieldShow (sd_fields sd))
        <> " ++ \"}\""
      , "instance " <> encoderName (sd_name sd) <> " :: "
        <> tcPreds (sd_args sd) ["EncodeJson"] <> "EncodeJson" <> " (" <> fullType <> ") where"
      , "    encodeJson (" <> unTypeName (sd_name sd) <> " objT) ="
      , "        " <> T.intercalate "\n         ~> " (map makeToJsonFld $ sd_fields sd)
      , "        ~> jsonEmptyObject"
      , "instance " <> decoderName (sd_name sd) <> " :: "
        <> tcPreds (sd_args sd) ["DecodeJson"] <> "DecodeJson" <> " (" <> fullType <> ") where"
      , "    decodeJson jsonT = do"
      , "        objT <- decodeJson jsonT"
      , "        " <> T.intercalate "\n        " (map makeFromJsonFld $ sd_fields sd)
      , "        pure $ " <> unTypeName (sd_name sd) <> " { " <> T.intercalate ", " (map makeFieldSetter $ sd_fields sd) <> " }"
      ]
      where
        makeFieldShow fld =
            let name = unFieldName $ sf_name fld
            in  T.pack (show name) <> " ++ \": \" ++ show a." <> name
        makeFieldEq fld =
            let name = unFieldName $ sf_name fld
            in  "a." <> name <> " == " <> "b." <> name
        makeFieldSetter fld =
            let name = unFieldName $ sf_name fld
            in name <> " : " <> "v" <> name
        makeFromJsonFld fld =
            let name = unFieldName $ sf_name fld
            in case sf_type fld of
                 (TyCon q _) | q == bi_name tyMaybe ->
                    "v" <> name <> " <- objT .?? " <> T.pack (show name)
                 _ ->
                    "v" <> name <> " <- objT .? " <> T.pack (show name)
        makeToJsonFld fld =
            let name = unFieldName $ sf_name fld
            in T.pack (show name) <> " " <> ":=" <> " objT." <> name
        justType = unTypeName (sd_name sd)
        fullType =
            unTypeName (sd_name sd) <> " " <> T.intercalate " " (map unTypeVar $ sd_args sd)
  
  makeStructField :: StructField -> T.Text
  makeStructField sf =
      unFieldName (sf_name sf) <> " :: " <> makeType (sf_type sf)
  
  tcPreds :: [TypeVar] -> [T.Text] -> T.Text
  tcPreds args tyClasses =
      if null args
      then ""
      else let mkPred (TypeVar tv) =
                   T.intercalate "," $ flip map tyClasses $ \tyClass -> 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)
      , ""
      , "instance " <> eqName (ed_name ed) <> " :: "
        <> tcPreds (ed_args ed) ["Eq"] <> "Eq (" <> fullType <> ") where "
      , "    " <> T.intercalate "\n    " (map makeChoiceEq $ ed_choices ed)
      , "    eq _ _ = false"
      , "instance " <> showName (ed_name ed) <> " :: "
        <> tcPreds (ed_args ed) ["Show"] <> "Show (" <> fullType <> ") where "
      , "    " <> T.intercalate "\n    " (map makeChoiceShow $ ed_choices ed)
      , "instance " <> encoderName (ed_name ed) <> " :: "
        <> tcPreds (ed_args ed) ["EncodeJson"] <> "EncodeJson" <> " (" <> fullType <> ") where"
      , "    encodeJson x ="
      , "        case x of"
      , "          " <> T.intercalate "\n          " (map mkToJsonChoice $ ed_choices ed)
      , "instance " <> decoderName (ed_name ed) <> " :: "
        <> tcPreds (ed_args ed) ["DecodeJson"] <> "DecodeJson" <> " (" <> fullType <> ") where"
      , "    decodeJson jsonT ="
      , "        decodeJson jsonT >>= \\objT -> "
      , "        " <> T.intercalate "\n        <|> " (map mkFromJsonChoice $ ed_choices ed)
      ]
      where
        makeChoiceShow ec =
            let constr = unChoiceName $ ec_name ec
            in case ec_arg ec of
                   Nothing -> "show (" <> constr <> ") = " <> T.pack (show constr)
                   Just _ -> "show (" <> constr <> " a) = " <> T.pack (show constr) <> " ++ \" \" ++ show a"
        makeChoiceEq ec =
            let constr = unChoiceName $ ec_name ec
            in case ec_arg ec of
                   Nothing -> "eq (" <> constr <> ") (" <> constr <> ") = true"
                   Just _ -> "eq (" <> constr <> " a) (" <> constr <> " b) = a == b"
        mkFromJsonChoice ec =
            let constr = unChoiceName $ ec_name ec
                tag = camelTo2 '_' $ T.unpack constr
                (op, opEnd) =
                    case ec_arg ec of
                      Nothing -> ("<$ (eatBool <$> (", "))")
                      Just _ -> ("<$>", "")
            in "(" <> constr <> " " <> op <> " objT " <> ".?" <> " " <> 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 <> " -> "
               <> " " <> T.pack (show tag) <> " " <> " := " <> " " <> argVal <> " ~> jsonEmptyObject"
        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)
  
  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 -> "String"
            | bi == tyInt -> "Int"
            | bi == tyBool -> "Boolean"
            | bi == tyFloat -> "Number"
            | bi == tyMaybe -> "(Maybe " <> T.intercalate " " (map makeType tvars) <> ")"
            | bi == tyBytes -> "AsBase64"
            | bi == tyList -> "(Array " <> T.intercalate " " (map makeType tvars) <> ")"
            | bi == tyDateTime -> "DateTime"
            | 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
  