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