From 0666b8df5d4911bccfff903ee0934bea7eb67163 Mon Sep 17 00:00:00 2001 From: Eunchong Yu Date: Thu, 25 Aug 2016 03:26:29 +0900 Subject: [PATCH] Generalize CodeGen to use it for other targets (#67) * [WIP] * Replace CodeGen with StateT to contain context properly * Fix 'fail' method of (CodeGen a) * [WIP] * Generalize CodeGen --- nirum.cabal | 4 + src/Nirum/CodeGen.hs | 42 +++++ src/Nirum/Targets/Python.hs | 263 +++++++++++++++---------------- test/Nirum/CodeGenSpec.hs | 39 +++++ test/Nirum/Targets/PythonSpec.hs | 202 ++++++++++-------------- 5 files changed, 290 insertions(+), 260 deletions(-) create mode 100644 src/Nirum/CodeGen.hs create mode 100644 test/Nirum/CodeGenSpec.hs diff --git a/nirum.cabal b/nirum.cabal index 95eb894..0eb27b1 100644 --- a/nirum.cabal +++ b/nirum.cabal @@ -19,6 +19,7 @@ cabal-version: >=1.10 library exposed-modules: Nirum.Cli + , Nirum.CodeGen , Nirum.Constructs , Nirum.Constructs.Annotation , Nirum.Constructs.Annotation.Internal @@ -43,6 +44,7 @@ library , filepath >=1.4 && <1.5 , interpolatedstring-perl6 >=1.0.0 && <1.1.0 , megaparsec >=5 && <5.1 + , mtl >=2.2.1 && <3 , semver >=0.3.0 && <1.0 , text >=0.9.1.0 && <1.3 hs-source-dirs: src @@ -72,6 +74,7 @@ test-suite spec hs-source-dirs: test main-is: Spec.hs other-modules: Nirum.CliSpec + , Nirum.CodeGenSpec , Nirum.Constructs.AnnotationSpec , Nirum.Constructs.DocsSpec , Nirum.Constructs.DeclarationSetSpec @@ -98,6 +101,7 @@ test-suite spec , hspec-meta , interpolatedstring-perl6 >=1.0.0 && <1.1.0 , megaparsec >=5 && <5.1 + , mtl >=2.2.1 && <3 , nirum , process >=1.1 && <2 , semigroups diff --git a/src/Nirum/CodeGen.hs b/src/Nirum/CodeGen.hs new file mode 100644 index 0000000..b40099b --- /dev/null +++ b/src/Nirum/CodeGen.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +module Nirum.CodeGen ( CodeGen + , Failure + , fromString + , runCodeGen + ) where + +import Control.Applicative (Applicative) +import Control.Monad (Monad) +import Control.Monad.Except (MonadError, ExceptT(ExceptT), mapExceptT, runExceptT) +import Control.Monad.State (MonadState, State, mapState, runState) +import Data.Functor (Functor) + + +newtype CodeGen s e a = CodeGen (ExceptT e (State s) a) + deriving ( Applicative + , Functor + , MonadError e + , MonadState s + ) + +class Failure s a where + fromString :: MonadState s m => String -> m a + +instance (Failure s e) => Monad (CodeGen s e) where + return a = CodeGen $ ExceptT $ return (Right a) + {-# INLINE return #-} + (CodeGen m) >>= k = CodeGen $ ExceptT $ do + a <- runExceptT m + case a of + Left e -> return (Left e) + Right x -> let CodeGen n = k x in runExceptT n + {-# INLINE (>>=) #-} + fail str = CodeGen $ mapExceptT mutate (fromString str) + where + mutate = mapState (\(a, s) -> case a of + Left _ -> undefined + Right e -> (Left e, s)) + {-# INLINE fail #-} + +runCodeGen :: CodeGen s e a -> s -> (Either e a, s) +runCodeGen (CodeGen a) = runState (runExceptT a) diff --git a/src/Nirum/Targets/Python.hs b/src/Nirum/Targets/Python.hs index e3ff6bf..9c34951 100644 --- a/src/Nirum/Targets/Python.hs +++ b/src/Nirum/Targets/Python.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE ExtendedDefaultRules, OverloadedLists, QuasiQuotes #-} +{-# LANGUAGE ExtendedDefaultRules, OverloadedLists, QuasiQuotes, + TypeSynonymInstances, MultiParamTypeClasses #-} module Nirum.Targets.Python ( Code - , CodeGen( code - , localImports - , standardImports - , thirdPartyImports - ) + , CodeGen + , CodeGenContext ( localImports + , standardImports + , thirdPartyImports + ) , CompileError , InstallRequires ( InstallRequires , dependencies @@ -16,23 +17,24 @@ module Nirum.Targets.Python ( Code ) , addDependency , addOptionalDependency - , compileError , compileModule , compilePackage , compilePrimitiveType , compileTypeDeclaration , compileTypeExpression - , hasError + , emptyContext , toAttributeName , toClassName , toImportPath , toNamePair , unionInstallRequires - , withLocalImport - , withStandardImport - , withThirdPartyImports + , insertLocalImport + , insertStandardImport + , insertThirdPartyImports + , runCodeGen ) where +import Control.Monad.State (modify) import qualified Data.List as L import Data.Maybe (fromMaybe) import GHC.Exts (IsList(toList)) @@ -43,6 +45,8 @@ import qualified Data.Text as T import System.FilePath (joinPath) import Text.InterpolatedString.Perl6 (qq) +import qualified Nirum.CodeGen as C +import Nirum.CodeGen (Failure) import qualified Nirum.Constructs.DeclarationSet as DS import Nirum.Constructs.Identifier ( Identifier , toPascalCaseText @@ -95,65 +99,46 @@ data Source = Source { sourcePackage :: Package type Code = T.Text type CompileError = T.Text -data CodeGen a = CodeGen { standardImports :: S.Set T.Text - , thirdPartyImports :: M.Map T.Text (S.Set T.Text) - , localImports :: M.Map T.Text (S.Set T.Text) - , code :: a - } - | CodeGenError CompileError - deriving (Eq, Ord, Show) - -instance Functor CodeGen where - fmap f codeGen = pure f <*> codeGen - -instance Applicative CodeGen where - pure = return - c@CodeGen { code = f } <*> codeGen = codeGen >>= \x -> c { code = f x } - (CodeGenError m) <*> _ = CodeGenError m - -instance Monad CodeGen where - return code' = CodeGen { standardImports = [] - , thirdPartyImports = [] - , localImports = [] - , code = code' - } - (CodeGen si ti li c) >>= f = case f c of - (CodeGen si' ti' li' code') -> - let stdImports = S.union si si' - thirdPartyImports' = M.unionWith S.union ti ti' - localImports' = M.unionWith S.union li li' - in - CodeGen stdImports thirdPartyImports' localImports' code' - (CodeGenError m) -> CodeGenError m - (CodeGenError m) >>= _ = CodeGenError m - - fail = CodeGenError . T.pack - -hasError :: CodeGen a -> Bool -hasError (CodeGenError _) = True -hasError _ = False - -compileError :: CodeGen a -> Maybe CompileError -compileError CodeGen {} = Nothing -compileError (CodeGenError m) = Just m - -withStandardImport :: T.Text -> CodeGen a -> CodeGen a -withStandardImport module' c@CodeGen { standardImports = si } = - c { standardImports = S.insert module' si } -withStandardImport _ c@(CodeGenError _) = c - -withThirdPartyImports :: [(T.Text, S.Set T.Text)] -> CodeGen a -> CodeGen a -withThirdPartyImports imports c@CodeGen { thirdPartyImports = ti } = - c { thirdPartyImports = L.foldl (M.unionWith S.union) ti importList } +instance Failure CodeGenContext CompileError where + fromString = return . T.pack + +data CodeGenContext + = CodeGenContext { standardImports :: S.Set T.Text + , thirdPartyImports :: M.Map T.Text (S.Set T.Text) + , localImports :: M.Map T.Text (S.Set T.Text) + } + deriving (Eq, Ord, Show) + +emptyContext :: CodeGenContext +emptyContext = CodeGenContext { standardImports = [] + , thirdPartyImports = [] + , localImports = [] + } + +type CodeGen = C.CodeGen CodeGenContext CompileError + +runCodeGen :: CodeGen a -> CodeGenContext -> (Either CompileError a, CodeGenContext) +runCodeGen = C.runCodeGen + +insertStandardImport :: T.Text -> CodeGen () +insertStandardImport module' = modify insert' where + insert' c@CodeGenContext { standardImports = si } = + c { standardImports = S.insert module' si } + +insertThirdPartyImports :: [(T.Text, S.Set T.Text)] -> CodeGen () +insertThirdPartyImports imports = modify insert' + where + insert' c@CodeGenContext { thirdPartyImports = ti } = + c { thirdPartyImports = L.foldl (M.unionWith S.union) ti importList } importList :: [M.Map T.Text (S.Set T.Text)] importList = map (uncurry M.singleton) imports -withThirdPartyImports _ c@(CodeGenError _) = c -withLocalImport :: T.Text -> T.Text -> CodeGen a -> CodeGen a -withLocalImport module' object c@CodeGen { localImports = li } = - c { localImports = M.insertWith S.union module' [object] li } -withLocalImport _ _ c@(CodeGenError _) = c +insertLocalImport :: T.Text -> T.Text -> CodeGen () +insertLocalImport module' object = modify insert' + where + insert' c@CodeGenContext { localImports = li } = + c { localImports = M.insertWith S.union module' [object] li } -- | The set of Python reserved keywords. -- See also: https://docs.python.org/3/reference/lexical_analysis.html#keywords @@ -224,11 +209,11 @@ compileUnionTag source parentname typename' fields = do [name | Field name _ _ <- toList fields] ",\n " parentClass = toClassName' parentname - withStandardImport "typing" $ - withThirdPartyImports [ ("nirum.validate", ["validate_union_type"]) - , ("nirum.constructs", ["name_dict_type"]) - ] $ - return [qq| + insertStandardImport "typing" + insertThirdPartyImports [ ("nirum.validate", ["validate_union_type"]) + , ("nirum.constructs", ["name_dict_type"]) + ] + return [qq| class $className($parentClass): # TODO: docstring @@ -266,16 +251,16 @@ compilePrimitiveType primitiveTypeIdentifier = case primitiveTypeIdentifier of Bool -> return "bool" Bigint -> return "int" - Decimal -> withStandardImport "decimal" $ return "decimal.Decimal" + Decimal -> insertStandardImport "decimal" >> return "decimal.Decimal" Int32 -> return "int" Int64 -> return "int" Float32 -> return "float" Float64 -> return "float" Text -> return "str" Binary -> return "bytes" - Date -> withStandardImport "datetime" $ return "datetime.date" - Datetime -> withStandardImport "datetime" $ return "datetime.datetime" - Uuid -> withStandardImport "uuid" $ return"uuid.UUID" + Date -> insertStandardImport "datetime" >> return "datetime.date" + Datetime -> insertStandardImport "datetime" >> return "datetime.datetime" + Uuid -> insertStandardImport "uuid" >> return"uuid.UUID" Uri -> return "str" compileTypeExpression :: Source -> TypeExpression -> CodeGen Code @@ -283,17 +268,19 @@ compileTypeExpression Source { sourceModule = boundModule } (TypeIdentifier i) = case lookupType i boundModule of Missing -> fail $ "undefined identifier: " ++ toString i Imported _ (PrimitiveType p _) -> compilePrimitiveType p - Imported m _ -> - withThirdPartyImports [(toImportPath m, [toClassName i])] $ - return $ toClassName i + Imported m _ -> do + insertThirdPartyImports [(toImportPath m, [toClassName i])] + return $ toClassName i Local _ -> return $ toClassName i compileTypeExpression source (MapModifier k v) = do kExpr <- compileTypeExpression source k vExpr <- compileTypeExpression source v - withStandardImport "typing" $ return [qq|typing.Mapping[$kExpr, $vExpr]|] + insertStandardImport "typing" + return [qq|typing.Mapping[$kExpr, $vExpr]|] compileTypeExpression source modifier = do expr <- compileTypeExpression source typeExpr - withStandardImport "typing" $ return [qq|typing.$className[$expr]|] + insertStandardImport "typing" + return [qq|typing.$className[$expr]|] where typeExpr :: TypeExpression className :: T.Text @@ -318,14 +305,12 @@ compileTypeDeclaration src TypeDeclaration { typename = typename' , type' = BoxedType itype } = do let className = toClassName' typename' itypeExpr <- compileTypeExpression src itype - withStandardImport "typing" $ - withThirdPartyImports [ ("nirum.validate", ["validate_boxed_type"]) - , ("nirum.serialize", ["serialize_boxed_type"]) - , ( "nirum.deserialize" - , ["deserialize_boxed_type"] - ) - ] $ - return [qq| + insertStandardImport "typing" + insertThirdPartyImports [ ("nirum.validate", ["validate_boxed_type"]) + , ("nirum.serialize", ["serialize_boxed_type"]) + , ("nirum.deserialize", ["deserialize_boxed_type"]) + ] + return [qq| class $className: # TODO: docstring @@ -362,7 +347,8 @@ compileTypeDeclaration _ TypeDeclaration { typename = typename' [ [qq|{toAttributeName' memberName} = '{toSnakeCaseText bn}'|] | EnumMember memberName@(Name _ bn) _ <- toList members ] - withStandardImport "enum" $ return [qq| + insertStandardImport "enum" + return [qq| class $className(enum.Enum): # TODO: docstring @@ -395,16 +381,13 @@ compileTypeDeclaration src TypeDeclaration { typename = typename' toNamePair [name | Field name _ _ <- toList fields] ",\n " - withStandardImport "typing" $ - withThirdPartyImports [ ( "nirum.validate" - , ["validate_record_type"] - ) - , ("nirum.serialize", ["serialize_record_type"]) - , ( "nirum.deserialize" - , ["deserialize_record_type"]) - , ("nirum.constructs", ["name_dict_type"]) - ] $ - return [qq| + insertStandardImport "typing" + insertThirdPartyImports [ ("nirum.validate", ["validate_record_type"]) + , ("nirum.serialize", ["serialize_record_type"]) + , ("nirum.deserialize", ["deserialize_record_type"]) + , ("nirum.constructs", ["name_dict_type"]) + ] + return [qq| class $className: # TODO: docstring @@ -450,15 +433,13 @@ compileTypeDeclaration src TypeDeclaration { typename = typename' fieldCodes' = T.intercalate "\n\n" fieldCodes enumMembers = toIndentedCodes (\(t, b) -> [qq|$t = '{b}'|]) enumMembers' "\n " - withStandardImport "typing" $ - withStandardImport "enum" $ - withThirdPartyImports [ ( "nirum.serialize" - , ["serialize_union_type"]) - , ( "nirum.deserialize" - , ["deserialize_union_type"]) - , ("nirum.constructs", ["name_dict_type"]) - ] $ - return [qq| + insertStandardImport "typing" + insertStandardImport "enum" + insertThirdPartyImports [ ("nirum.serialize", ["serialize_union_type"]) + , ("nirum.deserialize", ["deserialize_union_type"]) + , ("nirum.constructs", ["name_dict_type"]) + ] + return [qq| class $className: __nirum_union_behind_name__ = '{toSnakeCaseText $ N.behindName typename'}' @@ -513,16 +494,16 @@ compileTypeDeclaration src ServiceDeclaration { serviceName = name clientMethods <- mapM compileClientMethod methods' let dummyMethods' = T.intercalate "\n\n" dummyMethods clientMethods' = T.intercalate "\n\n" clientMethods - withStandardImport "urllib.request" $ - withStandardImport "json" $ - withThirdPartyImports [ ("nirum.constructs", ["name_dict_type"]) - , ("nirum.deserialize", ["deserialize_meta"]) - , ("nirum.serialize", ["serialize_meta"]) - , ("nirum.rpc", [ "service_type" - , "client_type" - ]) - ] $ - return [qq| + insertStandardImport "urllib.request" + insertStandardImport "json" + insertThirdPartyImports [ ("nirum.constructs", ["name_dict_type"]) + , ("nirum.deserialize", ["deserialize_meta"]) + , ("nirum.serialize", ["serialize_meta"]) + , ("nirum.rpc", [ "service_type" + , "client_type" + ]) + ] + return [qq| class $className(service_type): __nirum_service_methods__ = \{ @@ -568,12 +549,12 @@ class {className}_Client(client_type, $className): rtypeExpr <- compileTypeExpression src rtype paramMetadata <- mapM compileParameterMetadata params' let paramMetadata' = commaNl paramMetadata - withThirdPartyImports [("nirum.constructs", ["name_dict_type"])] $ - return [qq|'{toAttributeName' mName}': \{ - '_return': $rtypeExpr, - '_names': name_dict_type([{paramNameMap params'}]), - {paramMetadata'} - \}|] + insertThirdPartyImports [("nirum.constructs", ["name_dict_type"])] + return [qq|'{toAttributeName' mName}': \{ + '_return': $rtypeExpr, + '_names': name_dict_type([{paramNameMap params'}]), + {paramMetadata'} + \}|] compileParameterMetadata :: Parameter -> CodeGen Code compileParameterMetadata (Parameter pName pType _) = do let pName' = toAttributeName' pName @@ -658,17 +639,17 @@ unionInstallRequires a b = compileModule :: Source -> Either CompileError (InstallRequires, Code) compileModule source = - case code' of - CodeGenError errMsg -> Left errMsg - CodeGen {} -> codeWithDeps $ [qq| -{imports $ standardImports code'} + case runCodeGen code' emptyContext of + (Left errMsg, _ ) -> Left errMsg + (Right code , context) -> codeWithDeps context $ [qq| +{imports $ standardImports context} -{fromImports $ localImports code'} +{fromImports $ localImports context} -{fromImports $ thirdPartyImports code'} +{fromImports $ thirdPartyImports context} -{code code'} - |] +{code} +|] where code' :: CodeGen T.Text code' = compileModuleBody source @@ -689,14 +670,16 @@ compileModule source = require :: T.Text -> T.Text -> S.Set T.Text -> S.Set T.Text require pkg module' set = if set `has` module' then S.singleton pkg else S.empty - deps :: S.Set T.Text - deps = require "nirum" "nirum" $ M.keysSet $ thirdPartyImports code' - optDeps :: M.Map (Int, Int) (S.Set T.Text) - optDeps = [ ((3, 4), require "enum34" "enum" $ standardImports code') - , ((3, 5), require "typing" "typing" $ standardImports code') - ] - codeWithDeps :: Code -> Either CompileError (InstallRequires, Code) - codeWithDeps c = Right (InstallRequires deps optDeps, c) + codeWithDeps :: CodeGenContext -> Code -> Either CompileError (InstallRequires, Code) + codeWithDeps context c = Right (InstallRequires deps optDeps, c) + where + deps :: S.Set T.Text + deps = require "nirum" "nirum" $ M.keysSet $ thirdPartyImports context + optDeps :: M.Map (Int, Int) (S.Set T.Text) + optDeps = + [ ((3, 4), require "enum34" "enum" $ standardImports context) + , ((3, 5), require "typing" "typing" $ standardImports context) + ] compilePackageMetadata :: Package -> InstallRequires -> Code compilePackageMetadata package (InstallRequires deps optDeps) = [qq| diff --git a/test/Nirum/CodeGenSpec.hs b/test/Nirum/CodeGenSpec.hs new file mode 100644 index 0000000..8f65f0b --- /dev/null +++ b/test/Nirum/CodeGenSpec.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, RankNTypes, MultiParamTypeClasses #-} +module Nirum.CodeGenSpec where + +import Control.Monad.Except (throwError) +import Control.Monad.State (modify) +import Data.Text as T (Text, pack) + +import Test.Hspec.Meta + +import Nirum.CodeGen (CodeGen, Failure, fromString, runCodeGen) + + +data SampleError = SampleError Text + deriving (Eq, Ord, Show) + +instance forall s. Failure s SampleError where + fromString = return . SampleError . T.pack + + +spec :: Spec +spec = parallel $ do + specify "fail" $ do + let codeGen' :: CodeGen Integer SampleError () = do + modify (+1) + modify (+1) + fail "test" + runCodeGen codeGen' 0 `shouldBe` (Left (SampleError "test"), 2) + let codeGen'' :: CodeGen Integer SampleError Integer = do + modify (+1) + _ <- fail "test" + modify (+1) + return 42 + runCodeGen codeGen'' 0 `shouldBe` (Left (SampleError "test"), 1) + specify "throwError" $ do + let codeGen' :: CodeGen Integer SampleError () = do + modify (+1) + _ <- throwError $ SampleError "test" + modify (+2) + runCodeGen codeGen' 0 `shouldBe` (Left (SampleError "test"), 1) diff --git a/test/Nirum/Targets/PythonSpec.hs b/test/Nirum/Targets/PythonSpec.hs index eeeac8b..fbf6e1f 100644 --- a/test/Nirum/Targets/PythonSpec.hs +++ b/test/Nirum/Targets/PythonSpec.hs @@ -22,6 +22,7 @@ import Data.Char (isSpace) import Data.Maybe (fromJust, isJust) import System.IO.Error (catchIOError) +import Data.Either (isRight) import Data.List (dropWhileEnd) import qualified Data.Map.Strict as M import qualified Data.Text as T @@ -77,11 +78,11 @@ import Nirum.Package (BoundModule(modulePath), Package, resolveBoundModule) import Nirum.PackageSpec (createPackage) import Nirum.Targets.Python ( Source (Source) , Code - , CodeGen( code - , localImports - , standardImports - , thirdPartyImports - ) + , CodeGen + , CodeGenContext ( localImports + , standardImports + , thirdPartyImports + ) , CompileError , InstallRequires ( InstallRequires , dependencies @@ -89,19 +90,19 @@ import Nirum.Targets.Python ( Source (Source) ) , addDependency , addOptionalDependency - , compileError , compilePackage , compilePrimitiveType , compileTypeExpression - , hasError + , emptyContext , toAttributeName , toClassName , toImportPath , toNamePair , unionInstallRequires - , withLocalImport - , withStandardImport - , withThirdPartyImports + , insertLocalImport + , insertStandardImport + , insertThirdPartyImports + , runCodeGen ) codeGen :: a -> CodeGen a @@ -283,142 +284,103 @@ makeDummySource' pathPrefix m = makeDummySource :: Module -> Source makeDummySource = makeDummySource' [] +run' :: CodeGen a -> (Either CompileError a, CodeGenContext) +run' c = runCodeGen c emptyContext + +code :: CodeGen a -> a +code = either (const undefined) id . fst . run' + +codeContext :: CodeGen a -> CodeGenContext +codeContext = snd . run' + +compileError :: CodeGen a -> Maybe CompileError +compileError cg = either Just (const Nothing) $ fst $ runCodeGen cg emptyContext + + spec :: Spec spec = parallel $ do describe "CodeGen" $ do - let v = 123 :: Int - cg = return v :: CodeGen Int - f = return . g :: Int -> CodeGen Int - f' = return . h :: Int -> CodeGen Int - g = (+ 5) :: Int -> Int - h = (* 2) :: Int -> Int - g' = pure g :: CodeGen (Int -> Int) - h' = pure h :: CodeGen (Int -> Int) - id' x = x - context "Functor" $ do - specify "identity morphisms" $ - fmap id' (return 123 :: CodeGen Int) `shouldBe` id' (return 123) - specify "composition of morphisms" $ do - fmap (g . h) cg `shouldBe` (fmap g . fmap h) cg - fmap (h . g) cg `shouldBe` (fmap h . fmap g) cg - context "Applicative" $ do - specify "identity law" $ - (pure id' <*> cg) `shouldBe` cg - specify "homomorphism" $ do - let pure' = pure :: a -> CodeGen a - (pure g <*> pure v) `shouldBe` pure' (g v) - (pure h <*> pure v) `shouldBe` pure' (h v) - specify "interchange" $ do - (g' <*> pure v) `shouldBe` (pure ($ v) <*> g') - (h' <*> pure v) `shouldBe` (pure ($ v) <*> h') - specify "composition" $ do - (g' <*> (h' <*> cg)) `shouldBe` (pure (.) <*> g' <*> h' <*> cg) - (h' <*> (g' <*> cg)) `shouldBe` (pure (.) <*> h' <*> g' <*> cg) - context "Monad" $ do - specify "left identity" $ do - (return v >>= f) `shouldBe` f v - (return v >>= f') `shouldBe` f' v - specify "right identity" $ - (cg >>= return) `shouldBe` cg - specify "associativity" $ do - ((cg >>= f) >>= f') `shouldBe` (cg >>= (\x -> f x >>= f')) - ((cg >>= f') >>= f) `shouldBe` (cg >>= (\x -> f' x >>= f)) + context "Monad" $ specify "packages and imports" $ do - let (c :: CodeGen Int) = do - a <- withStandardImport "sys" cg - b <- withThirdPartyImports - [("nirum", ["serialize_boxed_type"])] - cg - c' <- withLocalImport ".." "Gender" cg - d <- withStandardImport "os" cg - e <- withThirdPartyImports - [("nirum", ["serialize_enum_type"])] - cg - f'' <- withLocalImport ".." "Path" cg - return $ sum ([a, b, c', d, e, f''] :: [Int]) - c `shouldSatisfy` (not . hasError) - standardImports c `shouldBe` ["os", "sys"] - thirdPartyImports c `shouldBe` + let c = do + insertStandardImport "sys" + insertThirdPartyImports [("nirum", ["serialize_boxed_type"])] + insertLocalImport ".." "Gender" + insertStandardImport "os" + insertThirdPartyImports [("nirum", ["serialize_enum_type"])] + insertLocalImport ".." "Path" + let (e, ctx) = runCodeGen c emptyContext + e `shouldSatisfy` isRight + standardImports ctx `shouldBe` ["os", "sys"] + thirdPartyImports ctx `shouldBe` [("nirum", ["serialize_boxed_type", "serialize_enum_type"])] - localImports c `shouldBe` [("..", ["Gender", "Path"])] - code c `shouldBe` (123 * 6) - specify "withStandardImport" $ do - let codeGen1 = withStandardImport "sys" (pure True) - codeGen1 `shouldSatisfy` (not . hasError) - standardImports codeGen1 `shouldBe` ["sys"] - thirdPartyImports codeGen1 `shouldBe` [] - localImports codeGen1 `shouldBe` [] - code codeGen1 `shouldBe` True + localImports ctx `shouldBe` [("..", ["Gender", "Path"])] + specify "insertStandardImport" $ do + let codeGen1 = insertStandardImport "sys" + let (e1, ctx1) = runCodeGen codeGen1 emptyContext + e1 `shouldSatisfy` isRight + standardImports ctx1 `shouldBe` ["sys"] + thirdPartyImports ctx1 `shouldBe` [] + localImports ctx1 `shouldBe` [] compileError codeGen1 `shouldBe` Nothing - let codeGen2 = withStandardImport "os" codeGen1 - codeGen2 `shouldSatisfy` (not . hasError) - standardImports codeGen2 `shouldBe` ["os", "sys"] - thirdPartyImports codeGen2 `shouldBe` [] - localImports codeGen2 `shouldBe` [] - code codeGen2 `shouldBe` True + let codeGen2 = codeGen1 >> insertStandardImport "os" + let (e2, ctx2) = runCodeGen codeGen2 emptyContext + e2 `shouldSatisfy` isRight + standardImports ctx2 `shouldBe` ["os", "sys"] + thirdPartyImports ctx2 `shouldBe` [] + localImports ctx2 `shouldBe` [] compileError codeGen2 `shouldBe` Nothing - specify "fail" $ do - let codeGen' = do - val <- withStandardImport "sys" (pure True) - _ <- fail "test" - withStandardImport "sys" (pure val) - compileError codeGen' `shouldBe` Just "test" specify "compilePrimitiveType" $ do code (compilePrimitiveType Bool) `shouldBe` "bool" code (compilePrimitiveType Bigint) `shouldBe` "int" - let decimal = compilePrimitiveType Decimal - code decimal `shouldBe` "decimal.Decimal" - standardImports decimal `shouldBe` ["decimal"] + let (decimalCode, decimalContext) = run' (compilePrimitiveType Decimal) + decimalCode `shouldBe` Right "decimal.Decimal" + standardImports decimalContext `shouldBe` ["decimal"] code (compilePrimitiveType Int32) `shouldBe` "int" code (compilePrimitiveType Int64) `shouldBe` "int" code (compilePrimitiveType Float32) `shouldBe` "float" code (compilePrimitiveType Float64) `shouldBe` "float" code (compilePrimitiveType Text) `shouldBe` "str" code (compilePrimitiveType Binary) `shouldBe` "bytes" - let date = compilePrimitiveType Date - code date `shouldBe` "datetime.date" - standardImports date `shouldBe` ["datetime"] - let datetime = compilePrimitiveType Datetime - code datetime `shouldBe` "datetime.datetime" - standardImports datetime `shouldBe` ["datetime"] - let uuid = compilePrimitiveType Uuid - code uuid `shouldBe` "uuid.UUID" - standardImports uuid `shouldBe` ["uuid"] + let (dateCode, dateContext) = run' (compilePrimitiveType Date) + dateCode `shouldBe` Right "datetime.date" + standardImports dateContext `shouldBe` ["datetime"] + let (datetimeCode, datetimeContext) = run' (compilePrimitiveType Datetime) + datetimeCode `shouldBe` Right "datetime.datetime" + standardImports datetimeContext `shouldBe` ["datetime"] + let (uuidCode, uuidContext) = run' (compilePrimitiveType Uuid) + uuidCode `shouldBe` Right "uuid.UUID" + standardImports uuidContext `shouldBe` ["uuid"] code (compilePrimitiveType Uri) `shouldBe` "str" describe "compileTypeExpression" $ do let s = makeDummySource $ Module [] Nothing specify "TypeIdentifier" $ do - let c = compileTypeExpression s (TypeIdentifier "bigint") - c `shouldSatisfy` (not . hasError) - standardImports c `shouldBe` [] - localImports c `shouldBe` [] - code c `shouldBe` "int" + let (c, ctx) = run' $ compileTypeExpression s (TypeIdentifier "bigint") + standardImports ctx `shouldBe` [] + localImports ctx `shouldBe` [] + c `shouldBe` Right "int" specify "OptionModifier" $ do - let c' = compileTypeExpression s (OptionModifier "text") - c' `shouldSatisfy` (not . hasError) - standardImports c' `shouldBe` ["typing"] - localImports c' `shouldBe` [] - code c' `shouldBe` "typing.Optional[str]" + let (c', ctx') = run' $ compileTypeExpression s (OptionModifier "text") + standardImports ctx' `shouldBe` ["typing"] + localImports ctx' `shouldBe` [] + c' `shouldBe` Right "typing.Optional[str]" specify "SetModifier" $ do - let c'' = compileTypeExpression s (SetModifier "text") - c'' `shouldSatisfy` (not . hasError) - standardImports c'' `shouldBe` ["typing"] - localImports c'' `shouldBe` [] - code c'' `shouldBe` "typing.AbstractSet[str]" + let (c'', ctx'') = run' $ compileTypeExpression s (SetModifier "text") + standardImports ctx'' `shouldBe` ["typing"] + localImports ctx'' `shouldBe` [] + c'' `shouldBe` Right "typing.AbstractSet[str]" specify "ListModifier" $ do - let c''' = compileTypeExpression s (ListModifier "text") - c''' `shouldSatisfy` (not . hasError) - standardImports c''' `shouldBe` ["typing"] - localImports c''' `shouldBe` [] - code c''' `shouldBe` "typing.Sequence[str]" + let (c''', ctx''') = run' $ compileTypeExpression s (ListModifier "text") + standardImports ctx''' `shouldBe` ["typing"] + localImports ctx''' `shouldBe` [] + c''' `shouldBe` Right "typing.Sequence[str]" specify "MapModifier" $ do - let c'''' = compileTypeExpression s (MapModifier "uuid" "text") - c'''' `shouldSatisfy` (not . hasError) - standardImports c'''' `shouldBe` ["uuid", "typing"] - localImports c'''' `shouldBe` [] - code c'''' `shouldBe` "typing.Mapping[uuid.UUID, str]" + let (c'''', ctx'''') = run' $ compileTypeExpression s (MapModifier "uuid" "text") + standardImports ctx'''' `shouldBe` ["uuid", "typing"] + localImports ctx'''' `shouldBe` [] + c'''' `shouldBe` Right "typing.Mapping[uuid.UUID, str]" describe "toClassName" $ do it "transform the facial name of the argument into PascalCase" $ do