type-machine-0.1.0.0: test/TypeMachine/FunctionsSpec.hs
module TypeMachine.FunctionsSpec (spec) where
import Control.Exception.Base
import Control.Monad
import Data.Either (isLeft)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Language.Haskell.TH hiding (bang)
import Test.Hspec
import TypeMachine
import TypeMachine.Log
import TypeMachine.TM (execTM)
import TypeMachine.Type (Type (..))
spec :: Spec
spec =
describe
"Functions"
$ do
let bang = Bang NoSourceUnpackedness NoSourceStrictness
idKey = "id"
nameKey = "name"
otherPropKey = "otherProp"
userIdType = (bang, ConT $ mkName "Int")
userNameType = (bang, ConT $ mkName "String")
userOtherPropRequiredType = ConT $ mkName "String"
userOtherPropType = (bang, AppT (ConT $ mkName "Maybe") userOtherPropRequiredType)
typeWithVar =
Type
(mkName "TypeWithVar")
( Map.fromList
[ ("a", (bang, VarT $ mkName "a"))
,
( "b"
,
( bang
, ConT (mkName "Maybe")
`AppT` ( ConT (mkName "Maybe")
`AppT` VarT (mkName "b")
)
)
)
]
)
[("a", Nothing), ("b", Nothing)]
userType =
Type
(mkName "User")
( Map.fromList
[ (idKey, userIdType)
, (nameKey, userNameType)
, (otherPropKey, userOtherPropType)
]
)
[]
describe "omit" $ do
it "remove fields" $ do
(userWithId, logs) <- testTM (omit [nameKey, otherPropKey] userType)
logs `shouldBe` []
length (fields userWithId) `shouldBe` length (fields userType) - 2
Map.lookup idKey (fields userWithId) `shouldNotBe` Nothing
Map.lookup "otherProp" (fields userWithId) `shouldBe` Nothing
Map.lookup nameKey (fields userWithId) `shouldBe` Nothing
describe "issue warning" $ do
it "field does not exist" $ do
(user2, logs) <- testTM (omit [nameKey, idKey, otherPropKey] userType)
logs `shouldBe` [emptyResultType]
length (fields user2) `shouldBe` 0
it "field does not exist" $ do
(user2, logs) <- testTM (omit [nameKey, "idonotexist"] userType)
logs `shouldBe` [fieldNotInType "idonotexist"]
length (fields user2) `shouldBe` length (fields userType) - 1
describe "fail" $ do
it "has type parameters" $ do
shouldFail (omit [nameKey] typeWithVar)
describe "required" $ do
it "mark field as required" $ do
(user2, logs) <- testTM (require [otherPropKey] userType)
logs `shouldBe` []
snd <$> Map.lookup otherPropKey (fields user2)
`shouldBe` Just userOtherPropRequiredType
describe "issue warning" $ do
it "field does not exist" $ do
(user2, logs) <- testTM (require ["idonotexist"] userType)
logs `shouldBe` [fieldNotInType "idonotexist"]
fields user2 `shouldBe` fields userType
it "field is not optional" $ do
(user2, logs) <- testTM (require [idKey] userType)
logs `shouldBe` [fieldNotOptional "id"]
fields user2 `shouldBe` fields userType
describe "pick" $ do
it "pick fields" $ do
(userWithId, logs) <- testTM (pick [idKey] userType)
logs `shouldBe` []
length (fields userWithId) `shouldBe` 1
Map.lookup idKey (fields userWithId) `shouldBe` Just userIdType
describe "issue warning" $ do
it "field does not exist" $ do
(emptyType, logs) <- testTM (pick ["a", idKey] userType)
logs `shouldBe` [fieldNotInType "a"]
length (fields emptyType) `shouldBe` 1
it "result type is empty" $ do
(emptyType, logs) <- testTM (pick [] userType)
logs `shouldBe` [emptyResultType]
length (fields emptyType) `shouldBe` 0
it "field does not exist and result type is empty" $ do
(emptyType, logs) <- testTM (pick ["a"] userType)
logs
`shouldBe` [ fieldNotInType "a"
, emptyResultType
]
length (fields emptyType) `shouldBe` 0
describe "fail" $ do
it "has type parameters" $ do
shouldFail (pick [nameKey] typeWithVar)
describe "intersection" $ do
it "should have only common fields" $ do
(userWithId, _) <- testTM (pick [idKey] userType)
(intersectionRes, logs) <- testTM (intersection userType userWithId)
logs `shouldBe` []
Map.toList (fields intersectionRes) `shouldBe` [(idKey, userIdType)]
describe "issue warning" $ do
it "result type is empty" $ do
(emptyType, _) <- testTM (pick [] userType)
(res, logs) <- testTM (intersection emptyType userType)
logs `shouldBe` [emptyResultType]
length (fields res) `shouldBe` 0
describe "fail" $ do
it "has type parameters" $ do
shouldFail (intersection userType typeWithVar)
describe "union" $ do
it "should have all fields" $ do
(userWithId, _) <- testTM (pick [idKey] userType)
(unionRes, logs) <- testTM (union userType userWithId)
logs `shouldBe` []
fields unionRes `shouldBe` fields userType
it "should prefer the first type" $ do
(user2, _) <- testTM (require [otherPropKey] userType)
(unionRes, logs) <- testTM (union user2 userType)
logs `shouldBe` []
length (fields unionRes) `shouldBe` 3
snd <$> Map.lookup otherPropKey (fields unionRes)
`shouldBe` Just userOtherPropRequiredType
it "should prefer the second type" $ do
(user2, _) <- testTM (require [otherPropKey] userType)
(unionRes, logs) <- testTM (union' user2 userType)
logs `shouldBe` []
length (fields unionRes) `shouldBe` 3
Map.lookup otherPropKey (fields unionRes)
`shouldBe` Just userOtherPropType
describe "fail" $ do
it "has type parameters" $ do
shouldFail (union userType typeWithVar)
describe "partial" $ do
it "should wrap all fields with Maybe, except optional ones" $ do
(partialUser, logs) <- testTM (partial userType)
logs `shouldBe` []
Map.lookup otherPropKey (fields partialUser)
`shouldBe` Map.lookup otherPropKey (fields userType)
case snd <$> Map.lookup idKey (fields partialUser) of
Just (AppT (ConT wrapper) wrapped) -> do
nameBase wrapper `shouldBe` "Maybe"
wrapped `shouldBe` snd userIdType
x -> expectationFailure ("expected a type wrapped in maybe, got " ++ show x)
it "should wrap all fields with Maybe, including optional ones" $ do
(partialUser, logs) <- testTM (partial' userType)
logs `shouldBe` []
forM_ (Map.toList $ fields userType) $ \(fName, (_, fType)) ->
case snd <$> Map.lookup fName (fields partialUser) of
Just (AppT (ConT wrapper) wrapped) -> do
nameBase wrapper `shouldBe` "Maybe"
wrapped `shouldBe` fType
x -> expectationFailure ("expected a type wrapped in maybe, got " ++ show x)
describe "record" $ do
it "should have all fields" $ do
let fType = ConT (mkName "Maybe") `AppT` ConT (mkName "Int")
(res, logs) <- testTM (record ["a", "b"] (return fType))
logs `shouldBe` []
length (fields res) `shouldBe` 2
snd <$> Map.lookup "a" (fields res) `shouldBe` Just fType
describe "issue warning" $ do
it "empty record" $ do
(emptyType, logs) <- testTM (record [] (conT $ mkName "Int"))
logs `shouldBe` [emptyResultType]
length (fields emptyType) `shouldBe` 0
it "duplicate key" $ do
(res, logs) <- testTM (record ["a", "a"] (conT $ mkName "Int"))
logs `shouldBe` [duplicateKey]
length (fields res) `shouldBe` 1
describe "apply" $ do
it "should replace type variables" $ do
(res, logs) <- testTM (applyMany [[t|Int|], [t|String|]] typeWithVar)
typeParams res `shouldBe` []
logs `shouldBe` []
-- Check first type variable
let aField = snd $ fromJust $ Map.lookup "a" $ fields res
case aField of
ConT n -> nameBase n `shouldBe` "Int"
t -> expectationFailure $ "expected a type constructor, got: " ++ show t
-- Check second type variable
logs `shouldBe` []
let bField = snd $ fromJust $ Map.lookup "b" $ fields res
case bField of
AppT (ConT _) (AppT (ConT _) (ConT n)) -> nameBase n `shouldBe` "String"
t ->
expectationFailure $
"expected two nexted type constructors, got: " ++ show t
describe "issue warning" $ do
it "no type variable" $ do
(_, logs) <- testTM (apply [t|Int|] userType)
logs `shouldBe` [noTypeParameter]
where
testTM = runQ . execTM
shouldFail tm = do
mres <-
try
(testTM tm) ::
IO (Either IOException (TypeMachine.Type, [String]))
mres `shouldSatisfy` isLeft