diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Sven Heyll (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Sven Heyll nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,157 @@ +-- | Some examples for 'Test.TypeSpec' +module Main where + +import Data.Kind +import GHC.TypeLits +import Test.TypeSpecCrazy + +main :: IO () +main = do + print specHelloWorld + print specGrouped + print specAliases + print specTuple + print specFamilyInstancesSuperCrazy + print spec1 + print specCrazy + print specInvalidCrazy + +-- * TypeSpec Examples + +-- | Let's start off simple: +specHelloWorld :: Expect (Int `Isn't` Bool) +specHelloWorld = Valid + +-- | We can also expect a bit more using lists and tuples: +specGrouped + :: Expect '[ Int `Isn't` Bool + , Int `Is` Int + , Bool `Is` Bool `ButNot` String + ] +specGrouped = Valid + +specTuple :: + Explain "Type level tuples can also be used to group tests." + (They "accept only two elments" + '( (5 - 4) `Is` 1, (3 + 3) `Is` 6 `ButNot` (3 - 3) ) ) +specTuple = Valid + +-- * Some nice aliases + +type ALot = 1000 + +specAliases :: + (Explain "There are a variety aliases for the basic combinators." + (Context "Basic Combinators" + (Describe "Context" + (It "labels expectations using 'It'" + (Describe "Describe" + (It's "an alias for It, just like They" + (It's "time for the first assertion" + (1000 `Is` ALot)))))))) +specAliases = Valid + + +-- * More complex example + +type family Swap a +type instance Swap (a,b) = (b,a) + +type family SwapT (a :: (k1, k2)) :: (k2, k1) +type instance SwapT '(a,b) = '(b,a) + +type family Fst a where + Fst (a,b) = a + +type family Count a :: Nat where + Count (a,b) = 2 + Count (a,b,c) = 3 + Count (a,b,c,d) = 4 + +-- A failing test case example: +-- specFailing :: +-- TypeSpec +-- (It "counts the number of elements in a tuple" +-- (Count ((),(),()) `ShouldBe` 4)) +-- specFailing = Valid + +specFamilyInstancesSuperCrazy :: + + "Only one title like this" + ########################### + + "Describe the following expectations" + + --* Swap (Int, Bool) `Isn't` (Int, Int) + -* Swap (Int, Bool) `Is` (Bool, Int) + -* Swap (Int, Bool) `Isn't` Swap (Swap (Int, Bool)) + -* (Int, Bool) `Is` Swap (Swap (Int, Bool)) + -* + ("... now there is maybe a nested block" + + --* Count (Int,Int,Int,Int) `ShouldBe` 4 + -* SwapT '(0,1) `ShouldBe` '(1,0) + -* And (Count (Int,Int,Int) <=? 4)) + + -/- + + "Here there is another top-level block" + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + [ Count (Int,Int,Int,Int) `Is` 4 + , SwapT '(0,1) `Is` '(1,0) + , And (Count (Int,Int,Int) <=? 4) + ] + + +specFamilyInstancesSuperCrazy = Valid + +-- * More examples + +spec1 :: + Explain "TypeSpec" + (It "Allows explanations of types" (ShouldBe Int Int)) +spec1 = Valid + +specCrazy :: + + "Higher kinded assertions" + ########################### + + "ShouldBe accepts types of kind * -> *" + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + ShouldBe Maybe Maybe + -* ShouldBe [] [] + -* ShouldBe (->) (->) + +specCrazy = Valid + +-- -------------------------------------------------------- + +type SpecInvalidCrazy = + + "One of the following specs is not OK" + ####################################### + + "This should be ok" + ~~~~~~~~~~~~~~~~~~~~~ + + TheseAreEqual Bool Bool + + -/- + + "This should also be ok" + ~~~~~~~~~~~~~~~~~~~~~~~~ + + TheseAreNotEqual (Maybe Int) (Maybe Int) + + -/- + + "But this looks bad:" + ~~~~~~~~~~~~~~~~~~~~~ + + TheseAreEqual Maybe (Either Int) + +specInvalidCrazy :: SpecInvalidCrazy +specInvalidCrazy = Invalid diff --git a/src/Test/TypeSpec.hs b/src/Test/TypeSpec.hs new file mode 100644 --- /dev/null +++ b/src/Test/TypeSpec.hs @@ -0,0 +1,66 @@ +-- | A tiny EDSL to write type-level-unit tests. +module Test.TypeSpec + ( type Expect + , type Explain + , type It's + , type IsTheSameAs + , type Is + , type TheseAreEqual + , type IsNot + , type Isn't + , type IsNotTheSameAs + , type IsDifferentFrom + , type TheseAreNotEqual + , type IsTrue + , type Therefore + , type And + , type IsFalse + , type They + , type Describe + , type Context + , module ReExport) + where + +import Test.TypeSpec.Core as ReExport +import Test.TypeSpec.Group as ReExport +import Test.TypeSpec.Label as ReExport +import Test.TypeSpec.ShouldBe as ReExport + +-- * 'TypeSpec' Aliases + +-- | An alias for 'TypeSpec'. +type Expect = TypeSpec + +-- | Another alias for 'TypeSpec' (and also 'It') +type Explain does this = TypeSpec (It does this) + +-- * 'ShouldBe' aliases + +type Is = ShouldBe +type IsTheSameAs = ShouldBe +type TheseAreEqual = ShouldBe + +-- * 'ShouldNotBe' aliases + +type IsNot = ShouldNotBe +type Isn't = ShouldNotBe +type IsNotTheSameAs = ShouldNotBe +type IsDifferentFrom = ShouldNotBe +type TheseAreNotEqual = ShouldNotBe + +-- * 'ShouldBeTrue' aliases + +type IsTrue = ShouldBeTrue +type And = ShouldBeTrue +type Therefore = ShouldBeTrue + +-- * 'ShouldBeFalse' aliases + +type IsFalse = ShouldBeFalse + +-- * Labelling Aliases + +type They message expectations = It message expectations +type Describe = It +type Context = It +type It's = It diff --git a/src/Test/TypeSpec/Core.hs b/src/Test/TypeSpec/Core.hs new file mode 100644 --- /dev/null +++ b/src/Test/TypeSpec/Core.hs @@ -0,0 +1,106 @@ +-- | Core of the TypeSpec abstractions. Import to add custom instances. +module Test.TypeSpec.Core + ( TypeSpec (..) + , type EvalExpectation + , PrettyTypeSpec(..) + , prettyIndentation + , nest' + , sentence + , module ReExport + ) + where + +import Data.Proxy +import Test.TypeSpec.Internal.Either () +import Test.TypeSpec.Internal.Apply +import Test.TypeSpec.Internal.Result as ReExport +import Text.PrettyPrint + +-- * Type Level Specifcations + +-- | A type specification. +data TypeSpec expectation where + -- | Expect the given expectations to hold. If the compiler does not reject it - + -- the expectation seem plausible. + Valid :: (Try (EvalExpectation expectation) ~ expectation) + => TypeSpec expectation + -- | Expect the given expectations to **NOT** hold. If the compiler does not + -- reject it - the expectation seem indeed implausible. + Invalid :: (DontTry (EvalExpectation expectation)) + => TypeSpec expectation + +-- * Expectations + +-- | An open family of type level expectation evaluators, that return either @()@ +-- or an @ErrorMessage@. +type family EvalExpectation (expectation :: k) :: Result k + +-- ** Combining/Grouping collections + +-- | Given a pair @(expectation1, expectation2)@ try to evaluate the first then, +-- if no error was returned, the second. +type instance EvalExpectation '(a, b) = + Pair'' <$> EvalExpectation a <*> EvalExpectation b + +-- | Given a list @(expectation : rest)@ try to evaluate the @expectation@ then, +-- if no error was returned, the @rest@. +type instance EvalExpectation '[] = OK '[] +type instance EvalExpectation (expectation ': rest) = + Cons'' <$> EvalExpectation expectation <*> EvalExpectation rest + +-- * Pretty Printing + +-- | A class for pretty printing via the 'Show' instance of 'TypeSpec'. +class PrettyTypeSpec (t :: k) where + prettyTypeSpec :: proxy t -> Doc + +-- * Printing/Showing + +instance PrettyTypeSpec t => Show (TypeSpec t) where + show px@Valid = + render + $ hang (text "Valid:") 5 (prettyTypeSpec px) + show px@Invalid = + render + $ hang (text "Invalid:") 5 (prettyTypeSpec px) + +-- | The default indention to use when 'nest'ing 'Doc'uments. +prettyIndentation :: Int +prettyIndentation = 2 + +-- | Nest using the default indention `prettyIndentation`. +nest' :: Doc -> Doc +nest' = nest prettyIndentation + +-- | Print a /sentence/ with the second part 'hang'ing from the first. +-- Generate: @predicate: object@ +sentence :: String -> Doc -> Doc +sentence predicate object = + hang (text predicate <> colon <> space) 5 object + +-- * Default instances + +instance + ( PrettyTypeSpec expectation1 + , PrettyTypeSpec expectation2 ) + => PrettyTypeSpec '(expectation1, expectation2) + where + prettyTypeSpec _ = + prettyTypeSpec pe1 $+$ prettyTypeSpec pe2 + where pe1 = Proxy :: Proxy expectation1 + pe2 = Proxy :: Proxy expectation2 + +instance + PrettyTypeSpec '[] + where + prettyTypeSpec _ = empty + +instance + ( PrettyTypeSpec expectation + , PrettyTypeSpec rest ) + => PrettyTypeSpec (expectation ': rest) + where + prettyTypeSpec _ = + (prettyTypeSpec pe1) $+$ (prettyTypeSpec pe2) + where pe1 = Proxy :: Proxy expectation + pe2 = Proxy :: Proxy rest diff --git a/src/Test/TypeSpec/Group.hs b/src/Test/TypeSpec/Group.hs new file mode 100644 --- /dev/null +++ b/src/Test/TypeSpec/Group.hs @@ -0,0 +1,42 @@ +-- | Group expectations +module Test.TypeSpec.Group + ( type (-/-), type (-*) ) + where + +import Data.Proxy +import Test.TypeSpec.Core +import Test.TypeSpec.Internal.Apply +import Test.TypeSpec.Internal.Either () +import Text.PrettyPrint + +-- * Composed Expectations + +-- | A @cons@ like operator. +-- Make a list of expectations. Use this to chain together any expectations +-- especially those using '(~~~)' or '(-*)', since it has a lower precedence +-- than both. +data expectation1 -/- expectation2 +infixr 1 -/- + +type instance + EvalExpectation (expectation -/- expectations) = + TyCon2 ((-/-)) <$> EvalExpectation expectation <*> EvalExpectation expectations + +-- | A @cons@ like operator. +-- Make a list of expectations. Use this to chain together anything /below/ or +-- inside '(-/-)' and '(~~~)' parts. The precedence of this operator is higher +-- that that of '(-/-)'. +type expectation1 -* expectation2 = expectation1 -/- expectation2 +infixr 3 -* + +-- * Pretty Printing Instances + +instance + ( PrettyTypeSpec expectation1 + , PrettyTypeSpec expectation2 ) + => PrettyTypeSpec (expectation1 -/- expectation2) + where + prettyTypeSpec _ = + (prettyTypeSpec pe1) $+$ (prettyTypeSpec pe2) + where pe1 = Proxy :: Proxy expectation1 + pe2 = Proxy :: Proxy expectation2 diff --git a/src/Test/TypeSpec/Internal/Apply.hs b/src/Test/TypeSpec/Internal/Apply.hs new file mode 100644 --- /dev/null +++ b/src/Test/TypeSpec/Internal/Apply.hs @@ -0,0 +1,116 @@ +-- | Useful abstractions for type level programming using. This reimplements +-- parts of the singletons library, which is just too heavy of a dependency to +-- carry around, when only three small types are used of it. +module Test.TypeSpec.Internal.Apply + ( type (>>=) + , type (>>) + , type (<*>) + , type (<$>$$) + , type (<$>$) + , type (<$>) + , type TyCon1 + , type TyCon2 + , type Apply + , TyFun, type TyFunData + , type (~>) + , type Cons'' + , type Cons' + , type Pair'' + , type Pair' + , type Const + , type Const' + , type Const'' + , Flip' + , Flip + , Flip_ + , type Flip__ + , Compose'' + , Compose' + , Compose + , type Compose_ + ) + where + +import Data.Kind + +-- | Bind to actions. +type family + (>>=) (ma :: monad a) + (f :: TyFunData (a :: Type) ((monad b) :: Type)) + :: monad b + +-- | Execute one action and then the next, ignore the result of the first. +type (>>) ma mb = ma >>= Const' mb + +-- | Execute an action that returns a function than map function over the result +-- of the next action. +type family + (f :: m (a ~> b)) <*> (ma :: m a) :: m b where + mf <*> mx = mf >>= Apply (Flip (<$>$$)) mx + +-- | Tuple construction +data Pair'' :: a ~> b ~> (a, b) +data Pair' :: a -> b ~> (a, b) +type instance Apply Pair'' x = Pair' x +type instance Apply (Pair' x) y = '(x, y) + +-- | List construction +data Cons'' :: a ~> [a] ~> [a] +data Cons' :: a -> [a] ~> [a] +type instance Apply Cons'' x = Cons' x +type instance Apply (Cons' x) xs = x ': xs + +-- | Convert data types to Partially applicable type functions +data TyCon1 :: (a -> b) -> a ~> b +data TyCon2 :: (a -> b -> c) -> a ~> b ~> c +type instance Apply (TyCon1 f) x = f x +type instance Apply (TyCon2 f) x = (TyCon1 (f x)) + +-- | Execute an action and map a pure function over the result. +data (<$>$$) :: (a ~> b) ~> m a ~> m b +data (<$>$) :: (a ~> b) -> m a ~> m b +type instance Apply (<$>$$) f = (<$>$) f +type instance Apply ((<$>$) f) x = f <$> x +type family + (f :: (a ~> b)) <$> (ma :: m a) :: m b + +-- * Flip Type Functions + +data Flip' :: (a ~> b ~> c) ~> b ~> a ~> c +data Flip :: (a ~> b ~> c) -> b ~> a ~> c +data Flip_ :: (a ~> b ~> c) -> b -> a ~> c +type instance Apply Flip' f = Flip f +type instance Apply (Flip f) y = Flip_ f y +type instance Apply (Flip_ f y) x = Flip__ f y x +type family + Flip__ (f :: (a ~> b ~> c)) (y :: b) (x :: a) :: c where + Flip__ f y x = Apply (Apply f x) y + +-- * Type Function composition + +data Compose'' :: (b ~> c) ~> (a ~> b) ~> (a ~> c) +data Compose' :: (b ~> c) -> (a ~> b) ~> (a ~> c) +data Compose :: (b ~> c) -> (a ~> b) -> (a ~> c) +type instance Apply Compose'' f = Compose' f +type instance Apply (Compose' f) g = (Compose f g) +type instance Apply (Compose f g) x = Compose_ f g x +type family + Compose_ (f :: b ~> c) (g :: a ~> b) (x :: a) :: c where + Compose_ f g x = Apply f (Apply g x) + + +-- * Type-Level 'const' + +type family Const (a :: t) (b :: t') :: t where Const a b = a +data Const' :: a -> (TyFunData b a) +data Const'' :: TyFunData a (TyFunData b a) +type instance Apply Const'' a = Const' a +type instance Apply (Const' a) b = Const a b + +-- * Defunctionalization + +data TyFun :: Type -> Type -> Type +type TyFunData a b = TyFun a b -> Type +type a ~> b = TyFun a b -> Type +infixr 0 ~> +type family Apply (f :: a ~> b) (x :: a) :: b diff --git a/src/Test/TypeSpec/Internal/Either.hs b/src/Test/TypeSpec/Internal/Either.hs new file mode 100644 --- /dev/null +++ b/src/Test/TypeSpec/Internal/Either.hs @@ -0,0 +1,16 @@ +-- | Useful abstractions for type level programming using 'Either'. +module Test.TypeSpec.Internal.Either (type FromLeft) where + +import Test.TypeSpec.Internal.Apply + +-- * Either instances + +type instance (>>=) ('Right a) f = Apply f a +type instance (>>=) ('Left b) f = 'Left b + +type instance (<$>) f ('Right a) = 'Right (Apply f a) +type instance (<$>) f ('Left a) = 'Left a + +type family + FromLeft (e :: Either a b) :: a where + FromLeft ('Left a) = a diff --git a/src/Test/TypeSpec/Internal/Equality.hs b/src/Test/TypeSpec/Internal/Equality.hs new file mode 100644 --- /dev/null +++ b/src/Test/TypeSpec/Internal/Equality.hs @@ -0,0 +1,8 @@ +-- | Type Equality +module Test.TypeSpec.Internal.Equality (type PolyKindEq) where + + -- | Operator 'Data.Equality.(==)' expects both arguments to have the + -- same kind. + type family PolyKindEq (a :: ak) (b :: bk) :: Bool where + PolyKindEq a a = 'True + PolyKindEq a b = 'False diff --git a/src/Test/TypeSpec/Internal/Result.hs b/src/Test/TypeSpec/Internal/Result.hs new file mode 100644 --- /dev/null +++ b/src/Test/TypeSpec/Internal/Result.hs @@ -0,0 +1,50 @@ +-- | Result type used in constraints inside 'TypeSpec' to propagate type errors. +module Test.TypeSpec.Internal.Result + ( type Result + , type Try + , type DontTry + , type FAILED + , type OK + , type PrependToError + ) where + +import GHC.TypeLits +import Data.Kind +import Test.TypeSpec.Internal.Apply () +import Test.TypeSpec.Internal.Either () + +-- * Type error propagation + +-- | When a type level expectation is tested, it might be that compound +-- expectations fail. In order to have a small, precise error message, the type +-- level assertion results are made to have kind 'Result'. +type Result = Either ErrorMessage + +type family + Try (e :: Result k) :: k where + Try (OK (d :: k)) = d + Try (FAILED m) = TypeError m + +type family + DontTry (e :: Result r) :: Constraint where + DontTry (FAILED e) = () + DontTry (OK okIsNotOk) = + TypeError ('Text "You specified this wasn't okay: " + ':$$: + 'Text " " ':<>: 'ShowType okIsNotOk + ':$$: + 'Text "... turns out it actually is!") + +-- | A nice name than 'Left' +type OK = 'Right +type FAILED = 'Left + +type family + PrependToError + (message :: ErrorMessage) + (result :: Result a) + :: Result a + where + PrependToError message (OK x) = OK x + PrependToError message (FAILED otherMessage) = + FAILED (message ':<>: otherMessage) diff --git a/src/Test/TypeSpec/Label.hs b/src/Test/TypeSpec/Label.hs new file mode 100644 --- /dev/null +++ b/src/Test/TypeSpec/Label.hs @@ -0,0 +1,29 @@ +-- | Label expectations +module Test.TypeSpec.Label + ( It ) + where + +import Data.Kind +import Data.Typeable +import GHC.TypeLits +import Test.TypeSpec.Core +import Test.TypeSpec.Internal.Apply +import Test.TypeSpec.Internal.Either () +import Text.PrettyPrint + +-- | Add a type level string as label or longer descripton around expectations. +-- This is analog to the @it@ function in the @hspec@ package. +data It :: Symbol -> expectation -> Type + +type instance + EvalExpectation (It message expectation) = + PrependToError + ('Text message ':$$: 'Text " ") + (EvalExpectation expectation) + >> (OK (It message expectation)) + + +instance (KnownSymbol msg, PrettyTypeSpec x) => PrettyTypeSpec (It msg x) where + prettyTypeSpec _ = + (text (symbolVal (Proxy :: Proxy msg))) + $+$ nest prettyIndentation (prettyTypeSpec (Proxy :: Proxy x)) diff --git a/src/Test/TypeSpec/ShouldBe.hs b/src/Test/TypeSpec/ShouldBe.hs new file mode 100644 --- /dev/null +++ b/src/Test/TypeSpec/ShouldBe.hs @@ -0,0 +1,123 @@ +-- | Type level assertions on type equality. +module Test.TypeSpec.ShouldBe + ( ShouldBe + , ShouldNotBe + , ShouldBeTrue + , ShouldBeFalse + , ButNot + ) + where + +import Data.Kind +import Data.Type.Bool +import Data.Type.Equality +import Data.Typeable +import GHC.TypeLits +import Test.TypeSpec.Core +import Test.TypeSpec.Internal.Apply () +import Test.TypeSpec.Internal.Either () +import Test.TypeSpec.Internal.Equality +import Text.PrettyPrint +import Type.Showtype + +-- | State that a type is equal to the type level @True@. +data ShouldBeTrue :: expectation -> Type + +type instance EvalExpectation (ShouldBeTrue t) = + If (PolyKindEq t 'True) + (OK (ShouldBeTrue t)) + (FAILED + ('Text "Should have been 'True: " ':<>: 'ShowType t)) + +-- | State that a type is equal to the type level @False@. +data ShouldBeFalse :: expectation -> Type + +type instance EvalExpectation (ShouldBeFalse t) = + If (PolyKindEq t 'False) + (OK (ShouldBeFalse t)) + (FAILED + ('Text "Should have been 'False: " ':<>: 'ShowType t)) + +-- | State that one type is different to two other types. This must always be +-- used right next to a 'ShouldBe' pair, otherwise this will not work. +data ButNot :: shouldBe -> actual -> Type + +type instance + EvalExpectation (ButNot (ShouldBe expected actual) other) = + If (expected == actual) + (If (expected == other) + (FAILED + ('Text "Expected type: " + ':$$: 'Text " " ':<>: 'ShowType expected + ':$$: 'Text "to be different from: " + ':$$: 'Text " " ':<>: 'ShowType other)) + (OK (ButNot (ShouldBe expected actual) other))) + (FAILED + ('Text "Expected type: " ':<>: 'ShowType expected + ':$$: 'Text "Actual type: " ':<>: 'ShowType actual)) + +-- | State that two types or type constructs are boiled down to the same type. +data ShouldBe :: expected -> actual -> Type + +type instance + EvalExpectation (ShouldBe expected actual) = + If (PolyKindEq expected actual) + (OK (ShouldBe expected actual)) + (FAILED + ('Text "Expected type: " ':<>: 'ShowType expected + ':$$: 'Text "Actual type: " ':<>: 'ShowType actual)) + +-- | State that two types or type constructs are NOT the same type. +data ShouldNotBe :: expected -> actual -> Type + +type instance + EvalExpectation (ShouldNotBe expected actual) = + If (PolyKindEq expected actual) + (FAILED + ('Text "Expected type: " + ':$$: 'Text " " ':<>: 'ShowType expected + ':$$: 'Text "to be different from: " + ':$$: 'Text " " ':<>: 'ShowType actual)) + (OK (ShouldNotBe expected actual)) + +-- * PrettyTypeSpec instances + +instance PrettyTypeSpec (ShouldBeTrue a) where + prettyTypeSpec _px = + prettyBulletPoint $ text "Type == True" + +instance PrettyTypeSpec (ShouldBeFalse a) where + prettyTypeSpec _px = + prettyBulletPoint $ text "Type == False" + +instance PrettyTypeSpec (ShouldBe a b) where + prettyTypeSpec _px = + prettyBulletPoint $ text "Types are equal" + +instance (Showtype a, Showtype b) => PrettyTypeSpec (ShouldNotBe a b) where + prettyTypeSpec _px = + prettyBulletPoint + $ sentence "Type" (text expected) + $$ sentence "differs from" (text actual) + where + expected = showtype (Proxy :: Proxy a) + actual = showtype (Proxy :: Proxy b) + +instance + (a ~ (ShouldBe a0 a1) + , Showtype a0 + , Showtype a1 + , Showtype b ) + => PrettyTypeSpec (ButNot a b) where + prettyTypeSpec _ = + prettyBulletPoint + $ (sentence "Type" + (text (showtype (Proxy :: Proxy a0)))) + $$ (sentence "is equal to" + (text (showtype (Proxy :: Proxy a1)))) + $$ (sentence "but not to" + (text (showtype (Proxy :: Proxy b)))) + +-- | Pretty print a test prefix by a bullet-point. +prettyBulletPoint :: Doc -> Doc +prettyBulletPoint doc = text "•" <+> doc diff --git a/src/Test/TypeSpecCrazy.hs b/src/Test/TypeSpecCrazy.hs new file mode 100644 --- /dev/null +++ b/src/Test/TypeSpecCrazy.hs @@ -0,0 +1,140 @@ +-- | Funny operators that are mere type aliases for the constructs in +-- 'TypeSpec' +module Test.TypeSpecCrazy + ( module Test.TypeSpecCrazy + , module ReExport) + where + +import Test.TypeSpec as ReExport + +-- * Crazy Type operators + +-- | Create a 'TypeSpec' with an initial description or title followed by some +-- expectations. Note that the number of @#@s is alway a multiple of 3. +type (###) title expr = Explain title expr +type (######) title expr = Explain title expr +type (#########) title expr = Explain title expr +type (############) title expr = Explain title expr +type (###############) title expr = Explain title expr +type (##################) title expr = Explain title expr +type (#####################) title expr = Explain title expr +type (########################) title expr = Explain title expr +type (###########################) title expr = Explain title expr +type (##############################) title expr = Explain title expr +type (#################################) title expr = Explain title expr +type (####################################) title expr = Explain title expr +type (#######################################) title expr = Explain title expr +type (##########################################) title expr = + Explain title expr +type (#############################################) title expr = + Explain title expr +type (################################################) title expr = + Explain title expr +type (###################################################) title expr = + Explain title expr +type (######################################################) title expr = + Explain title expr +type (#########################################################) title expr = + Explain title expr +type (############################################################) title expr = + Explain title expr +type (###############################################################) title expr = + Explain title expr +type (##################################################################) title expr = + Explain title expr +type (#####################################################################) title expr = + Explain title expr +type (########################################################################) title expr = + Explain title expr + +infixr 0 ### +infixr 0 ###### +infixr 0 ######### +infixr 0 ############ +infixr 0 ############### +infixr 0 ################## +infixr 0 ##################### +infixr 0 ######################## +infixr 0 ########################### +infixr 0 ############################## +infixr 0 ################################# +infixr 0 #################################### +infixr 0 ####################################### +infixr 0 ########################################## +infixr 0 ############################################# +infixr 0 ################################################ +infixr 0 ################################################### +infixr 0 ###################################################### +infixr 0 ######################################################### +infixr 0 ############################################################ +infixr 0 ############################################################### +infixr 0 ################################################################## +infixr 0 ##################################################################### +infixr 0 ######################################################################## + +-- | Specify an expectation using an underlined title using 'It'. +type (--*) title expr = It title expr +type (~~~) title expr = It title expr +type (~~~~~~) title expr = It title expr +type (~~~~~~~~~) title expr = It title expr +type (~~~~~~~~~~~~) title expr = It title expr +type (~~~~~~~~~~~~~~~) title expr = It title expr +type (~~~~~~~~~~~~~~~~~~) title expr = It title expr +type (~~~~~~~~~~~~~~~~~~~~~) title expr = It title expr +type (~~~~~~~~~~~~~~~~~~~~~~~~) title expr = It title expr +type (~~~~~~~~~~~~~~~~~~~~~~~~~~~) title expr = It title expr +type (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) title expr = It title expr +type (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) title expr = It title expr +type (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) title expr = It title expr +type (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) title expr = It title expr +type (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) title expr = + It title expr +type (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) title expr = + It title expr +type (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) title expr = + It title expr +type (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) title expr = + It title expr +type (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) title expr = + It title expr +type (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) title expr = + It title expr +type (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) title expr = + It title expr +type (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) title expr = + It title expr +type (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) title expr = + It title expr +type (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) title expr = + It title expr +type (~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~) title expr = + It title expr + +infixl 2 --* +infixl 2 ~~~ +infixr 2 ~~~~~~ +infixr 2 ~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +infixr 2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +type expectation1 -*- expectation2 = expectation1 -/- expectation2 +infixl 2 -*- diff --git a/type-spec.cabal b/type-spec.cabal new file mode 100644 --- /dev/null +++ b/type-spec.cabal @@ -0,0 +1,100 @@ +name: type-spec +version: 0.1.0.0 +synopsis: Type Level Specification by Example +description: Please see README.md +homepage: https://github.com/sheyll/type-spec#readme +license: BSD3 +license-file: LICENSE +author: Sven Heyll +maintainer: sven.heyll@gmail.com +copyright: 2016 Sven Heyll +category: expring +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Test.TypeSpec + , Test.TypeSpecCrazy + , Test.TypeSpec.Core + , Test.TypeSpec.Group + , Test.TypeSpec.Label + , Test.TypeSpec.ShouldBe + , Test.TypeSpec.Internal.Apply + , Test.TypeSpec.Internal.Either + , Test.TypeSpec.Internal.Equality + , Test.TypeSpec.Internal.Result + build-depends: base >= 4.9 && < 5 + , pretty >= 1.1.3 && < 1.2 + , show-type >= 0.1.1 + default-language: Haskell2010 + default-extensions: ConstraintKinds + , CPP + , DataKinds + , DefaultSignatures + , DeriveDataTypeable + , DeriveFunctor + , DeriveGeneric + , FlexibleInstances + , FlexibleContexts + , FunctionalDependencies + , GADTs + , GeneralizedNewtypeDeriving + , KindSignatures + , MultiParamTypeClasses + , OverloadedStrings + , PolyKinds + , QuasiQuotes + , RecordWildCards + , RankNTypes + , ScopedTypeVariables + , StandaloneDeriving + , TemplateHaskell + , TupleSections + , TypeFamilies + , TypeInType + , TypeOperators + , TypeSynonymInstances + , UndecidableInstances + ghc-options: -Wall + +test-suite examples + type: exitcode-stdio-1.0 + ghc-options: -Wall + hs-source-dirs: examples + main-is: Main.hs + default-language: Haskell2010 + build-depends: base >= 4.9 && < 5 + , type-spec + default-language: Haskell2010 + default-extensions: ConstraintKinds + , CPP + , DataKinds + , DefaultSignatures + , DeriveDataTypeable + , DeriveFunctor + , DeriveGeneric + , FlexibleInstances + , FlexibleContexts + , FunctionalDependencies + , GADTs + , GeneralizedNewtypeDeriving + , KindSignatures + , MultiParamTypeClasses + , OverloadedStrings + , QuasiQuotes + , RecordWildCards + , RankNTypes + , ScopedTypeVariables + , StandaloneDeriving + , TemplateHaskell + , TupleSections + , TypeFamilies + , TypeInType + , TypeOperators + , TypeSynonymInstances + +source-repository head + type: git + location: https://github.com/sheyll/type-spec