diff --git a/servant-csharp.cabal b/servant-csharp.cabal --- a/servant-csharp.cabal +++ b/servant-csharp.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: servant-csharp -version: 0.0.7.1 +version: 0.0.8.0 synopsis: Generate servant client library for C# description: Generate servant client library for C# homepage: https://github.com/cutsea110/servant-csharp.git @@ -20,15 +20,20 @@ exposed-modules: CS , CS.Common , CS.JsonDotNet + , CS.JsonDotNet.Base + , CS.JsonDotNet.Internal + , CS.JsonDotNet.Internal.Types -- other-modules: other-extensions: OverloadedStrings , ScopedTypeVariables , MultiParamTypeClasses , FlexibleContexts , FlexibleInstances + , TupleSections , TypeSynonymInstances , QuasiQuotes - build-depends: base >=4.8 && <4.9 + build-depends: aeson >= 0.11.1.4 + , base >=4.8 && <4.9 , bytestring >=0.10 && <0.11 , directory >=1.2 && <1.3 , filepath >=1.4 && <1.5 @@ -36,10 +41,14 @@ , heredocs >=0.1 && <0.2 , http-types >=0.9 && <0.10 , lens >=4.13 && <4.14 + , mtl >= 2.2.1 , servant >= 0.6.1 , servant-foreign >=0.7 && <0.8 + , servant-swagger >= 1.0.3 + , swagger2 >= 2.0.2 , text >=1.2 && <1.3 , time >=1.5 && <1.6 + , unordered-containers >= 0.2.7.0 , uuid >=1.3 && <1.4 , uuid-types >=1.0 && <1.1 hs-source-dirs: src diff --git a/src/CS.hs b/src/CS.hs --- a/src/CS.hs +++ b/src/CS.hs @@ -1,17 +1,4 @@ -module CS ( genCsForAPI - - , classCsForAPI - , classCsForAPIWith - , apiCsForAPI - , apiCsForAPIWith - , enumCsForAPI - , enumCsForAPIWith - , converterCsForAPI - , converterCsForAPIWith - , assemblyInfoCsForAPI - , assemblyInfoCsForAPIWith - , csprojForAPI - , csprojForAPIWith +module CS ( generateCsForAPI , GenerateCsConfig(..) , def diff --git a/src/CS/JsonDotNet.hs b/src/CS/JsonDotNet.hs --- a/src/CS/JsonDotNet.hs +++ b/src/CS/JsonDotNet.hs @@ -1,255 +1,91 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -module CS.JsonDotNet ( genCsForAPI +{-# LANGUAGE TupleSections #-} +module CS.JsonDotNet ( GenerateCsConfig(..) + , def - , classCsForAPI - , classCsForAPIWith - , apiCsForAPI - , apiCsForAPIWith - , enumCsForAPI - , enumCsForAPIWith - , converterCsForAPI - , converterCsForAPIWith - , assemblyInfoCsForAPI - , assemblyInfoCsForAPIWith - , csprojForAPI - , csprojForAPIWith + , generateCsForAPI - , GenerateCsConfig(..) - , def + , apiCsFrom + , enumCs + , classCs + , converterCs + , assemblyInfoCs + , projectCsproj ) where -import Prelude hiding (concat, lines, unlines) -import Control.Arrow + +import Control.Arrow ((***), (&&&)) import Control.Lens hiding ((<.>)) +import Control.Monad.Trans +import Control.Monad.Identity +import Data.Aeson import Data.ByteString (ByteString) import Data.ByteString.Char8 as BC (unpack) import Data.Char (toUpper, toLower) -import Data.List (intercalate, concat) +import qualified Data.HashMap.Lazy as M +import Data.List (intercalate) import Data.Maybe (fromJust) import Data.Monoid ((<>)) import Data.Proxy -import Data.Text as T (Text, unpack, pack) +import Data.Swagger hiding (namespace) +import Data.Text as T (Text, unpack) import Data.Time.Clock (UTCTime(..), getCurrentTime) import Data.Time.Calendar (toGregorian) -import Data.UUID.Types (toString) +import System.Directory (createDirectoryIfMissing) +import System.FilePath ((),(<.>)) +import Data.UUID.Types (toString, UUID) import Data.UUID.V4 as UUID (nextRandom) -import Language.Haskell.Exts import Servant.Foreign -import System.Directory (createDirectoryIfMissing) -import System.FilePath ((), (<.>)) +import Servant.Swagger import Text.Heredoc import CS.Common (CSharp, getEndpoints) +import CS.JsonDotNet.Internal +import CS.JsonDotNet.Base data GenerateCsConfig = GenerateCsConfig { namespace :: String - , outdir :: String , classCsName :: String , apiCsName :: String , enumCsName :: String , converterCsName :: String - , classtemplate :: GenerateCsConfig -> IO String - , apitemplate :: forall api. - (HasForeign CSharp Text api, - GenerateList Text (Foreign Text api)) - => GenerateCsConfig - -> Proxy api - -> IO String - , enumtemplate :: GenerateCsConfig -> IO String - , convertertemplate :: GenerateCsConfig -> IO String - , assemblyinfotemplate :: GenerateCsConfig -> IO String - , csprojtemplate :: GenerateCsConfig -> IO String - , guid :: Maybe String - , sources :: [FilePath] + , guid :: Maybe UUID } def :: GenerateCsConfig def = GenerateCsConfig { namespace = "ServantClientAPI" - , outdir = "gen" , classCsName = "Classes.cs" , apiCsName = "API.cs" , enumCsName = "Enum.cs" , converterCsName = "JsonConverter.cs" - , classtemplate = defClassTemplate - , apitemplate = defAPITemplate - , enumtemplate = defEnumTemplate - , convertertemplate = defConvTemplate - , assemblyinfotemplate = defAssemblyInfoTemplate - , csprojtemplate = defCsprojTemplate , guid = Nothing - , sources = [] } -genCsForAPI :: (HasForeign CSharp Text api, - GenerateList Text (Foreign Text api)) => - GenerateCsConfig -> Proxy api -> IO () -genCsForAPI conf api = do - guid' <- maybe (toString <$> UUID.nextRandom) return $ guid conf - let conf' = conf { guid = Just guid' } - createDirectoryIfMissing True $ outdir conf' namespace conf' "Properties" - classCsForAPIWith conf' >>= writeFile (outdir conf' namespace conf' classCsName conf') - apiCsForAPIWith conf' api >>= writeFile (outdir conf' namespace conf' apiCsName conf') - enumCsForAPIWith conf' >>= writeFile (outdir conf' namespace conf' enumCsName conf') - converterCsForAPIWith conf' >>= writeFile (outdir conf' namespace conf' converterCsName conf') - assemblyInfoCsForAPIWith conf' >>= writeFile (outdir conf' namespace conf' "Properties" "AssemblyInfo.cs") - csprojForAPIWith conf' >>= writeFile (outdir conf' namespace conf' namespace conf' <.> "csproj") - -------------------------------------------------------------------------- -isDatatypeDecl :: Decl -> Bool -isDatatypeDecl (DataDecl _ DataType _ _ _ [qcon] _) = True -isDatatypeDecl _ = False -data FieldType = TInt - | TString - | TDay - | TUTCTime - | TEnum String - | TGeneral String - | TNewtype String FieldType - | TList FieldType - | TNullable FieldType - -instance Show FieldType where - show TInt = "int" - show TString = "string" - show TDay = "DateTime" - show TUTCTime = "DateTime" - show (TEnum s) = s - show (TGeneral s) = s - show (TNewtype s _) = s - show (TList t) = "List<"<>show t<>">" - show (TNullable TInt) = "int?" - show (TNullable TString) = "string" - show (TNullable TDay) = "DateTime?" - show (TNullable TUTCTime) = "DateTime?" - show (TNullable (TEnum t)) = show (TEnum t)<>"?" - show (TNullable (TNewtype s TString)) = s - show (TNullable (TNewtype s _)) = "Nullable<"<>s<>">" - show (TNullable t) = "Nullable<"<>show t<>">" - -showCSharpOriginalType :: FieldType -> String -showCSharpOriginalType TInt = "System.Int64" -showCSharpOriginalType TString = "System.String" -showCSharpOriginalType _ = error "don't support this type." - -classTypes :: GenerateCsConfig -> IO [(String, [(String, FieldType)])] -classTypes conf = do - enums <- fmap (map fst) $ enumTypes conf - aliases <- usingAliases conf - classTypesFromFiles enums aliases (sources conf) - where - classTypesFromFiles :: [String] -> [(String, FieldType)] -> [FilePath] - -> IO [(String, [(String, FieldType)])] - classTypesFromFiles enums aliases hss - = return . concat =<< mapM (classTypesFromFile enums aliases) hss - - classTypesFromFile :: [String] -> [(String, FieldType)] -> FilePath - -> IO [(String, [(String, FieldType)])] - classTypesFromFile enums aliases hs = do - ParseOk (Module _ _ _ _ _ _ decls) <- parseFile hs - let xs = filter isDatatypeDecl decls - return $ map toClass xs - where - toClass (DataDecl _ _ _ _ _ [qcon] _) - = toClass' qcon - toClass' (QualConDecl _ _ _ (RecDecl (Ident name) fs)) - = (name, map field fs) - field ((Ident fname):[], ts) - = (fname, toType ts) - toType :: Type -> FieldType - toType (TyCon (UnQual (Ident t))) - = case t of - "String" -> TString - "Text" -> TString - "Int" -> TInt - "Integer" -> TInt - "Day" -> TDay - "UTCTime" -> TUTCTime - _ -> if t `elem` enums - then TEnum t - else maybe (TGeneral t) (TNewtype t) - $ lookup t aliases - toType (TyApp (TyCon (UnQual (Ident "Maybe"))) t) - = case toType t of - TList t -> TList t - t -> TNullable t - toType (TyList t) = TList (toType t) - toType _ = error "don't support this Type" - --------------------------------------------------------------------------- -isEnumLikeDataDecl :: Decl -> Bool -isEnumLikeDataDecl (DataDecl _ DataType _ _ _ xs _) - = all isEnumLikeConDecl xs -isEnumLikeDataDecl _ = False - -isEnumLikeConDecl :: QualConDecl -> Bool -isEnumLikeConDecl (QualConDecl _ _ _ (ConDecl _ [])) = True -isEnumLikeConDecl _ = False - -enumTypes :: GenerateCsConfig -> IO [(String, [String])] -enumTypes = enumTypesFromFiles . sources - where - enumTypesFromFiles :: [FilePath] -> IO [(String, [String])] - enumTypesFromFiles hss - = return . concat =<< mapM enumTypesFromFile hss - - enumTypesFromFile :: FilePath -> IO [(String, [String])] - enumTypesFromFile hs = do - ParseOk (Module _ _ _ _ _ _ decls) <- parseFile hs - let xs = filter isEnumLikeDataDecl decls - return $ map toTuple xs - where - conName :: QualConDecl -> String - conName (QualConDecl _ _ _ (ConDecl (Ident name) [])) = name - conName _ = error "invalid enum type" - toTuple (DataDecl _ _ _ (Ident name) _ xs _) - = (name, map conName xs) - --------------------------------------------------------------------------- --- | TODO : more typeable -isNewtypeDecl :: Decl -> Bool -isNewtypeDecl (DataDecl _ NewType _ _ _ _ _) = True -isNewtypeDecl _ = False - -isTypeDecl :: Decl -> Bool -isTypeDecl (TypeDecl _ _ _ _) = True -isTypeDecl _ = False - -origType :: QualConDecl -> FieldType -origType (QualConDecl _ _ _ (RecDecl _ [(_, tycon)])) - = origType' tycon - -origType' :: Type -> FieldType -origType' (TyCon (UnQual (Ident t))) - = case t of - "String" -> TString - "Text" -> TString - "Int" -> TInt - "Integer" -> TInt - t -> error ("don't supported type. "<>t) - -usingAliases :: GenerateCsConfig -> IO [(String, FieldType)] -usingAliases = usingAliasesFromFiles . sources - where - usingAliasesFromFiles :: [FilePath] -> IO [(String, FieldType)] - usingAliasesFromFiles hss - = return . concat =<< mapM usingAliasesFromFile hss - - usingAliasesFromFile :: FilePath -> IO [(String, FieldType)] - usingAliasesFromFile hs = do - ParseOk (Module _ _ _ _ _ _ decls) <- parseFile hs - let xs = filter (\d -> isNewtypeDecl d || isTypeDecl d) decls - return $ map toTuple xs - where - toTuple (DataDecl _ NewType _ (Ident name) _ [qcon] _) - = (name, origType qcon) - toTuple (TypeDecl _ (Ident name) _ tycon) - = (name, origType' tycon) +-- | generate C# project +generateCsForAPI :: (HasSwagger api, HasForeign CSharp Text api, + GenerateList Text (Foreign Text api)) => + GenerateCsConfig -> Proxy api -> IO () +generateCsForAPI conf api = do + let outDir = "gen" namespace conf + swagger = toSwagger api + writeFile (outDir "AssemblyInfo.cs") =<< assemblyInfoCs conf + writeFile (outDir namespace conf <.> "csproj") =<< projectCsproj conf + writeFile (outDir classCsName conf) + $ runSwagger (classCs conf) swagger + writeFile (outDir enumCsName conf) + $ runSwagger enumCs swagger + writeFile (outDir converterCsName conf) + $ runSwagger (converterCs conf) swagger + writeFile (outDir apiCsName conf) + $ runSwagger (apiCsFrom conf api) swagger -------------------------------------------------------------------------- retType :: Req Text -> String @@ -329,85 +165,11 @@ requestBodyExists :: Req Text -> Bool requestBodyExists = not . null . rqBody -classCsForAPI :: IO String -classCsForAPI = classCsForAPIWith def - -classCsForAPIWith :: GenerateCsConfig -> IO String -classCsForAPIWith conf = (classtemplate conf) conf - -apiCsForAPI :: (HasForeign CSharp Text api, - GenerateList Text (Foreign Text api)) => - Proxy api -> IO String -apiCsForAPI = apiCsForAPIWith def - -apiCsForAPIWith :: (HasForeign CSharp Text api, - GenerateList Text (Foreign Text api)) => - GenerateCsConfig -> Proxy api -> IO String -apiCsForAPIWith conf api = (apitemplate conf) conf api - -enumCsForAPI :: IO String -enumCsForAPI = enumCsForAPIWith def - -enumCsForAPIWith :: GenerateCsConfig -> IO String -enumCsForAPIWith conf = (enumtemplate conf) conf - -converterCsForAPI :: IO String -converterCsForAPI = converterCsForAPIWith def - -converterCsForAPIWith :: GenerateCsConfig -> IO String -converterCsForAPIWith conf = (convertertemplate conf) conf - -defClassTemplate :: GenerateCsConfig -> IO String -defClassTemplate conf = do - uas <- usingAliases conf - classes <- classTypes conf - return [heredoc|/* generated by servant-csharp */ -using Newtonsoft.Json; -using Newtonsoft.Json.Converters; -using System; -using System.Collections.Generic; - -#region type alias -$forall (n, t) <- uas - using ${n} = ${showCSharpOriginalType t}; -#endregion - -namespace ${namespace conf} -{ - $forall (name, fields) <- classes - #region ${name} - [JsonObject("${name}")] - public class ${name} - { - $forall (fname, ftype) <- fields - $case ftype - $of TDay - [JsonProperty(PropertyName = "${fname}")] - [JsonConverter(typeof(DayConverter))] - $of TNullable TDay - [JsonProperty(PropertyName = "${fname}")] - [JsonConverter(typeof(DayConverter))] - $of TEnum _ - [JsonProperty(PropertyName = "${fname}")] - [JsonConverter(typeof(StringEnumConverter))] - $of TNullable (TEnum _) - [JsonProperty(PropertyName = "${fname}")] - [JsonConverter(typeof(StringEnumConverter))] - $of TList (TEnum _) - [JsonProperty(PropertyName = "${fname}", ItemConverterType = typeof(StringEnumConverter))] - $of _ - [JsonProperty(PropertyName = "${fname}")] - public ${show ftype} ${fname} { get; set; } - } - #endregion -} -|] - -defAPITemplate :: (HasForeign CSharp Text api, - GenerateList Text (Foreign Text api)) => - GenerateCsConfig -> Proxy api -> IO String -defAPITemplate conf api = do - uas <- usingAliases conf +apiCsFrom :: (Monad m, HasForeign CSharp Text api, + GenerateList Text (Foreign Text api)) => + GenerateCsConfig -> Proxy api -> SwagT m String +apiCsFrom conf api = do + uas <- prims return [heredoc|/* generated by servant-csharp */ using Newtonsoft.Json; using System.Collections.Generic; @@ -420,7 +182,7 @@ #region type alias $forall (n, t) <- uas - using ${n} = ${showCSharpOriginalType t}; + using ${T.unpack n} = ${showCSharpOriginalType t}; #endregion namespace ${namespace conf} @@ -499,29 +261,206 @@ } |] -defEnumTemplate conf = do - es <- enumTypes conf +-------------------------------------------------------------------------- + +defs :: Monad m => SwagT m [(Text, Schema)] +defs = mkSwag (M.toList . _swaggerDefinitions) + +pathitems :: Monad m => SwagT m [(FilePath, PathItem)] +pathitems = mkSwag (M.toList . _swaggerPaths) + +convProperty :: Monad m => ParamName -> Referenced Schema -> Bool + -> SwagT m (ParamName, FieldType) +convProperty pname rs req + = if req + then convProp pname rs + else do + (n, f) <- convProp pname rs + return (n, FNullable f) + where + convProp :: Monad m + => ParamName + -> Referenced Schema + -> SwagT m (ParamName, FieldType) + convProp n (Ref (Reference s)) = convRef n s + convProp n (Inline s) = convert (n, s) + +convRef :: Monad m + => ParamName -> Text -> SwagT m (ParamName, FieldType) +convRef pname tname = do + fs <- enums <> prims <> models + case lookup tname fs of + Just ftype -> return $ (pname, conv ftype) + Nothing -> error $ T.unpack $ "not found " <> pname + where + conv :: FieldType -> FieldType + conv f | isFEnum f = FRefEnum tname + | isFPrim f = FRefPrim tname f + | isFObj f = FRefObject tname + +convObject :: Monad m => (Text, Schema) -> SwagT m (Text, FieldType) +convObject (name, s) = do + return . (name,) . FObject name =<< fields + where + fields :: Monad m => SwagT m [(ParamName, FieldType)] + fields = mapM (\(p, s) -> (convProperty p s (isReq p))) props + props :: [(ParamName, Referenced Schema)] + props = M.toList (_schemaProperties s) + isReq :: ParamName -> Bool + isReq pname = pname `elem` reqs + reqs :: [ParamName] + reqs = _schemaRequired s + +convert :: Monad m => (Text, Schema) -> SwagT m (Text, FieldType) +convert (name, s) = do + if not $ null enums' + then return $ (name, FEnum name enums') + else case type' of + SwaggerString -> maybe (return (name, FString)) + convByFormat + format' + SwaggerInteger -> return (name, FInteger) + SwaggerNumber -> return (name, FNumber) + SwaggerBoolean -> return (name, FBool) + SwaggerArray -> maybe (error "fail to convert SwaggerArray") + convByItemType + items' + SwaggerNull -> error "convert don't support SwaggerNull yet" + SwaggerObject -> convObject (name, s) + where + param' = _schemaParamSchema s + items' = _paramSchemaItems param' + type' = _paramSchemaType param' + enums' = maybe [] id $ _paramSchemaEnum param' + format' = _paramSchemaFormat param' + convByFormat :: Monad m => Text -> SwagT m (Text, FieldType) + convByFormat "date" = return (name, FDay) + convByFormat "yyyy-mm-ddThh:MM:ssZ" = return (name, FUTCTime) + convByItemType :: Monad m + => SwaggerItems Schema -> SwagT m (Text, FieldType) + convByItemType (SwaggerItemsObject (Ref (Reference s))) = do + (n, t) <- convRef name s + return (n, FList t) + convByItemType (SwaggerItemsPrimitive _ _) + = error "don't support SwaggerItemsPrimitive yet" + convByItemType (SwaggerItemsArray _) + = error "don't support SwaggerItemsArray yet" + +enums :: Monad m => SwagT m [(Text, FieldType)] +enums = filterM (return.isFEnum.snd) =<< mapM convert =<< defs + +prims :: Monad m => SwagT m [(Text, FieldType)] +prims = filterM (return.isFPrim.snd) =<< mapM convert =<< defs + +models :: Monad m => SwagT m [(Text, FieldType)] +models = filterM (return.isFObj.snd) =<< mapM convert =<< defs +enumCs :: Monad m => SwagT m String +enumCs = do + es <- mapM (return.snd) =<< enums return [heredoc|/* generated by servant-csharp */ -namespace ${namespace conf} +namespace ServantClientBook { - $forall (name, cs) <- es - #region ${name} - public enum ${name} + $forall FEnum name cs <- es + #region ${T.unpack name} + public enum ${T.unpack name} { - $forall c <- cs - ${c}, + $forall String c <- cs + ${T.unpack c}, } #endregion } |] -defConvTemplate conf = do +showCSharpOriginalType :: FieldType -> String +showCSharpOriginalType FInteger = "System.Int64" +showCSharpOriginalType FNumber = "System.Double" +showCSharpOriginalType FString = "System.String" +showCSharpOriginalType FDay = "System.DateTime" +showCSharpOriginalType FUTCTime = "System.DateTime" +showCSharpOriginalType _ = error "don't support this type." + +show' :: FieldType -> String +show' FInteger = "int" +show' FNumber = "double" +show' FString = "string" +show' FBool = "bool" +show' FDay = "DateTime" +show' FUTCTime = "DateTime" +show' (FEnum name _) = T.unpack name +show' (FObject name _) = T.unpack name +show' (FList t) = "List<" <> show' t <> ">" +show' (FNullable t) = case nullable t of + CVal -> show' t <> "?" + CRef -> show' t + CSt -> "Nullable<" <> show' t <> ">" +show' (FRefObject name) = T.unpack name +show' (FRefEnum name) = T.unpack name +show' (FRefPrim name _) = T.unpack name + +converterType :: FieldType -> ConverterType +converterType FDay = DayConv +converterType (FRefPrim _ FDay) = DayConv +converterType (FEnum _ _) = EnumConv +converterType (FRefEnum _) = EnumConv +converterType (FNullable t) = converterType t +converterType (FList t) = case converterType t of + DayConv -> ItemConv DayConv + EnumConv -> ItemConv EnumConv + t' -> t' +converterType _ = NoConv + + +classCs :: Monad m => GenerateCsConfig -> SwagT m String +classCs conf = do + ps <- prims + ms <- models return [heredoc|/* generated by servant-csharp */ using Newtonsoft.Json; +using Newtonsoft.Json.Converters; using System; +using System.Collections.Generic; +#region type alias +$forall (n, t) <- ps + using ${T.unpack n} = ${showCSharpOriginalType t}; +#endregion + namespace ${namespace conf} { + $forall (_, FObject name' fields) <- ms + $let name = T.unpack name' + #region ${name} + [JsonObject("${name}")] + public class ${name} + { + $forall (fname', ftype) <- fields + $let fname = T.unpack fname' + $case converterType ftype + $of DayConv + [JsonProperty(PropertyName = "${fname}")] + [JsonConverter(typeof(DayConverter))] + $of ItemConv DayConv + [JsonProperty(PropertyName = "${fname}", ItemConverterType = typeof(DayConverter))] + $of EnumConv + [JsonProperty(PropertyName = "${fname}")] + [JsonConverter(typeof(StringEnumConverter))] + $of ItemConv EnumConv + [JsonProperty(PropertyName = "${fname}", ItemConverterType = typeof(StringEnumConverter))] + $of _ + [JsonProperty(PropertyName = "${fname}")] + public ${show' ftype} ${fname} { get; set; } + } + #endregion +} +|] + +converterCs :: Monad m => GenerateCsConfig -> SwagT m String +converterCs conf = return [heredoc|/* generated by servant-csharp */ +using Newtonsoft.Json; +using System; + +namespace ${namespace conf} +{ public class DayConverter : JsonConverter { public override bool CanConvert(Type objectType) @@ -543,18 +482,10 @@ } |] --------------------------------------------------------------------------- - -assemblyInfoCsForAPI :: IO String -assemblyInfoCsForAPI = assemblyInfoCsForAPIWith def - -assemblyInfoCsForAPIWith :: GenerateCsConfig -> IO String -assemblyInfoCsForAPIWith conf = (assemblyinfotemplate conf) conf - -defAssemblyInfoTemplate :: GenerateCsConfig -> IO String -defAssemblyInfoTemplate conf = do +assemblyInfoCs :: GenerateCsConfig -> IO String +assemblyInfoCs conf = do (year, _, _) <- fmap (toGregorian . utctDay) getCurrentTime - guid <- maybe (toString <$> UUID.nextRandom) return $ guid conf + guid' <- maybe UUID.nextRandom return $ guid conf return [heredoc| using System.Reflection; using System.Runtime.CompilerServices; @@ -571,31 +502,25 @@ [assembly: ComVisible(false)] -[assembly: Guid("${guid}")] +[assembly: Guid("${toString guid'}")] // [assembly: AssemblyVersion("1.0.*")] [assembly: AssemblyVersion("1.0.0.0")] [assembly: AssemblyFileVersion("1.0.0.0")] |] --------------------------------------------------------------------------- - -csprojForAPI :: IO String -csprojForAPI = csprojForAPIWith def - -csprojForAPIWith :: GenerateCsConfig -> IO String -csprojForAPIWith conf = (csprojtemplate conf) conf - -defCsprojTemplate :: GenerateCsConfig -> IO String -defCsprojTemplate conf = do - guid <- maybe ((map toUpper . toString) <$> UUID.nextRandom) return $ guid conf +projectCsproj :: GenerateCsConfig -> IO String +projectCsproj conf = do + guid' <- maybe ((map toUpper . toString) <$> UUID.nextRandom) + (return . toString) + $ guid conf return [heredoc| Debug AnyCPU - {${guid}} + {${guid'}} Library Properties ${namespace conf} diff --git a/src/CS/JsonDotNet/Base.hs b/src/CS/JsonDotNet/Base.hs new file mode 100644 --- /dev/null +++ b/src/CS/JsonDotNet/Base.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE FlexibleInstances #-} +module CS.JsonDotNet.Base where + +import Control.Monad.Trans +import Control.Monad.Identity +import Data.Proxy +import Data.Swagger hiding (namespace) +import Servant.Swagger + +type Swag = SwagT Identity + +runSwagger :: Swag a -> Swagger -> a +runSwagger f = runIdentity . runSwagT f + +mkSwag :: Monad m => (Swagger -> a) -> SwagT m a +mkSwag f = SwagT (return . f) + +generateFrom :: HasSwagger api => Swag a -> Proxy api -> a +f `generateFrom` api = runSwagger f (toSwagger api) + +newtype SwagT m a = SwagT { runSwagT :: Swagger -> m a } +instance Monad m => Functor (SwagT m) where + fmap f x = SwagT $ \sw -> return . f =<< runSwagT x sw +instance Monad m => Applicative (SwagT m) where + pure x = SwagT $ \sw -> return x + f <*> g = SwagT $ \sw -> do + f' <- runSwagT f sw + g' <- runSwagT g sw + return (f' g') +instance Monad m => Monad (SwagT m) where + f >>= k = SwagT $ \sw -> + runSwagT f sw >>= \f' -> + runSwagT (k f') sw + +instance Monad m => Monoid (SwagT m [a]) where + mempty = SwagT $ \sw -> return mempty + x `mappend` y = SwagT $ \sw -> do + x' <- runSwagT x sw + y' <- runSwagT y sw + return $ x' `mappend` y' + +instance MonadTrans SwagT where + lift m = SwagT $ \sw -> m + +instance MonadIO m => MonadIO (SwagT m) where + liftIO x = SwagT $ \sw -> liftIO x diff --git a/src/CS/JsonDotNet/Internal.hs b/src/CS/JsonDotNet/Internal.hs new file mode 100644 --- /dev/null +++ b/src/CS/JsonDotNet/Internal.hs @@ -0,0 +1,4 @@ +module CS.JsonDotNet.Internal ( module CS.JsonDotNet.Internal.Types + ) where + +import CS.JsonDotNet.Internal.Types diff --git a/src/CS/JsonDotNet/Internal/Types.hs b/src/CS/JsonDotNet/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/CS/JsonDotNet/Internal/Types.hs @@ -0,0 +1,60 @@ +module CS.JsonDotNet.Internal.Types where + +import Data.Aeson +import Data.Text + +data FieldType = FInteger + | FNumber + | FString + | FBool + | FDay + | FUTCTime + | FEnum Text [Value] + | FObject Text [(Text, FieldType)] + | FList FieldType + | FNullable FieldType + + | FRefObject Text + | FRefEnum Text + | FRefPrim Text FieldType + deriving Show + +isFEnum :: FieldType -> Bool +isFEnum (FEnum _ _) = True +isFEnum _ = False + +isFPrim :: FieldType -> Bool +isFPrim FString = True +isFPrim FInteger = True +isFPrim FNumber = True +isFPrim FBool = True +isFPrim FDay = True +isFPrim FUTCTime = True +isFPrim _ = False + +isFObj :: FieldType -> Bool +isFObj (FObject _ _) = True +isFObj _ = False + +data CCate = CVal | CRef | CSt deriving Show + +nullable :: FieldType -> CCate +nullable FInteger = CVal +nullable FNumber = CVal +nullable FString = CRef +nullable FBool = CVal +nullable FDay = CVal +nullable FUTCTime = CVal +nullable (FEnum _ _) = CSt +nullable (FObject _ _) = CSt +nullable (FList _) = CRef +nullable (FNullable _) = CRef +nullable (FRefObject _) = CVal +nullable (FRefEnum _) = CVal +nullable (FRefPrim _ t) = nullable t + +data ConverterType = NoConv + | DayConv + | EnumConv + | ItemConv ConverterType + deriving Show