diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Revision history for sized-grid +## 0.1.1.4 -- 2018-11-20 + +* Changed test suite to use QuickCheck + +## 0.1.1.3 -- 2018-11-14 + +* Version bumps + ## 0.1.1.0 -- 2018-05-10 * Added Field instances for coord diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -101,7 +101,7 @@ , All AffineSpace cs , All Eq cs , AllDiffSame Integer cs - , KnownNat (MaxCoordSize cs) + , AllSizedKnown cs , IsGrid cs (grid cs) ) => Rule diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -101,7 +101,7 @@ , All AffineSpace cs , All Eq cs , AllDiffSame Integer cs - , KnownNat (MaxCoordSize cs) + , AllSizedKnown cs , IsGrid cs (grid cs) ) => Rule diff --git a/sized-grid.cabal b/sized-grid.cabal --- a/sized-grid.cabal +++ b/sized-grid.cabal @@ -1,5 +1,5 @@ name: sized-grid -version: 0.1.1.1 +version: 0.1.1.4 cabal-version: >=1.10 category: Data build-type: Simple @@ -19,6 +19,10 @@ README.lhs README.md +source-repository head + type: git + location: https://github.com/edwardwas/sized-grid + library exposed-modules: SizedGrid.Ordinal @@ -31,18 +35,18 @@ SizedGrid.Grid.Focused SizedGrid build-depends: - base >=4.9 && <4.12, - lens >=4.16.1 && <4.17, - vector >=0.12.0.1 && <0.13, - vector-space ==0.13.*, - generics-sop >=0.3.2.0 && <0.4, - distributive >=0.5.3 && <0.6, - adjunctions ==4.4.*, - comonad >=5.0.3 && <5.1, - random ==1.1.*, + base >=4.9 && <4.13, + adjunctions >= 4.3 && < 4.5, + aeson >=1.2 && <1.5, + comonad >=5.0 && <5.1, + constraints >= 0.9 && < 0.11, + distributive >=0.5 && <0.6, + generics-sop >=0.3 && <0.4, + lens >=4.15 && <4.17, mtl >=2.2.2 && <2.3, - constraints ==0.10.*, - aeson >=1.2.4.0 && <1.5 + random ==1.1.*, + vector >=0.12 && <0.13, + vector-space >=0.10 && < 0.14 default-language: Haskell2010 hs-source-dirs: src other-modules: @@ -53,34 +57,37 @@ type: exitcode-stdio-1.0 main-is: Main.hs build-depends: - base >=4.9 && <4.12, - sized-grid -any, - hedgehog >=0.5.3 && <0.7, - tasty >=1.0.1.1 && <1.2, - tasty-hedgehog >=0.1.0.2 && <0.3, - vector-space ==0.13.*, - generics-sop >=0.3.2.0 && <0.4, - lens >=4.16.1 && <4.17, - adjunctions ==4.4.*, - aeson >=1.2.4.0 && <1.5, + base >=4.9 && <4.13, HUnit >=1.6.0.0 && <1.7, - tasty-hunit >=0.10.0.1 && <0.11 + aeson >=1.2 && <1.5, + adjunctions >= 4.3 && < 4.5, + generics-sop >=0.3 && <0.4, + lens >=4.15 && <4.17, + sized-grid -any, + tasty >=1.0 && <1.2, + tasty-hunit >=0.10 && <0.11, + vector >=0.12 && <0.13, + vector-space >=0.10 && < 0.14, + QuickCheck >= 2.10 && < 3.0, + tasty-quickcheck >= 0.9 && < 1 default-language: Haskell2010 hs-source-dirs: tests other-modules: Test.Utils + Test.Shrink + test-suite readme type: exitcode-stdio-1.0 main-is: README.lhs build-depends: - base >=4.9 && <4.12, + base >=4.9 && <4.13, + ansi-terminal >=0.8.0.2 && <0.9, + adjunctions >= 4.3 && < 4.5, + comonad >=5.0 && <5.1, + distributive >=0.5 && <0.6, + lens >=4.15 && <4.17, markdown-unlit >=0.5.0 && <0.6, sized-grid -any, - distributive >=0.5.3 && <0.6, - adjunctions ==4.4.*, - vector-space ==0.13.*, - comonad >=5.0.3 && <5.1, - lens >=4.16.1 && <4.17, - ansi-terminal >=0.8.0.2 && <0.9 + vector-space >=0.10 && < 0.14 default-language: Haskell2010 ghc-options: -pgmL markdown-unlit diff --git a/src/SizedGrid/Coord.hs b/src/SizedGrid/Coord.hs --- a/src/SizedGrid/Coord.hs +++ b/src/SizedGrid/Coord.hs @@ -1,14 +1,19 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} module SizedGrid.Coord where @@ -22,6 +27,8 @@ import Data.AdditiveGroup import Data.Aeson import Data.AffineSpace +import Data.Constraint +import Data.Constraint.Nat import Data.List (intercalate) import Data.Semigroup (Semigroup (..)) import qualified Data.Vector as V @@ -29,6 +36,7 @@ import qualified Generics.SOP as SOP import GHC.Exts (Constraint) import GHC.Generics (Generic) +import GHC.TypeLits import qualified GHC.TypeLits as GHC import System.Random (Random (..)) @@ -41,7 +49,18 @@ newtype Coord cs = Coord {unCoord :: NP I cs} deriving (Generic) +coordSplit:: Coord (c ': cs) -> (c, Coord cs) +coordSplit (Coord (I x :* xs)) = (x, Coord xs) +pattern (:|) :: c -> Coord cs -> Coord (c ': cs) +pattern (:|) a as <- (coordSplit -> (a,as)) + where (:|) a (Coord as) = Coord (I a :* as) + +pattern EmptyCoord :: Coord '[] +pattern EmptyCoord = Coord Nil + +infixr 5 :| + _WrappedCoord :: Lens' (Coord cs) (NP I cs) _WrappedCoord f (Coord n) = Coord <$> f n @@ -262,3 +281,54 @@ -- | Swap x and y for a coord in 2D space tranposeCoord :: Coord '[a,b] -> Coord '[b,a] tranposeCoord (Coord (a :* b :* Nil)) = Coord (b :* a :* Nil) + +-- | The zero position for a coord +zeroCoord :: All IsCoord cs => Coord cs +zeroCoord = Coord $ hcpure (Proxy :: Proxy IsCoord) (I $ zeroPosition) + +class AllSizedKnown (cs :: [*]) where + sizeProof :: Dict (KnownNat (MaxCoordSize cs)) + +instance AllSizedKnown '[] where + sizeProof = Dict + +instance (KnownNat (CoordSized a), AllSizedKnown as) => + AllSizedKnown (a ': as) where + sizeProof = + withDict + (sizeProof @as) + (Dict \\ (timesNat @(CoordSized a) @(MaxCoordSize as))) + +class WeakenCoord as bs where + weakenCoord :: Coord as -> Maybe (Coord bs) + +instance WeakenCoord '[] '[] where + weakenCoord c = Just c + +instance ( b ~ CoordFromNat a n + , WeakenCoord as bs + , IsCoord a + , IsCoord (CoordFromNat a n) + ) => + WeakenCoord (a ': as) (b ': bs) where + weakenCoord (a :| as) = do + bs <- weakenCoord as + b <- weakenIsCoord a + return (b :| bs) + weakenCoord _ = error "Unreachable pattern in weakenCoord" + +class StrengthenCoord as bs where + strengthenCoord :: Coord as -> Coord bs + +instance StrengthenCoord '[] '[] where + strengthenCoord c = c + +instance ( StrengthenCoord as bs + , IsCoord (CoordFromNat a n) + , IsCoord a + , b ~ CoordFromNat a n + , CoordSized a <= CoordSized (CoordFromNat a n) + ) => + StrengthenCoord (a ': as) (b ': bs) where + strengthenCoord (a :| as) = strengthenIsCoord a :| strengthenCoord as + strengthenCoord _ = error "Unreachable pattern in strengthenCoord" diff --git a/src/SizedGrid/Coord/Class.hs b/src/SizedGrid/Coord/Class.hs --- a/src/SizedGrid/Coord/Class.hs +++ b/src/SizedGrid/Coord/Class.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} @@ -14,15 +15,31 @@ import SizedGrid.Ordinal import Control.Lens +import Data.Constraint +import Data.Maybe (fromJust) import Data.Proxy import GHC.TypeLits +import Unsafe.Coerce (unsafeCoerce) +-- | Proof an idiom about how `CoordFromNat` works. This relies on 'CoordFromNat a (CoordSized a ~ a' +coordFromNatCollapse :: + forall a x y. Dict (CoordFromNat (CoordFromNat a x) y ~ CoordFromNat a y) +coordFromNatCollapse = unsafeCoerce (Dict :: Dict (z ~ z)) + +coordFromNatSame :: + (CoordFromNat a ~ CoordFromNat b) :- (a ~ CoordFromNat b (CoordSized a)) +coordFromNatSame = Sub (unsafeCoerce (Dict :: Dict (a ~ a))) + +coordSizedCollapse :: forall c n . Dict (CoordSized (CoordFromNat c n) ~ n) +coordSizedCollapse = unsafeCoerce (Dict :: Dict (a ~ a)) + -- | Everything that can be uses as a Coordinate. The only required function is `asOrdinal` and the type instance of `CoordSized`: the rest can be derived automatically. -- -- This is kind * -> Constraint for ease of use later. There is some argument that it should be of kind (Nat -> *) -> Constraint and we could remove `CoordSized`, but that has other complications -class (1 <= CoordSized c, KnownNat (CoordSized c)) => IsCoord c where +class (1 <= CoordSized c, KnownNat (CoordSized c)) => IsCoord c where -- | The maximum number of values that a Coord can take type CoordSized c :: Nat + type CoordFromNat c :: (Nat -> *) -- | As each coord represents a finite number of states, it must be isomorphic to an Ordinal asOrdinal :: Iso' c (Ordinal (CoordSized c)) -- | The origin. If c is an instance of `Monoid`, this should be mempty @@ -36,10 +53,32 @@ maxCoordSize :: proxy c -> Integer maxCoordSize p = natVal (sCoordSized p) - 1 + maxCoord :: c + maxCoord = view (re asOrdinal) maxCoord + + asSizeProxy :: + c + -> (forall n. (KnownNat n, n + 1 <= (CoordSized c)) => + Proxy n -> x) + -> x + asSizeProxy c = asSizeProxy (view asOrdinal c) + + weakenIsCoord :: IsCoord (CoordFromNat c n) => c -> Maybe (CoordFromNat c n) + weakenIsCoord = fmap (review asOrdinal) . weakenOrdinal . view asOrdinal + + strengthenIsCoord :: + (IsCoord (CoordFromNat c n), CoordSized c <= CoordSized (CoordFromNat c n)) + => c + -> CoordFromNat c n + strengthenIsCoord = review asOrdinal . strengthenOrdinal . view asOrdinal + instance (1 <= n, KnownNat n) => IsCoord (Ordinal n) where type CoordSized (Ordinal n) = n + type CoordFromNat (Ordinal n) = Ordinal asOrdinal = id zeroPosition = Ordinal (Proxy @0) + asSizeProxy (Ordinal p) func = func p + maxCoord = fromJust $ numToOrdinal (maxCoordSize (Proxy :: Proxy (Ordinal n))) -- | Enumerate all possible values of a coord, in order allCoordLike :: IsCoord c => [c] diff --git a/src/SizedGrid/Coord/HardWrap.hs b/src/SizedGrid/Coord/HardWrap.hs --- a/src/SizedGrid/Coord/HardWrap.hs +++ b/src/SizedGrid/Coord/HardWrap.hs @@ -38,6 +38,7 @@ instance (1 <= n, KnownNat n) => IsCoord (HardWrap n) where type CoordSized (HardWrap n) = n + type CoordFromNat (HardWrap n) = HardWrap asOrdinal = iso unHardWrap HardWrap instance (1 <= n, KnownNat n) => Semigroup (HardWrap n) where diff --git a/src/SizedGrid/Coord/Periodic.hs b/src/SizedGrid/Coord/Periodic.hs --- a/src/SizedGrid/Coord/Periodic.hs +++ b/src/SizedGrid/Coord/Periodic.hs @@ -52,6 +52,7 @@ instance (1 <= n, KnownNat n) => IsCoord (Periodic n) where type CoordSized (Periodic n) = n + type CoordFromNat (Periodic n) = Periodic asOrdinal = iso unPeriodic Periodic instance (1 <= n, KnownNat n) => Semigroup (Periodic n) where diff --git a/src/SizedGrid/Grid/Class.hs b/src/SizedGrid/Grid/Class.hs --- a/src/SizedGrid/Grid/Class.hs +++ b/src/SizedGrid/Grid/Class.hs @@ -22,7 +22,6 @@ #endif import Generics.SOP -import qualified GHC.TypeLits as GHC -- | Conversion between `Grid` and `FocusedGrid` and access grids at a `Coord` class IsGrid cs grid | grid -> cs where @@ -33,24 +32,17 @@ -- | Convert to, or run a function over, a `FocusedGrid` asFocusedGrid :: Lens' (grid a) (FocusedGrid cs a) -instance ( GHC.KnownNat (MaxCoordSize cs) - , All Semigroup cs - , All Monoid cs - , All IsCoord cs - ) => +instance (AllSizedKnown cs, All IsCoord cs) => IsGrid cs (Grid cs) where gridIndex coord = lens (\g -> index g coord) (\(Grid v) a -> Grid (v & ix (coordPosition coord) .~ a)) asGrid = id - asFocusedGrid = lens (\g -> FocusedGrid g mempty) (\_ fg -> focusedGrid fg) + asFocusedGrid = + lens (\g -> FocusedGrid g zeroCoord) (\_ fg -> focusedGrid fg) -instance ( GHC.KnownNat (MaxCoordSize cs) - , All IsCoord cs - , All Monoid cs - , All Semigroup cs - ) => +instance (AllSizedKnown cs, All IsCoord cs) => IsGrid cs (FocusedGrid cs) where gridIndex c = (\f (FocusedGrid g p) -> (\g' -> FocusedGrid g' p) <$> f g) . diff --git a/src/SizedGrid/Grid/Focused.hs b/src/SizedGrid/Grid/Focused.hs --- a/src/SizedGrid/Grid/Focused.hs +++ b/src/SizedGrid/Grid/Focused.hs @@ -17,7 +17,6 @@ import Data.Functor.Rep import Data.Semigroup (Semigroup (..)) import Generics.SOP -import qualified GHC.TypeLits as GHC -- | Similar to `Grid`, but this has a focus on a certain square. Becuase of this we loose some instances, such as `Applicative`, but we gain a `Comonad` and `ComonadStore` instance. We can convert between a focused and unfocused list using facilites in `IsGrid` data FocusedGrid cs a = FocusedGrid @@ -25,7 +24,7 @@ , focusedGridPosition :: Coord cs } deriving (Functor,Foldable,Traversable) -instance ( GHC.KnownNat (MaxCoordSize cs) +instance ( AllSizedKnown cs , All IsCoord cs , All Monoid cs , All Semigroup cs @@ -35,7 +34,7 @@ extract (FocusedGrid g p) = index g p duplicate (FocusedGrid g p) = FocusedGrid (tabulate (FocusedGrid g)) p -instance ( GHC.KnownNat (MaxCoordSize cs) +instance ( AllSizedKnown cs , All IsCoord cs , All Monoid cs , All Semigroup cs diff --git a/src/SizedGrid/Grid/Grid.hs b/src/SizedGrid/Grid/Grid.hs --- a/src/SizedGrid/Grid/Grid.hs +++ b/src/SizedGrid/Grid/Grid.hs @@ -1,9 +1,18 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -16,35 +25,41 @@ import Control.Lens hiding (index) import Data.Aeson +import Data.Constraint import Data.Distributive import Data.Functor.Classes import Data.Functor.Rep import Data.Proxy (Proxy (..)) +import Data.Semigroup ((<>)) import qualified Data.Vector as V import Generics.SOP -import GHC.Exts +import qualified GHC.Generics as GHC +import GHC.TypeLits import qualified GHC.TypeLits as GHC -- | A multi dimensional sized grid newtype Grid (cs :: [*]) a = Grid { unGrid :: V.Vector a - } deriving (Eq, Show, Functor, Foldable, Traversable, Eq1, Show1) + } deriving (Eq, Show, Functor, Foldable, Traversable, Eq1, Show1, GHC.Generic) -instance GHC.KnownNat (MaxCoordSize cs) => Applicative (Grid cs) where - pure = - Grid . - V.replicate (fromIntegral $ GHC.natVal (Proxy :: Proxy (MaxCoordSize cs))) - Grid fs <*> Grid as = Grid $ V.zipWith ($) fs as +instance AllSizedKnown cs => Applicative (Grid cs) where + pure = + withDict + (sizeProof @cs) + (Grid . + V.replicate + (fromIntegral $ GHC.natVal (Proxy :: Proxy (MaxCoordSize cs)))) + Grid fs <*> Grid as = Grid $ V.zipWith ($) fs as -instance (GHC.KnownNat (MaxCoordSize cs), All IsCoord cs) => +instance (AllSizedKnown cs, All IsCoord cs) => Monad (Grid cs) where g >>= f = imap (\p a -> f a `index` p) g -instance (GHC.KnownNat (MaxCoordSize cs), All IsCoord cs) => +instance (AllSizedKnown cs, All IsCoord cs) => Distributive (Grid cs) where distribute = distributeRep -instance (All IsCoord cs, GHC.KnownNat (MaxCoordSize cs)) => +instance (All IsCoord cs, AllSizedKnown cs) => Representable (Grid cs) where type Rep (Grid cs) = Coord cs tabulate func = Grid $ V.fromList $ map func $ allCoord @@ -143,3 +158,101 @@ => Grid '[ w, h] a -> Grid '[ h, w] a transposeGrid g = tabulate $ \i -> index g $ tranposeCoord i + +splitGrid :: + forall c cs a. (AllSizedKnown cs) + => Grid (c ': cs) a + -> Grid '[ c] (Grid cs a) +splitGrid (Grid v) = + withDict + (sizeProof @cs) + (Grid $ + V.fromList $ + map + Grid + (splitVectorBySize + (fromIntegral $ GHC.natVal (Proxy :: Proxy (MaxCoordSize cs))) + v)) + +combineGrid :: Grid '[c] (Grid cs a) -> Grid (c ': cs) a +combineGrid (Grid v) = Grid (v >>= unGrid) + +combineHigherDim :: + ( CoordFromNat a ~ CoordFromNat b + , c ~ CoordFromNat a ((GHC.+) (CoordSized a) (CoordSized b))) + => Grid (a ': as) x + -> Grid (b ': as) x + -> Grid (c ': as) x +combineHigherDim (Grid v1) (Grid v2) = Grid (v1 <> v2) + +dropGrid :: + KnownNat n + => Proxy n + -> Grid '[ c] x + -> Grid '[ CoordFromNat c (CoordSized c - n)] x +dropGrid p (Grid v) = Grid $ V.drop (fromIntegral $ natVal p) v + +takeGrid :: KnownNat n => Proxy n -> Grid '[c] x -> Grid '[CoordFromNat c n] x +takeGrid p (Grid v) = Grid $ V.take (fromIntegral $ natVal p) v + + +splitHigherDim :: + forall a b c as x. + ( KnownNat (CoordSized b) + , c ~ CoordFromNat a (CoordSized a - CoordSized b) + , CoordSized b <= CoordSized a + , AllSizedKnown as + ) + => Grid (a ': as) x + -> (Grid (b ': as) x, Grid (c ': as) x) +splitHigherDim (Grid v) = + let (a, b) = + withDict + (sizeProof @as) + (V.splitAt + (fromIntegral $ + GHC.natVal (Proxy @(CoordSized b)) * + GHC.natVal (Proxy @(MaxCoordSize as))) + v) + in (Grid a, Grid b) + +mapLowerDim :: + forall as bs x y c f. (AllSizedKnown as, Applicative f) + => (Grid as x -> f (Grid bs y)) + -> Grid (c ': as) x + -> f (Grid (c ': bs) y) +mapLowerDim f (Grid v) = + withDict + (sizeProof @as) + (fmap (Grid . V.concat) $ + traverse (fmap unGrid . f . Grid) $ + splitVectorBySize + (fromIntegral (GHC.natVal (Proxy @(MaxCoordSize as)))) + v) + +class ShrinkableGrid (cs :: [*]) (as :: [*]) (bs :: [*]) where + shrinkGrid :: Coord cs -> Grid as x -> Grid bs x + +instance ShrinkableGrid '[] '[] '[] where + shrinkGrid _ (Grid v) = Grid v + +instance ( KnownNat (CoordSized b) + , AllSizedKnown as + , IsCoord c + , ShrinkableGrid cs as bs + , CoordFromNat b ~ CoordFromNat a + , CoordSized b <= (CoordSized a - CoordSized c + 1) + ) => + ShrinkableGrid (c ': cs) (a ': as) (b ': bs) where + shrinkGrid (c :| cs) = + combineGrid . fmap (shrinkGrid cs) . helper . splitGrid + where + helper :: Grid '[ a] x -> Grid '[ b] x + helper g = + asSizeProxy c $ \(pTake :: Proxy n) -> + withDict + (coordFromNatCollapse @a @(CoordSized a - n) @(CoordSized b)) + (takeGrid (Proxy :: Proxy (CoordSized b)) (dropGrid pTake g) \\ + coordFromNatSame @b @a) + shrinkGrid _ = error "Impossible pattern in shrinkGrid" + diff --git a/src/SizedGrid/Ordinal.hs b/src/SizedGrid/Ordinal.hs --- a/src/SizedGrid/Ordinal.hs +++ b/src/SizedGrid/Ordinal.hs @@ -17,6 +17,7 @@ import SizedGrid.Internal.Type +import Control.Lens (Prism', prism') import Control.Monad (guard) import Data.Aeson import Data.Constraint @@ -63,6 +64,16 @@ -- | Transform an ordinal to a given number ordinalToNum :: Num a => Ordinal m -> a ordinalToNum (Ordinal p) = fromIntegral $ natVal p + +strengthenOrdinal :: forall n m . (KnownNat m, n <= m) => Ordinal n -> Ordinal m +strengthenOrdinal (Ordinal (p :: Proxy x)) = (Ordinal p) \\ leTrans @(x + 1) @n @m + +weakenOrdinal :: KnownNat m => Ordinal n -> Maybe (Ordinal m) +weakenOrdinal = numToOrdinal . ordinalToNum @Integer + +-- | Convert between an ordinal and a usual number. This is a `Prism` as it may fail as `Oridnals` can only exist in a certain range. +_Ordinal :: (KnownNat n, Integral a) => Prism' a (Ordinal n) +_Ordinal = prism' ordinalToNum numToOrdinal instance (1 <= m, KnownNat m) => Bounded (Ordinal m) where minBound = Ordinal (Proxy @0) diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -6,32 +6,51 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Main where import SizedGrid +import Test.Shrink import Test.Utils -import Control.Lens hiding (index) -import Control.Monad (replicateM) +import Control.Lens hiding (index) +import Control.Monad (replicateM) import Data.Functor.Rep import Data.Proxy -import Generics.SOP hiding (S, Z) +import qualified Data.Vector as V +import Generics.SOP hiding (S, Z) +import qualified GHC.Generics as GHC import GHC.TypeLits -import qualified GHC.TypeLits as GHC -import Hedgehog -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import qualified GHC.TypeLits as GHC +import Test.QuickCheck (Arbitrary (..), Arbitrary1 (..), + Property, oneof, property, (.&&.), + (===)) import Test.Tasty -import Test.Tasty.Hedgehog import Test.Tasty.HUnit +import Test.Tasty.QuickCheck (testProperty) +instance (1 <= n, KnownNat n) => Arbitrary (Periodic n) where + arbitrary = Periodic <$> oneof (map pure [minBound .. maxBound]) + +instance (1 <= n, KnownNat n) => Arbitrary (HardWrap n) where + arbitrary = HardWrap <$> oneof (map pure [minBound .. maxBound]) + +instance (All Arbitrary cs, SListI cs) => Arbitrary (Coord cs) where + arbitrary = Coord <$> hsequence (hcpure (Proxy @Arbitrary) arbitrary) + +instance AllSizedKnown cs => Arbitrary1 (Grid cs) where + liftArbitrary g = sequenceA (pure g) + +instance (AllSizedKnown cs, Arbitrary a) => Arbitrary (Grid cs a) where + arbitrary = liftArbitrary arbitrary + assertOrderd :: Ord a => [a] -> Assertion assertOrderd = let helper [] = True helper (x:xs) = all (x <=) xs && helper xs - in assertBool "Ordered" . helper + in assertBool "Ordered" . helper testAllCoordOrdered :: forall cs proxy. (All Eq cs, All Ord cs, All IsCoord cs) @@ -40,128 +59,174 @@ testAllCoordOrdered _ = testCase "allCoord is ordered" $ assertOrderd (allCoord @cs) -genPeriodic :: (1 <= n, GHC.KnownNat n) => Gen (Periodic n) -genPeriodic = Periodic <$> Gen.enumBounded - -genCoord :: SListI cs => NP Gen cs -> Gen (Coord cs) -genCoord start = Coord <$> hsequence start - gridTests :: forall cs a x y. ( Show (Coord cs) , Eq (Coord cs) , All IsCoord cs - , GHC.KnownNat (MaxCoordSize cs) + , AllSizedKnown cs , Show a , Eq a - , AllGridSizeKnown cs - , cs ~ '[x,y] - , GHC.KnownNat (MaxCoordSize '[y,x]) + , cs ~ '[ x, y] + , KnownNat (CoordSized y * CoordSized x) + , KnownNat (CoordSized x * CoordSized y) + , Arbitrary a + , Arbitrary x + , Arbitrary y ) - => Gen (Coord cs) - -> Gen a + => Proxy (Coord cs) + -> Proxy a -> [TestTree] gridTests genC genA = - let tabulateIndex = - property $ do - c <- forAll genC - c === index (tabulate id :: Grid cs (Coord cs)) c - collapseUnCollapse = - property $ do - g :: Grid cs a <- forAll (sequenceA $ pure genA) - Just g === gridFromList (collapseGrid g) - uncollapseCollapse = - property $ do - cg :: [[a]] <- - replicateM (fromIntegral $ natVal (Proxy @(CoordSized x))) $ - replicateM (fromIntegral $ natVal (Proxy @(CoordSized y))) $ forAll genA - Just cg === (collapseGrid <$> gridFromList @cs cg) - doubleTranspose = property $ do - g :: Grid cs a <- forAll (sequenceA $ pure genA) - g === transposeGrid (transposeGrid g) - in [ testProperty "Tabulate index" tabulateIndex - , testProperty "Collapse UnCollapse" collapseUnCollapse - , testProperty "UnCollapse and Collapse" uncollapseCollapse - , testProperty "Transpose twice is id" doubleTranspose - ] + let tabulateIndex :: Coord cs -> Property + tabulateIndex c = c === index (tabulate id :: Grid cs (Coord cs)) c + collapseUnCollapse :: Property + collapseUnCollapse = + property $ do + g :: Grid cs a <- sequenceA $ pure arbitrary + return (Just g === gridFromList (collapseGrid g)) + uncollapseCollapse = + property $ do + cg :: [[a]] <- + replicateM (fromIntegral $ natVal (Proxy @(CoordSized x))) $ + replicateM (fromIntegral $ natVal (Proxy @(CoordSized y))) $ + arbitrary + return (Just cg === (collapseGrid <$> gridFromList @cs cg)) + doubleTranspose = + property $ do + g :: Grid cs a <- sequenceA $ pure arbitrary + return (g === transposeGrid (transposeGrid g)) + in [ testProperty "Tabulate index" tabulateIndex + , testProperty "Collapse UnCollapse" collapseUnCollapse + , testProperty "UnCollapse and Collapse" uncollapseCollapse + , testProperty "Transpose twice is id" doubleTranspose + ] -twoDimensionalCoordTests :: (cs ~ '[x,y], All Show cs, All Eq cs) => Gen (Coord cs) -> [TestTree] -twoDimensionalCoordTests genC = - let doubleTranspose = property $ do - c <- forAll genC - c === tranposeCoord (tranposeCoord c) +splitTests :: + forall c cs a. + ( Show a + , Eq a + , Num a + , All IsCoord (c ': cs) + , KnownNat (CoordSized c * MaxCoordSize cs) + , KnownNat (MaxCoordSize cs) + , KnownNat (5 * MaxCoordSize cs) + , KnownNat (3 * MaxCoordSize cs) + , KnownNat (2 * MaxCoordSize cs) + , KnownNat (CoordSized (CoordFromNat c 2) * MaxCoordSize cs) + , KnownNat (CoordSized (CoordFromNat c 2)) + , AllSizedKnown cs + , Arbitrary a + ) + => Proxy (c ': cs) + -> Proxy a + -> [TestTree] +splitTests _ _ = + let splitAndCombine = + property $ do + g :: Grid (c ': cs) a <- sequenceA $ pure arbitrary + return (g === combineGrid (splitGrid g)) + combineAndSplit = + property $ do + g :: Grid '[ c] (Grid cs a) <- + sequenceA $ pure (sequenceA $ pure arbitrary) + return (g === splitGrid (combineGrid g)) + higherSplitAndCombine = + property $ do + g :: Grid (Ordinal 5 ': cs) a <- sequenceA $ pure arbitrary + let (a :: Grid (Ordinal 3 ': cs) a, b) = splitHigherDim g + return (g === combineHigherDim a b) + higherCombineAndSplit = + property $ do + g1 :: Grid (Ordinal 3 ': cs) a <- sequenceA $ pure arbitrary + g2 :: Grid (Ordinal 2 ': cs) a <- sequenceA $ pure arbitrary + let g = combineHigherDim g1 g2 + return ((g1, g2) === splitHigherDim g) + in [ testProperty "Split and Combine" splitAndCombine + , testProperty "Combine and split" combineAndSplit + , testProperty "Split and Combine Higher dim" higherSplitAndCombine + , testProperty "Combine and Split Higher dim" higherCombineAndSplit + ] + +twoDimensionalCoordTests :: + forall cs x y . (cs ~ '[ x, y], All Show cs, All Eq cs, All Arbitrary cs) + => Proxy (Coord cs) + -> [TestTree] +twoDimensionalCoordTests _ = + let doubleTranspose :: Coord cs -> Property + doubleTranspose c = c === tranposeCoord (tranposeCoord c) in [testProperty "Transpose twice is id" doubleTranspose] coordCreationTests :: - (All Show cs, All Eq cs, Eq a, Show a, Show c, Eq c) - => Gen (Coord (c ': cs)) - -> Gen a + forall cs a c. + ( All Show cs + , All Eq cs + , Eq a + , Show a + , Show c + , Eq c + , Arbitrary a + , All Arbitrary cs + , Arbitrary c + ) + => Proxy (Coord (c ': cs)) + -> Proxy a -> [TestTree] coordCreationTests genC gen = [ testProperty "Create single coord" $ - property $ forAll gen >>= \g -> g === (singleCoord g ^. _1) - , testProperty "Create double coord" $ property $ do - a <- forAll gen - b <- forAll gen - let coord = appendCoord b $ singleCoord a - a === coord ^. _2 - b === coord ^. _1 - , testProperty "Create triple coord" $ property $ do - a <- forAll gen - b <- forAll gen - c <- forAll gen - let coord = appendCoord c $ appendCoord b $ singleCoord a - a === coord ^. _3 - b === coord ^. _2 - c === coord ^. _1 - , testProperty "Head and append" $ property $ do - coord <- forAll genC - a <- forAll gen - let newCoord = appendCoord a coord - a === newCoord ^. coordHead - coord === newCoord ^. coordTail - , testProperty "Tail destruction" $ property $ do - coord <- forAll genC - appendCoord (coord ^. coordHead) (coord ^. coordTail) === coord + property $ \(g :: a) -> g === (singleCoord g ^. _1) + , testProperty "Create double coord" $ + property $ \(a :: a) (b :: a) -> + let coord = b :| singleCoord a + in (a === coord ^. _2) .&&. (b === coord ^. _1) + , testProperty "Create triple coord" $ + property $ \(a :: a) (b :: a) (c :: a) -> + let coord = c :| (b :| singleCoord a) + in (a === coord ^. _3) .&&. (b === coord ^. _2) .&&. (c === coord ^. _1) + , testProperty "Head and append" $ + property $ \(coord :: Coord (c ': cs)) (a :: a) -> + let newCoord = appendCoord a coord + in (a === newCoord ^. coordHead) .&&. (coord === newCoord ^. coordTail) + , testProperty "Tail destruction" $ + property $ \(coord :: Coord (c ': cs)) -> + appendCoord (coord ^. coordHead) (coord ^. coordTail) === coord ] main :: IO () main = let periodic = - let g :: Gen (Periodic 10) = genPeriodic - in [ semigroupLaws g - , monoidLaws g - , additiveGroupLaws g - , affineSpaceLaws g - , aesonLaws g + let p = Proxy @(Periodic 10) + in [ semigroupLaws p + , monoidLaws p + , additiveGroupLaws p + , affineSpaceLaws p + , aesonLaws p + , isCoordLaws p ] hardWrap = - let g :: Gen (HardWrap 10) = HardWrap <$> Gen.enumBounded - in [semigroupLaws g, monoidLaws g, affineSpaceLaws g, aesonLaws g] + let p = Proxy @(HardWrap 10) + in [ semigroupLaws p + , monoidLaws p + , affineSpaceLaws p + , aesonLaws p + , isCoordLaws p + ] coord = - let g :: Gen (Coord '[ HardWrap 10, Periodic 20]) = - genCoord - ((HardWrap <$> Gen.enumBounded) :* - (Periodic <$> Gen.enumBounded) :* - Nil) - in [ semigroupLaws g - , monoidLaws g - , affineSpaceLaws g - , aesonLaws g - , testAllCoordOrdered g + let p = Proxy @(Coord '[ HardWrap 10, Periodic 20]) + in [ semigroupLaws p + , monoidLaws p + , affineSpaceLaws p + , aesonLaws p + , testAllCoordOrdered p ] coord2 = - let g :: Gen (Coord '[ Periodic 10, Periodic 20]) = - genCoord - ((Periodic <$> Gen.enumBounded) :* - (Periodic <$> Gen.enumBounded) :* - Nil) - in [ semigroupLaws g - , monoidLaws g - , affineSpaceLaws g - , additiveGroupLaws g - , aesonLaws g - , testAllCoordOrdered g + let p = Proxy @(Coord '[ Periodic 10, Periodic 20]) + in [ semigroupLaws p + , monoidLaws p + , affineSpaceLaws p + , additiveGroupLaws p + , aesonLaws p + , testAllCoordOrdered p ] in defaultMain $ testGroup @@ -170,34 +235,28 @@ , testGroup "HardWrap 20" hardWrap , testGroup "Coord [HardWrap 10, Periodic 20]" coord , testGroup "Coord [Periodic 10, Periodic 20]" coord2 - , testGroup "2D Coords" $ twoDimensionalCoordTests - (genCoord - ((HardWrap <$> Gen.enumBounded) :* - (Periodic <$> Gen.enumBounded) :* - Nil) :: Gen (Coord '[ HardWrap 10, Periodic 10])) + , testGroup "2D Coords" $ + twoDimensionalCoordTests (Proxy @(Coord '[ HardWrap 10, Periodic 10])) , testGroup "Coord creation" (coordCreationTests - (genCoord - ((HardWrap <$> Gen.enumBounded) :* - (Periodic <$> Gen.enumBounded) :* - Nil) :: Gen (Coord '[ HardWrap 10, Periodic 10])) - (Gen.enumBounded :: Gen Int)) + (Proxy @(Coord '[ HardWrap 10, Periodic 10])) + (Proxy @Int)) , testGroup "Grid" ((gridTests - @'[ Periodic 10, Periodic 11] - (genCoord $ - (Periodic <$> Gen.enumBounded) :* (Periodic <$> Gen.enumBounded) :* - Nil)) - (Gen.int $ Range.linear 0 100) ++ - [ applicativeLaws - (Proxy @(Grid '[ Periodic 10, Periodic 11])) - (Gen.int $ Range.linear 0 100) - , aesonLaws - (sequenceA $ - pure @(Grid '[ Periodic 10, Periodic 11]) $ - Gen.int $ Range.linear 0 100) - , eq1Laws (Proxy @(Grid '[ Periodic 10, Periodic 20])) - ]) + (Proxy @(Coord ('[ Periodic 10, Periodic 11]))) + (Proxy @Int) ++ + [ applicativeLaws + (Proxy @(Grid '[ Periodic 10, Periodic 11])) + (Proxy @Int) + , aesonLaws (Proxy @(Grid '[ Periodic 10, Periodic 11] Int)) + , eq1Laws (Proxy @(Grid '[ Periodic 10, Periodic 20])) + ])) + , testGroup + "Splitting" + (splitTests + (Proxy @('[ HardWrap 8, HardWrap 3, HardWrap 5])) + (Proxy @Int)) + , shrinkTests ] diff --git a/tests/Test/Shrink.hs b/tests/Test/Shrink.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Shrink.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Shrink where + +import Data.Maybe (fromJust) +import SizedGrid +import Test.Tasty +import Test.Tasty.HUnit + +exampleGrid :: Grid '[Ordinal 3, Ordinal 3] Int +exampleGrid = fromJust $ gridFromList [[1,2,3],[4,5,6],[7,8,9]] + +focusCenter :: Grid '[ Ordinal 1, Ordinal 1] Int +focusCenter = + let c :: Coord '[Ordinal 3, Ordinal 3] = + fromJust $ + (\x y -> x :| y :| EmptyCoord) <$> numToOrdinal (1 :: Int) <*> + numToOrdinal (1 :: Int) + in shrinkGrid c exampleGrid + +shrinkTests :: TestTree +shrinkTests = testCase "Focusing" $ do + assertEqual "Focus Center" focusCenter $ fromJust (gridFromList [[5]]) diff --git a/tests/Test/Utils.hs b/tests/Test/Utils.hs --- a/tests/Test/Utils.hs +++ b/tests/Test/Utils.hs @@ -1,22 +1,30 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Test.Utils where +import SizedGrid.Coord.Class +import SizedGrid.Ordinal + +#if MIN_VERSION_base(4,11,0) +#else +import Data.Semigroup +#endif +import Control.Lens import Data.AdditiveGroup import Data.Aeson import Data.AffineSpace import Data.Functor.Classes +import Data.Functor.Compose import Data.Proxy -import Data.Semigroup -import Hedgehog -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import GHC.TypeLits import Test.Tasty -import Test.Tasty.Hedgehog import Test.Tasty.HUnit +import Test.Tasty.QuickCheck eq1Laws :: forall f. (Eq1 f, Applicative f) @@ -27,39 +35,35 @@ assertEqual "Nil equal" True $ liftEq (==) (pure ()) (pure @f ()) in testGroup "Eq1 Laws" [testCase "Nil Eq" nilEq] -aesonLaws :: (Show a, Eq a, ToJSON a, FromJSON a) => Gen a -> TestTree -aesonLaws gen = - let encodeDecode = property $ do - a <- forAll gen - Just a === decode (encode a) - in testGroup "Aeson Laws" [testProperty "Encode decode" encodeDecode] +aesonLaws :: + forall a proxy. (Show a, Eq a, ToJSON a, FromJSON a, Arbitrary a) + => proxy a + -> TestTree +aesonLaws _ = + let encodeDecode :: a -> Property + encodeDecode a = Just a === decode (encode a) + in testGroup "Aeson Laws" [testProperty "Encode decode" encodeDecode] -semigroupLaws :: (Show a, Eq a, Semigroup a) => Gen a -> TestTree -semigroupLaws gen = - let assoc = property $ do - a <- forAll gen - b <- forAll gen - c <- forAll gen - a <> (b <> c) === (a <> b) <> c +semigroupLaws :: + forall a proxy. (Show a, Eq a, Semigroup a, Arbitrary a) + => proxy a + -> TestTree +semigroupLaws _ = + let assoc :: a -> a -> a -> Property + assoc a b c = a <> (b <> c) === (a <> b) <> c in testGroup "Semigroup Laws" [testProperty "Associative" assoc] -monoidLaws :: (Show a, Eq a, Monoid a) => Gen a -> TestTree -monoidLaws gen = - let assoc = - property $ do - a <- forAll gen - b <- forAll gen - c <- forAll gen - mappend a (mappend b c) === mappend (mappend a b) c - memptyId = - property $ do - a <- forAll gen - a === mappend mempty a - a === mappend a mempty - concatIsFold = - property $ do - as <- forAll $ Gen.list (Range.linear 0 100) gen - mconcat as === foldr mappend mempty as +monoidLaws :: + forall a proxy. (Show a, Eq a, Monoid a, Arbitrary a) + => proxy a + -> TestTree +monoidLaws _ = + let assoc :: a -> a -> a -> Property + assoc a b c = mappend a (mappend b c) === mappend (mappend a b) c + memptyId :: a -> Property + memptyId a = (a === (mappend mempty a)) .&&. ((a === mappend a mempty)) + concatIsFold :: [a] -> Property + concatIsFold as = mconcat as === foldr mappend mempty as in testGroup "Monoid laws" [ testProperty "Associative" assoc @@ -67,26 +71,19 @@ , testProperty "Concat is Fold" concatIsFold ] -additiveGroupLaws :: (Show a, Eq a, AdditiveGroup a) => Gen a -> TestTree -additiveGroupLaws gen = - let assoc = - property $ do - a <- forAll gen - b <- forAll gen - c <- forAll gen - a ^+^ (b ^+^ c) === (a ^+^ b) ^+^ c - zeroId = - property $ do - a <- forAll gen - a === zeroV ^+^ a - a === a ^+^ zeroV - inverseId = property $ do - a <- forAll gen - a ^-^ a === zeroV - takeLeaves = property $ do - a <- forAll gen - b <- forAll gen - a ^-^ (a ^-^ b) === b +additiveGroupLaws :: + forall a proxy. (Show a, Eq a, AdditiveGroup a, Arbitrary a) + => proxy a + -> TestTree +additiveGroupLaws _ = + let assoc :: a -> a -> a -> Property + assoc a b c = a ^+^ (b ^+^ c) === (a ^+^ b) ^+^ c + zeroId :: a -> Property + zeroId a = (a === zeroV ^+^ a) .&&. (a === a ^+^ zeroV) + inverseId :: a -> Property + inverseId a = a ^-^ a === zeroV + takeLeaves :: a -> a -> Property + takeLeaves a b = a ^-^ (a ^-^ b) === b in testGroup "AdditiveGroup laws" [ testProperty "Associative" assoc @@ -96,41 +93,121 @@ ] affineSpaceLaws :: - (Show a, Eq a, AffineSpace a, Eq (Diff a), Show (Diff a)) - => Gen a - -> TestTree -affineSpaceLaws gen = - let addZero = - property $ do - a <- forAll gen - a === a .+^ zeroV - takeSelf = - property $ do - a <- forAll gen - a .-. a === zeroV - in testGroup - "AffineSpace Laws" - [testProperty "Add Zero" addZero, testProperty "Take self" takeSelf] + forall a proxy. + (Arbitrary a, Show a, Eq a, AffineSpace a, Eq (Diff a), Show (Diff a)) + => proxy a + -> TestTree +affineSpaceLaws _ = + let addZero :: a -> Property + addZero a = a === a .+^ zeroV + takeSelf :: a -> Property + takeSelf a = a .-. a === zeroV + in testGroup + "AffineSpace Laws" + [testProperty "Add Zero" addZero, testProperty "Take self" takeSelf] applicativeLaws :: - forall f a. - (Applicative f, Traversable f, Show (f a), Eq (f a), Num a, Show a) - => Proxy f - -> Gen a - -> TestTree -applicativeLaws _ gen = - let genF :: Gen (f a) = sequence $ pure gen - identiy = - property $ do - v <- forAll genF - v === (pure id <*> v) - homomorphism = - property $ do - x <- forAll gen - f <- (+) <$> forAll gen - (pure f <*> pure x) === pure @f (f x) - in testGroup - "Applicative Laws" - [ testProperty "Identity" identiy - , testProperty "Homomorphism" homomorphism - ] + forall f a. + ( Applicative f + , Traversable f + , Show (f a) + , Eq (f a) + , Show a + , Arbitrary a + , Arbitrary1 f + , Function a + , CoArbitrary a + ) + => Proxy f + -> Proxy a + -> TestTree +applicativeLaws _ _ = + let identiy :: Gen Property + identiy = do + v :: f a <- liftArbitrary arbitrary + return (v === (pure id <*> v)) + homomorphism = do + x :: a <- arbitrary + f :: (a -> a) <- applyFun <$> arbitrary + return ((pure f <*> pure x) === pure @f (f x)) + interchange :: Gen Property + interchange = do + u :: f (a -> a) <- liftArbitrary (applyFun <$> arbitrary) + y :: a <- arbitrary + let lhs :: f a = u <*> pure y + rhs :: f a = pure ($ y) <*> u + return (lhs === rhs) + fmapLaw = do + f :: (a -> a) <- applyFun <$> arbitrary + x :: f a <- liftArbitrary arbitrary + return ((f <$> x) === (pure f <*> x)) + composition = do + u :: f (a -> a) <- liftArbitrary (applyFun <$> arbitrary) + v :: f (a -> a) <- liftArbitrary (applyFun <$> arbitrary) + w :: f a <- liftArbitrary arbitrary + let lhs = u <*> (v <*> w) + rhs = pure (.) <*> u <*> v <*> w + return (lhs === rhs) + in testGroup + "Applicative Laws" + [ testProperty "Identity" (property identiy) + , testProperty "Homomorphism" (property homomorphism) + , testProperty "Interchange" (property interchange) + , testProperty "Fmap Law" (property fmapLaw) + , testProperty "Composiiton" (property composition) + ] + +traversalLaws :: + forall a f b. + ( Eq a + , Show a + , Functor f + , Arbitrary a + , Function b + , CoArbitrary b + , Arbitrary b + ) + => Traversal' a (f b) + -> TestTree +traversalLaws t = + let pureId = + property $ do + a :: a <- arbitrary + return (pure @[] a === t pure a) + compose = + property $ do + a :: a <- arbitrary + fFunc :: b -> b <- applyFun <$> arbitrary + gFunc :: b -> b <- applyFun <$> arbitrary + let raiseFunc f x = Just (f <$> x) + return + (fmap (t (raiseFunc fFunc)) (t (raiseFunc gFunc) a) === + getCompose + (t (Compose . fmap (raiseFunc fFunc) . (raiseFunc gFunc)) a)) + in testGroup + "Traveral Laws" + [testProperty "Pure Id" pureId, testProperty "Compose" compose] + +isCoordLaws :: + forall a. (IsCoord a) + => Proxy a + -> TestTree +isCoordLaws p = + testCase "IsCoord Laws" $ do + assertEqual + "Max coord size is sCoordSized" + (maxCoordSize p) + (natVal (sCoordSized p) - 1) + assertEqual + "zeroPosition is Zero" + (0 :: Int) + (ordinalToNum $ view asOrdinal (zeroPosition @a)) + assertEqual + "Size Proxy Zero" + (0 :: Integer) + (asSizeProxy (zeroPosition @a) natVal) + assertEqual + "Max size equality" + (ordinalToNum $ view asOrdinal (maxCoord @a)) + (maxCoordSize p) +