diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.0.0.0 + +Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2021, Rob Rix + +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 Rob Rix 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/fresnel.cabal b/fresnel.cabal new file mode 100644 --- /dev/null +++ b/fresnel.cabal @@ -0,0 +1,117 @@ +cabal-version: 2.4 +name: fresnel +version: 0.0.0.0 +synopsis: high-powered optics in a small package +description: fresnel offers (non-indexed) profunctor optics composed with the lowly . operator. +homepage: https://github.com/fresnel/fresnel +bug-reports: https://github.com/fresnel/fresnel/issues +license: BSD-3-Clause +license-file: LICENSE +author: Rob Rix +maintainer: rob.rix@me.com + +copyright: 2021–2022 Rob Rix +category: Control +extra-source-files: CHANGELOG.md + +common common + default-language: Haskell2010 + ghc-options: + -Weverything + -Wno-all-missed-specialisations + -Wno-implicit-prelude + -Wno-missed-specialisations + -Wno-missing-import-lists + -Wno-missing-local-signatures + -Wno-missing-safe-haskell-mode + -Wno-monomorphism-restriction + -Wno-name-shadowing + -Wno-safe + -Wno-unsafe + if (impl(ghc >= 8.8)) + ghc-options: -Wno-missing-deriving-strategies + if (impl(ghc >= 8.10)) + ghc-options: + -Wno-missing-safe-haskell-mode + -Wno-prepositive-qualified-module + +library + import: common + exposed-modules: + Fresnel.At + Fresnel.Bifunctor.Contravariant + Fresnel.Either + Fresnel.Fold + Fresnel.Functor.Backwards + Fresnel.Functor.Traversed + Fresnel.Getter + Fresnel.Iso + Fresnel.Ixed + Fresnel.Lens + Fresnel.List + Fresnel.List.NonEmpty + Fresnel.Maybe + Fresnel.Monoid.Cons + Fresnel.Monoid.Fork + Fresnel.Monoid.Snoc + Fresnel.Optic + Fresnel.Optional + Fresnel.OptionalFold + Fresnel.Prism + Fresnel.Profunctor.Coexp + Fresnel.Profunctor.OptionalStar + Fresnel.Profunctor.Recall + Fresnel.Review + Fresnel.Set + Fresnel.Setter + Fresnel.Traversal + Fresnel.Tuple + other-modules: + Fresnel.Getter.Internal + Fresnel.Iso.Internal + Fresnel.Lens.Internal + Fresnel.Optional.Internal + Fresnel.OptionalFold.Internal + Fresnel.Prism.Internal + Fresnel.Traversal.Internal + build-depends: + , base >=4.14 && < 5 + , containers >= 0.5 && < 0.7 + , hashable ^>= 1.3 + , profunctors ^>= 5.6 + , transformers >= 0.4 && < 0.6 + , unordered-containers ^>= 0.2 + hs-source-dirs: src + +test-suite test + import: common + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + other-modules: + Fold.Test + Fresnel.Tropical + Getter.Test + Iso.Test + Monoid.Fork.Test + Profunctor.Coexp.Test + Review.Test + Test.Group + Test.Options + Test.Print + Test.Run + Tropical.Test + build-depends: + , ansi-terminal ^>= 0.11 + , base + , containers + , fresnel + , fused-effects + , template-haskell + , QuickCheck ^>= 2.14 + + +source-repository head + type: git + location: https://github.com/fresnel/fresnel + subdir: fresnel diff --git a/src/Fresnel/At.hs b/src/Fresnel/At.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/At.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE RankNTypes #-} +module Fresnel.At +( -- * Updateable collections + At(..) +, Index +, IxValue + -- * Construction +, atSet +, atMap +, ixAt + -- * Elimination +, sans +) where + +import Control.Monad (guard) +import qualified Data.HashMap.Internal.Strict as HashMap +import qualified Data.HashSet as HashSet +import Data.Hashable +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Set as Set +import Fresnel.Ixed +import Fresnel.Lens (Lens', lens) +import Fresnel.Maybe (_Just) +import Fresnel.Optional (Optional') +import Fresnel.Setter + +-- Updateable collections + +class Ixed c => At c where + at :: Index c -> Lens' c (Maybe (IxValue c)) + +instance At IntSet.IntSet where + at = atSet IntSet.member IntSet.insert IntSet.delete + +instance At (IntMap.IntMap v) where + at = atMap IntMap.lookup IntMap.insert IntMap.delete + +instance Ord k => At (Set.Set k) where + at = atSet Set.member Set.insert Set.delete + +instance Ord k => At (Map.Map k v) where + at = atMap Map.lookup Map.insert Map.delete + +instance (Eq k, Hashable k) => At (HashSet.HashSet k) where + at = atSet HashSet.member HashSet.insert HashSet.delete + +instance (Eq k, Hashable k) => At (HashMap.HashMap k v) where + at = atMap HashMap.lookup HashMap.insert HashMap.delete + +instance At (Maybe a) where + at _ = lens id (const id) + + +-- Construction + +atSet :: (Index c -> c -> Bool) -> (Index c -> c -> c) -> (Index c -> c -> c) -> Index c -> Lens' c (Maybe ()) +atSet member insert delete k = lens (guard . member k) (\ s -> maybe (delete k s) (const (insert k s))) + +atMap :: (Index c -> c -> Maybe (IxValue c)) -> (Index c -> IxValue c -> c -> c) -> (Index c -> c -> c) -> Index c -> Lens' c (Maybe (IxValue c)) +atMap lookup insert delete k = lens (lookup k) (\ m -> maybe (delete k m) (flip (insert k) m)) + +ixAt :: At a => Index a -> Optional' a (IxValue a) +ixAt i = at i . _Just + + +-- Elimination + +sans :: At c => Index c -> c -> c +sans k = at k .~ Nothing diff --git a/src/Fresnel/Bifunctor/Contravariant.hs b/src/Fresnel/Bifunctor/Contravariant.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Bifunctor/Contravariant.hs @@ -0,0 +1,45 @@ +module Fresnel.Bifunctor.Contravariant +( -- * Bicontravariant functors + Bicontravariant(..) +, contrafirst +, contrasecond + -- * Phantom parameters +, rphantom +, biphantom +) where + +import Data.Bifunctor (Bifunctor(..)) +import Data.Profunctor (Forget(..), Profunctor(..), Star(..)) +import Data.Functor.Contravariant +import Control.Arrow + +-- Bicontravariant functors + +class Bicontravariant p where + contrabimap :: (a' -> a) -> (b' -> b) -> p a b -> p a' b' + +instance Bicontravariant (Forget r) where + contrabimap f _ = Forget . lmap f . runForget + +instance Contravariant f => Bicontravariant (Star f) where + contrabimap f g = Star . dimap f (contramap g) . runStar + +instance Contravariant m => Bicontravariant (Kleisli m) where + contrabimap f g = Kleisli . dimap f (contramap g) . runKleisli + + +contrafirst :: Bicontravariant p => (a' -> a) -> p a b -> p a' b +contrafirst = (`contrabimap` id) + +contrasecond :: Bicontravariant p => (b' -> b) -> p a b -> p a b' +contrasecond = (id `contrabimap`) + + +-- Phantom parameters + +rphantom :: (Profunctor p, Bicontravariant p) => p a b -> p a c +rphantom = contrasecond (const ()) . rmap (const ()) + + +biphantom :: (Bifunctor p, Bicontravariant p) => p a b -> p c d +biphantom = contrabimap (const ()) (const ()) . bimap (const ()) (const ()) diff --git a/src/Fresnel/Either.hs b/src/Fresnel/Either.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Either.hs @@ -0,0 +1,15 @@ +module Fresnel.Either +( -- * Prisms + _Left +, _Right +) where + +import Fresnel.Prism + +-- Prisms + +_Left :: Prism (Either a b) (Either a' b) a a' +_Left = prism Left (either Right (Left . Right)) + +_Right :: Prism (Either a b) (Either a b') b b' +_Right = prism Right (either (Left . Left) Right) diff --git a/src/Fresnel/Fold.hs b/src/Fresnel/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Fold.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +module Fresnel.Fold +( -- * Folds + Fold +, IsFold + -- * Construction +, folded +, unfolded +, folding +, foldring +, ignored +, backwards + -- * Elimination +, has +, hasn't +, foldMapOf +, foldMapByOf +, foldrOf +, foldlOf' +, foldOf +, sequenceOf_ +, traverseOf_ +, forOf_ +, toListOf +, anyOf +, allOf +, nullOf +, previews +, preview +, (^?) +, Failover(..) +, Union(..) +) where + +import Data.Foldable (traverse_) +import Data.Functor.Contravariant +import Data.Monoid +import Data.Profunctor +import Data.Profunctor.Traversing +import Data.Profunctor.Unsafe ((#.), (.#)) +import Fresnel.Bifunctor.Contravariant +import Fresnel.Functor.Backwards (Backwards(..)) +import Fresnel.Functor.Traversed +import Fresnel.Monoid.Cons as Cons +import Fresnel.Monoid.Fork as Fork +import Fresnel.Monoid.Snoc as Snoc +import Fresnel.Optic +import Fresnel.OptionalFold.Internal (IsOptionalFold) +import Fresnel.Traversal.Internal (IsTraversal) + +-- Folds + +type Fold s a = forall p . IsFold p => Optic' p s a + +class (IsOptionalFold p, IsTraversal p) => IsFold p + +instance Monoid r => IsFold (Forget r) +instance (Applicative f, Traversable f, Contravariant f) => IsFold (Star f) + + +-- Construction + +folded :: Foldable f => Fold (f a) a +folded = rphantom . wander traverse_ + +unfolded :: (s -> Maybe (a, s)) -> Fold s a +unfolded coalg = rphantom . wander (\ f -> let loop = maybe (pure ()) (\ (a, s) -> f a *> loop s) . coalg in loop) + +folding :: Foldable f => (s -> f a) -> Fold s a +folding f = contrabimap f (const ()) . rmap (const ()) . wander traverse_ + +foldring :: (forall f . Applicative f => (a -> f u -> f u) -> f v -> s -> f w) -> Fold s a +foldring fr = rphantom . wander (\ f -> fr (\ a -> (f a *>)) (pure v)) where + v = error "foldring: value used" + +ignored :: Fold s a +ignored = foldring (\ _ nil _ -> nil) + +backwards :: Fold s a -> Fold s a +backwards o = rphantom . wander (\ f -> forwards . traverseOf_ o (Backwards #. f)) + + +-- Elimination + +has :: Fold s a -> (s -> Bool) +has o = anyOf o (const True) + +hasn't :: Fold s a -> (s -> Bool) +hasn't = nullOf + + +foldMapOf :: Monoid m => Fold s a -> ((a -> m) -> (s -> m)) +foldMapOf o = runForget #. o .# Forget + +foldMapByOf :: Fold s a -> ((r -> r -> r) -> r -> (a -> r) -> (s -> r)) +foldMapByOf o fork nil leaf s = runFork (runForget (o (Forget Fork.singleton)) s) fork leaf nil + +foldrOf :: Fold s a -> ((a -> r -> r) -> r -> s -> r) +foldrOf o cons nil s = runCons (runForget (o (Forget Cons.singleton)) s) cons nil + +foldlOf' :: Fold s a -> ((r -> a -> r) -> r -> s -> r) +foldlOf' o snoc nil s = runSnoc (runForget (o (Forget Snoc.singleton)) s) snoc nil + +foldOf :: Monoid a => Fold s a -> (s -> a) +foldOf o = foldMapOf o id + +sequenceOf_ :: Applicative f => Fold s (f a) -> (s -> f ()) +sequenceOf_ o = runTraversed . foldMapOf o Traversed + +traverseOf_ :: Applicative f => Fold s a -> ((a -> f r) -> (s -> f ())) +traverseOf_ o f = runTraversed . foldMapOf o (Traversed #. f) + +forOf_ :: Applicative f => Fold s a -> (s -> (a -> f r) -> f ()) +forOf_ o = flip (traverseOf_ o) + +toListOf :: Fold s a -> s -> [a] +toListOf o = foldrOf o (:) [] + +anyOf :: Fold s a -> (a -> Bool) -> (s -> Bool) +anyOf o = foldMapByOf o (||) False + +allOf :: Fold s a -> (a -> Bool) -> (s -> Bool) +allOf o = foldMapByOf o (&&) True + +nullOf :: Fold s a -> (s -> Bool) +nullOf o = foldrOf o (\ _ _ -> False) True + + +previews :: Fold s a -> (a -> r) -> (s -> Maybe r) +previews o f = getFirst #. foldMapOf o (First #. Just . f) + +preview :: Fold s a -> s -> Maybe a +preview o = previews o id + +(^?) :: s -> Fold s a -> Maybe a +s ^? o = preview o s + +infixl 8 ^? + + +newtype Failover s a = Failover { getFailover :: Fold s a } + +instance Semigroup (Failover s a) where + Failover a1 <> Failover a2 = Failover (folding (\ s -> Cons (\ cons nil -> maybe (foldrOf a2 cons nil s) (uncurry cons) (foldrOf a1 (\ a -> Just . (,) a . maybe nil (uncurry cons)) Nothing s)))) + +instance Monoid (Failover s a) where + mempty = Failover ignored + + +newtype Union s a = Union { getUnion :: Fold s a } + +instance Semigroup (Union s a) where + Union a1 <> Union a2 = Union (rphantom . wander (\ f s -> traverseOf_ a1 f s *> traverseOf_ a2 f s) . rphantom) + +instance Monoid (Union s a) where + mempty = Union ignored diff --git a/src/Fresnel/Functor/Backwards.hs b/src/Fresnel/Functor/Backwards.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Functor/Backwards.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Fresnel.Functor.Backwards +( Backwards(..) +) where + +newtype Backwards f a = Backwards { forwards :: f a } + deriving (Applicative, Functor) diff --git a/src/Fresnel/Functor/Traversed.hs b/src/Fresnel/Functor/Traversed.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Functor/Traversed.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Fresnel.Functor.Traversed +( -- * Traversed functor + runTraversed +, Traversed(..) +) where + +import Data.Functor (void) + +-- Traversed functor + +runTraversed :: Functor f => Traversed f a -> f () +runTraversed (Traversed fa) = void fa + +newtype Traversed f a = Traversed (f a) + deriving (Applicative, Functor) + +instance Applicative f => Semigroup (Traversed f a) where + Traversed a1 <> Traversed a2 = Traversed (a1 *> a2) + +instance Applicative f => Monoid (Traversed f a) where + mempty = Traversed (pure (error "Traversed.mempty: value used")) diff --git a/src/Fresnel/Getter.hs b/src/Fresnel/Getter.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Getter.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE RankNTypes #-} +module Fresnel.Getter +( -- * Getters + Getter +, IsGetter + -- * Construction +, to +, getting + -- * Elimination +, views +, view +, (^.) +) where + +import Data.Profunctor +import Data.Profunctor.Unsafe ((#.), (.#)) +import Fresnel.Bifunctor.Contravariant +import Fresnel.Getter.Internal (IsGetter) +import Fresnel.Optic + +-- Getters + +type Getter s a = forall p . IsGetter p => Optic' p s a + + +-- Construction + +to :: (s -> a) -> Getter s a +to f = lmap f . rphantom + + +getting :: (Profunctor p, Bicontravariant p) => Optic p s t a b -> Optic' p s a +getting l f = rphantom . l $ rphantom f + + +-- Elimination + +views :: Getter s a -> (a -> r) -> (s -> r) +views b = runForget #. b .# Forget + +view :: Getter s a -> (s -> a) +view b = views b id + +(^.) :: s -> Getter s a -> a +s ^. o = view o s + +infixl 8 ^. diff --git a/src/Fresnel/Getter/Internal.hs b/src/Fresnel/Getter/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Getter/Internal.hs @@ -0,0 +1,15 @@ +module Fresnel.Getter.Internal +( IsGetter +) where + +import Data.Functor.Contravariant (Contravariant) +import Data.Profunctor (Cochoice, Forget, Star) +import Fresnel.Bifunctor.Contravariant (Bicontravariant) +import Fresnel.Lens.Internal (IsLens) +import Fresnel.Profunctor.OptionalStar (OptionalStar) + +class (IsLens p, Bicontravariant p, Cochoice p) => IsGetter p + +instance IsGetter (Forget r) +instance (Contravariant f, Traversable f) => IsGetter (Star f) +instance (Contravariant f, Traversable f) => IsGetter (OptionalStar f) diff --git a/src/Fresnel/Iso.hs b/src/Fresnel/Iso.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Iso.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE RankNTypes #-} +{-| +@'Iso'@s are the root of the optic hierarchy: an @'Iso'@ can be used anywhere any other kind of optic is required. On the other hand, if something requests an @'Iso'@, it can only be given an @'Iso'@, as it doesn't provide enough capabilities to accept anything else. + +This implies that they're the weakest optic; they make the fewest assumptions, and thus can provide only the most minimal guarantees. Even so, these guarantees are relativevly strong: notionally, an @'Iso'@ consists of functions @/f/@ and @/g/@ which are mutual inverses: + +@ +f '.' g = 'id' +@ +@ +g '.' f = 'id' +@ +-} +module Fresnel.Iso +( -- * Isos + Iso +, Iso' +, IsIso + -- * Construction +, iso +, from + -- * Elimination +, withIso +, under + -- * Functions +, constant +, constantWith +, involuted +, flipped +, curried +, uncurried + -- * Relations +, non +, non' + -- * Tuples +, swapped +, mirrored + -- * Coercion +, coerced +, coercedTo +, coercedFrom + -- * Functor +, fmapping + -- * Contravariant +, contramapping + -- * Bifunctor +, bimapping +, firsting +, seconding + -- * Profunctor +, dimapping +, lmapping +, rmapping + -- * (Co-)representable +, protabulated +, cotabulated +) where + +import Control.Applicative (Alternative) +import Control.Monad (guard) +import Data.Bifunctor +import Data.Coerce (Coercible, coerce) +import Data.Functor.Contravariant +import Data.Maybe (fromMaybe) +import Data.Profunctor +import Data.Profunctor.Rep hiding (cotabulated) +import Data.Profunctor.Sieve +import Data.Tuple (swap) +import Fresnel.Iso.Internal +import Fresnel.Optic +import Fresnel.Optional (isn't) +import Fresnel.Prism (Prism', only) +import Fresnel.Profunctor.Coexp +import Fresnel.Review (review) + +-- Isos + +type Iso s t a b = forall p . IsIso p => Optic p s t a b + +type Iso' s a = Iso s s a a + + +-- Construction + +iso :: (s -> a) -> (b -> t) -> Iso s t a b +iso f g = f `dimap` g + +from :: Iso s t a b -> Iso b a t s +from o = withIso o (flip dimap) + + +-- Elimination + +withIso :: Iso s t a b -> (((s -> a) -> (b -> t) -> r) -> r) +withIso i = withCoexp (i mempty) . flip + + +under :: Iso s t a b -> (t -> s) -> (b -> a) +under i = withIso i (\ f r -> (f .) . (. r)) + + +-- Functions + +constant :: a -> Iso (a -> b) (a' -> b') b b' +constant a = a `constantWith` const + +constantWith :: a -> (b' -> a' -> b') -> Iso (a -> b) (a' -> b') b b' +constantWith a = iso ($ a) + +involuted :: (a -> a) -> Iso' a a +involuted f = iso f f + +flipped :: Iso (a -> b -> c) (a' -> b' -> c') (b -> a -> c) (b' -> a' -> c') +flipped = iso flip flip + +curried :: Iso ((a, b) -> c) ((a', b') -> c') (a -> b -> c) (a' -> b' -> c') +curried = iso curry uncurry + +uncurried :: Iso (a -> b -> c) (a' -> b' -> c') ((a, b) -> c) ((a', b') -> c') +uncurried = iso uncurry curry + + +-- Relations + +non :: Eq a => a -> Iso' (Maybe a) a +non a = non' (only a) + +non' :: Prism' a () -> Iso' (Maybe a) a +non' o = iso (fromMaybe (review o ())) (select (isn't o)) + + +-- Tuples + +swapped :: Iso (a, b) (a', b') (b, a) (b', a') +swapped = iso swap swap + +mirrored :: Iso (Either a b) (Either a' b') (Either b a) (Either b' a') +mirrored = iso mirror mirror + where + mirror = either Right Left + + +-- Coercion + +coerced :: (Coercible s a, Coercible t b) => Iso s t a b +coerced = coerce `iso` coerce + +-- | Build a bidi coercion, taking a constructor for the type being built both to improve type inference and as documentation. +-- +-- For example, given two newtypes @A@ and @B@ wrapping the same type, this expression: +-- +-- @ +-- 'coercedTo' B <<< 'coercedFrom' A +-- @ +-- +-- produces a bijection of type @'Iso'' A B@. +coercedTo :: Coercible t b => (s -> a) -> Iso s t a b +coercedTo f = f `iso` coerce + +-- | Build a bidi coercion, taking a constructor for the type being eliminated both to improve type inference and as documentation. +-- +-- For example, given two newtypes @A@ and @B@ wrapping the same type, this expression: +-- +-- @ +-- 'coercedTo' B <<< 'coercedFrom' A +-- @ +-- +-- produces a bijection of type @'Iso'' A B@. +coercedFrom :: Coercible s a => (b -> t) -> Iso s t a b +coercedFrom g = coerce `iso` g + + +-- Functor + +fmapping :: (Functor f, Functor g) => Iso s t a b -> Iso (f s) (g t) (f a) (g b) +fmapping o = withIso o $ \ sa bt -> iso (fmap sa) (fmap bt) + + +-- Contravariant + +contramapping :: (Contravariant f, Contravariant g) => Iso s t a b -> Iso (f a) (g b) (f s) (g t) +contramapping o = withIso o $ \ sa bt -> iso (contramap sa) (contramap bt) + + +-- Bifunctor + +bimapping :: (Bifunctor p, Bifunctor q) => Iso s t a b -> Iso s' t' a' b' -> Iso (p s s') (q t t') (p a a') (q b b') +bimapping a b = withIso a $ \ lsa lbt -> withIso b $ \ rsa rbt -> iso (bimap lsa rsa) (bimap lbt rbt) + +firsting :: (Bifunctor p, Bifunctor q) => Iso s t a b -> Iso (p s x) (q t y) (p a x) (q b y) +firsting a = withIso a $ \ sa bt -> iso (first sa) (first bt) + +seconding :: (Bifunctor p, Bifunctor q) => Iso s t a b -> Iso (p x s) (q y t) (p x a) (q y b) +seconding b = withIso b $ \ sa bt -> iso (second sa) (second bt) + + +-- Profunctor + +dimapping :: (Profunctor p, Profunctor q) => Iso s t a b -> Iso s' t' a' b' -> Iso (p a s') (q b t') (p s a') (q t b') +dimapping a b = withIso a $ \ lsa lbt -> withIso b $ \ rsa rbt -> iso (dimap lsa rsa) (dimap lbt rbt) + +lmapping :: (Profunctor p, Profunctor q) => Iso s t a b -> Iso (p a x) (q b y) (p s x) (q t y) +lmapping a = withIso a $ \ lsa lbt -> iso (lmap lsa) (lmap lbt) + +rmapping :: (Profunctor p, Profunctor q) => Iso s t a b -> Iso (p x s) (q y t) (p x a) (q y b) +rmapping b = withIso b $ \ rsa rbt -> iso (rmap rsa) (rmap rbt) + + +-- (Co-)representable (profunctorial) + +protabulated :: (Representable p, Representable q) => Iso (a -> Rep p b) (a' -> Rep q b') (p a b) (q a' b') +protabulated = tabulate `iso` sieve + +cotabulated :: (Corepresentable p, Corepresentable q) => Iso (Corep p a -> b) (Corep q a' -> b') (p a b) (q a' b') +cotabulated = cotabulate `iso` cosieve + + +-- Utilities + +select :: Alternative f => (a -> Bool) -> (a -> f a) +select p a = a <$ guard (p a) diff --git a/src/Fresnel/Iso/Internal.hs b/src/Fresnel/Iso/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Iso/Internal.hs @@ -0,0 +1,20 @@ +module Fresnel.Iso.Internal +( IsIso +) where + +import Control.Arrow (Kleisli) +import Data.Profunctor +import Fresnel.Profunctor.Coexp (Coexp) +import Fresnel.Profunctor.OptionalStar (OptionalStar) +import Fresnel.Profunctor.Recall (Recall) + +class Profunctor p => IsIso p + +instance IsIso (->) +instance Monad m => IsIso (Kleisli m) +instance IsIso (Forget r) +instance IsIso (Recall e) +instance Functor f => IsIso (Star f) +instance Functor f => IsIso (Costar f) +instance Functor f => IsIso (OptionalStar f) +instance IsIso (Coexp s t) diff --git a/src/Fresnel/Ixed.hs b/src/Fresnel/Ixed.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Ixed.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +module Fresnel.Ixed +( -- * Indexable collections + Ixed(..) + -- * Construction +, ixSet +, ixMap +, ixList +) where + +import Control.Monad (guard) +import qualified Data.HashMap.Internal as HashMap +import qualified Data.HashSet as HashSet +import Data.Hashable (Hashable) +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map +import qualified Data.Set as Set +import Fresnel.List.NonEmpty (head_, tail_) +import Fresnel.Optional (Optional', optional') + +-- Indexable collections + +class Ixed c where + type Index c + type IxValue c + + ix :: Index c -> Optional' c (IxValue c) + +instance Ixed IntSet.IntSet where + type Index IntSet.IntSet = IntSet.Key + type IxValue IntSet.IntSet = () + + ix = ixSet IntSet.member IntSet.insert + +instance Ixed (IntMap.IntMap v) where + type Index (IntMap.IntMap v) = IntMap.Key + type IxValue (IntMap.IntMap v) = v + + ix = ixMap IntMap.lookup IntMap.insert + +instance Ord k => Ixed (Set.Set k) where + type Index (Set.Set k) = k + type IxValue (Set.Set k) = () + + ix = ixSet Set.member Set.insert + +instance Ord k => Ixed (Map.Map k v) where + type Index (Map.Map k v) = k + type IxValue (Map.Map k v) = v + + ix = ixMap Map.lookup Map.insert + +instance (Eq k, Hashable k) => Ixed (HashSet.HashSet k) where + type Index (HashSet.HashSet k) = k + type IxValue (HashSet.HashSet k) = () + + ix = ixSet HashSet.member HashSet.insert + +instance (Eq k, Hashable k) => Ixed (HashMap.HashMap k v) where + type Index (HashMap.HashMap k v) = k + type IxValue (HashMap.HashMap k v) = v + + ix = ixMap HashMap.lookup HashMap.insert + +instance Ixed (Maybe a) where + type Index (Maybe a) = () + type IxValue (Maybe a) = a + + ix _ = optional' id (\ _ a -> Just a) + +instance Ixed [v] where + type Index [v] = Int + type IxValue [v] = v + + ix k = ixList k + +instance Ixed (NonEmpty.NonEmpty v) where + type Index (NonEmpty.NonEmpty v) = Int + type IxValue (NonEmpty.NonEmpty v) = v + + ix k + | k <= 0 = head_ + | otherwise = tail_.ixList (k - 1) + + +-- Construction + +ixSet :: (Index c -> c -> Bool) -> (Index c -> c -> c) -> Index c -> Optional' c () +ixSet member insert k = optional' (guard . member k) (const . insert k) + +ixMap :: (Index c -> c -> Maybe (IxValue c)) -> (Index c -> IxValue c -> c -> c) -> Index c -> Optional' c (IxValue c) +ixMap lookup insert k = optional' (lookup k) (flip (insert k)) + +ixList :: Int -> Optional' [a] a +ixList i = optional' (get i) (set i) + where + get i as = case as of + [] -> Nothing + a:as -> if i <= 0 then Just a else get (i - 1) as + set i as a' = case as of + [] -> as + a:as -> if i <= 0 then a':as else a : set (i - 1) as a' diff --git a/src/Fresnel/Lens.hs b/src/Fresnel/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Lens.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE RankNTypes #-} +module Fresnel.Lens +( -- * Lenses + Lens +, Lens' +, IsLens + -- * Construction +, lens + -- * Elimination +, withLens + -- * Combinators +, alongside + -- * Unpacked +, UnpackedLens(..) +, unpackedLens +) where + +import Control.Arrow ((&&&), (***)) +import Data.Profunctor +import Fresnel.Iso.Internal (IsIso) +import Fresnel.Lens.Internal (IsLens) +import Fresnel.Optic + +-- Lenses + +type Lens s t a b = forall p . IsLens p => Optic p s t a b + +type Lens' s a = Lens s s a a + + +-- Construction + +lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b +lens get set = dimap (id &&& get) (uncurry set) . second' + + +-- Elimination + +withLens :: Lens s t a b -> (((s -> a) -> (s -> b -> t) -> r) -> r) +withLens o = withUnpackedLens (o (unpackedLens id (const id))) + + +-- Combinators + +alongside :: Lens s1 t1 a1 b1 -> Lens s2 t2 a2 b2 -> Lens (s1, s2) (t1, t2) (a1, a2) (b1, b2) +alongside o1 o2 = withLens o1 $ \ get1 set1 -> withLens o2 $ \ get2 set2 -> + lens (get1 *** get2) (uncurry (***) . (set1 *** set2)) + + +-- Unpacked + +-- | A 'Lens' unpacked into the get & set functions it was constructed from. +newtype UnpackedLens a b s t = UnpackedLens { withUnpackedLens :: forall r . ((s -> a) -> (s -> b -> t) -> r) -> r } + +instance Profunctor (UnpackedLens a b) where + dimap f g (UnpackedLens r) = r $ \ get set -> unpackedLens (get . f) (rmap g . set . f) + +instance Strong (UnpackedLens a b) where + first' (UnpackedLens r) = r $ \ get set -> unpackedLens (get . fst) (\ (a, c) b -> (set a b, c)) + +instance IsIso (UnpackedLens a b) +instance IsLens (UnpackedLens a b) + + +unpackedLens :: (s -> a) -> (s -> b -> t) -> UnpackedLens a b s t +unpackedLens get set = UnpackedLens (\ k -> k get set) diff --git a/src/Fresnel/Lens/Internal.hs b/src/Fresnel/Lens/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Lens/Internal.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE RankNTypes #-} +module Fresnel.Lens.Internal +( IsLens +) where + +import Control.Arrow (Kleisli) +import Data.Profunctor (Forget, Star, Strong) +import Fresnel.Iso.Internal (IsIso) +import Fresnel.Profunctor.OptionalStar (OptionalStar) + +class (IsIso p, Strong p) => IsLens p + +instance IsLens (->) +instance Monad m => IsLens (Kleisli m) +instance IsLens (Forget r) +instance Functor f => IsLens (Star f) +instance Functor f => IsLens (OptionalStar f) diff --git a/src/Fresnel/List.hs b/src/Fresnel/List.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/List.hs @@ -0,0 +1,22 @@ +module Fresnel.List +( -- * Optics + uncons_ +, head_ +, tail_ +) where + +import qualified Data.List as List +import Fresnel.Optional +import Fresnel.Prism +import Fresnel.Tuple + +-- Optics + +uncons_ :: Prism' [a] (a, [a]) +uncons_ = prism' (uncurry (:)) List.uncons + +head_ :: Optional' [a] a +head_ = uncons_.fst_ + +tail_ :: Optional' [a] [a] +tail_ = uncons_.snd_ diff --git a/src/Fresnel/List/NonEmpty.hs b/src/Fresnel/List/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/List/NonEmpty.hs @@ -0,0 +1,26 @@ +module Fresnel.List.NonEmpty +( -- * Optics + nonEmpty_ +, uncons_ +, head_ +, tail_ +) where + +import qualified Data.List.NonEmpty as NE +import Fresnel.Iso (Iso, from, iso) +import Fresnel.Lens (Lens') +import Fresnel.Tuple (fst_, snd_) + +-- Optics + +nonEmpty_ :: Iso [a] [b] (Maybe (NE.NonEmpty a)) (Maybe (NE.NonEmpty b)) +nonEmpty_ = iso NE.nonEmpty (foldMap NE.toList) + +uncons_ :: Iso (NE.NonEmpty a) (NE.NonEmpty b) (a, Maybe (NE.NonEmpty a)) (b, Maybe (NE.NonEmpty b)) +uncons_ = iso NE.uncons (uncurry (NE.:|) . fmap (foldMap NE.toList)) + +head_ :: Lens' (NE.NonEmpty a) a +head_ = uncons_.fst_ + +tail_ :: Lens' (NE.NonEmpty a) [a] +tail_ = uncons_.snd_.from nonEmpty_ diff --git a/src/Fresnel/Maybe.hs b/src/Fresnel/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Maybe.hs @@ -0,0 +1,15 @@ +module Fresnel.Maybe +( -- * Prisms + _Just +, _Nothing +) where + +import Fresnel.Prism + +-- Prisms + +_Just :: Prism (Maybe a) (Maybe a') a a' +_Just = prism Just (maybe (Left Nothing) Right) + +_Nothing :: Prism' (Maybe a) () +_Nothing = prism' (const Nothing) (maybe (Just ()) (const Nothing)) diff --git a/src/Fresnel/Monoid/Cons.hs b/src/Fresnel/Monoid/Cons.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Monoid/Cons.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE RankNTypes #-} +module Fresnel.Monoid.Cons +( -- * Cons lists + Cons(..) + -- * Construction +, singleton +, cons +, nil +) where + +import Data.Foldable (toList) + +-- Cons lists + +newtype Cons a = Cons { runCons :: forall r . (a -> r -> r) -> r -> r } + +instance Show a => Show (Cons a) where + showsPrec _ = showList . toList + +instance Semigroup (Cons a) where + Cons a1 <> Cons a2 = Cons (\ cons -> a1 cons . a2 cons) + +instance Monoid (Cons a) where + mempty = nil + +instance Foldable Cons where + foldMap f (Cons r) = r (mappend . f) mempty + foldr f z (Cons r) = r f z + +instance Functor Cons where + fmap f (Cons r) = r (cons . f) nil + + +-- Construction + +singleton :: a -> Cons a +singleton a = Cons (\ cons nil -> cons a nil) + +cons :: a -> Cons a -> Cons a +cons a (Cons as) = Cons (\ cons -> cons a . as cons) + +nil :: Cons a +nil = Cons (\ _ nil -> nil) diff --git a/src/Fresnel/Monoid/Fork.hs b/src/Fresnel/Monoid/Fork.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Monoid/Fork.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE RankNTypes #-} +module Fresnel.Monoid.Fork +( -- * Binary trees + Fork(..) + -- * Construction +, singleton +) where + +import Control.Applicative (Alternative(..)) +import Data.Foldable (toList) + +-- Binary trees + +newtype Fork a = Fork { runFork :: forall r . (r -> r -> r) -> (a -> r) -> r -> r } + +instance Show a => Show (Fork a) where + showsPrec _ = showList . toList + +instance Semigroup (Fork a) where + Fork a1 <> Fork a2 = Fork (\ fork leaf nil -> a1 fork leaf nil `fork` a2 fork leaf nil) + +instance Monoid (Fork a) where + mempty = Fork (\ _ _ nil -> nil) + +instance Foldable Fork where + foldMap f (Fork r) = r (<>) f mempty + +instance Functor Fork where + fmap f (Fork r) = Fork (\ fork leaf -> r fork (leaf . f)) + +instance Applicative Fork where + pure a = Fork (\ _ leaf _ -> leaf a) + Fork f <*> Fork a = Fork (\ fork leaf nil -> f fork (\ f' -> a fork (leaf . f') nil) nil) + +instance Alternative Fork where + empty = mempty + (<|>) = (<>) + + +-- Construction + +singleton :: a -> Fork a +singleton a = Fork (\ _ leaf _ -> leaf a) diff --git a/src/Fresnel/Monoid/Snoc.hs b/src/Fresnel/Monoid/Snoc.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Monoid/Snoc.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE RankNTypes #-} +module Fresnel.Monoid.Snoc +( -- * Snoc lists + Snoc(..) + -- * Construction +, singleton +, snoc +, nil +) where + +import Data.Foldable (toList) + +-- Snoc lists + +newtype Snoc a = Snoc { runSnoc :: forall r . (r -> a -> r) -> r -> r } + +instance Show a => Show (Snoc a) where + showsPrec _ = showList . toList + +instance Semigroup (Snoc a) where + Snoc a1 <> Snoc a2 = Snoc (\ snoc -> a1 snoc . a2 snoc) + +instance Monoid (Snoc a) where + mempty = nil + +instance Foldable Snoc where + foldMap f (Snoc r) = r (const <> const f) mempty + +instance Functor Snoc where + fmap f (Snoc r) = r ((. f) . snoc) nil + + +-- Construction + +singleton :: a -> Snoc a +singleton a = Snoc (\ snoc nil -> snoc nil a) + +snoc :: Snoc a -> a -> Snoc a +snoc (Snoc as) a = Snoc (\ snoc nil -> snoc (as snoc nil) a) + +nil :: Snoc a +nil = Snoc (\ _ nil -> nil) diff --git a/src/Fresnel/Optic.hs b/src/Fresnel/Optic.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Optic.hs @@ -0,0 +1,12 @@ +-- | Type synonyms for defining types of optics. +module Fresnel.Optic +( -- * Optics + Optic +, Optic' +) where + +-- Optics + +type Optic p s t a b = p a b -> p s t + +type Optic' p s a = Optic p s s a a diff --git a/src/Fresnel/Optional.hs b/src/Fresnel/Optional.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Optional.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +module Fresnel.Optional +( -- * Optionals + Optional +, Optional' +, IsOptional + -- * Construction +, optional +, optional' + -- * Elimination +, matching +, matching' +, withOptional +, traverseOf +, is +, isn't + -- * Unpacked +, UnpackedOptional(..) +, unpackedOptional +) where + +import Data.Bifunctor +import Data.Maybe (isJust, isNothing) +import Data.Profunctor +import Fresnel.Iso.Internal (IsIso) +import Fresnel.Lens.Internal (IsLens) +import Fresnel.Optic +import Fresnel.Optional.Internal (IsOptional) +import Fresnel.Prism.Internal (IsPrism) +import Fresnel.Profunctor.OptionalStar + +-- Optional traversals + +type Optional s t a b = forall p . IsOptional p => Optic p s t a b + +type Optional' s a = Optional s s a a + + +-- Construction + +optional :: (s -> Either t a) -> (s -> b -> t) -> Optional s t a b +optional prj set = dimap + (\ s -> (prj s, set s)) + (\ (e, f) -> either id f e) + . first' . right' + +optional' :: (s -> Maybe a) -> (s -> b -> s) -> Optional s s a b +optional' prj = optional (\ s -> maybe (Left s) Right (prj s)) + + +-- Elimination + +matching :: Optional s t a b -> (s -> Either t a) +matching o = withOptional o const + +matching' :: Optional s t a b -> (s -> Maybe a) +matching' o = withOptional o (\ prj _ -> either (const Nothing) Just . prj) + +withOptional :: Optional s t a b -> (((s -> Either t a) -> (s -> b -> t) -> r) -> r) +withOptional o = withUnpackedOptional (o (unpackedOptional Right (const id))) + +traverseOf :: Functor f => Optional s t a b -> (forall r . r -> f r) -> (a -> f b) -> (s -> f t) +traverseOf o point = runOptionalStar . o . optionalStar point + +is :: Optional s t a b -> (s -> Bool) +is o = isJust . matching' o + +isn't :: Optional s t a b -> (s -> Bool) +isn't o = isNothing . matching' o + + +-- Unpacked + +newtype UnpackedOptional a b s t = UnpackedOptional { withUnpackedOptional :: forall r . ((s -> Either t a) -> (s -> b -> t) -> r) -> r } + +instance Profunctor (UnpackedOptional a b) where + dimap f g (UnpackedOptional r) = r $ \ prj set -> unpackedOptional (either (Left . g) Right . prj . f) (rmap g . set . f) + +instance Strong (UnpackedOptional a b) where + first' (UnpackedOptional r) = r $ \ prj set -> unpackedOptional (\ (a, c) -> first (,c) (prj a)) (\ (a, c) b -> (set a b, c)) + second' (UnpackedOptional r) = r $ \ prj set -> unpackedOptional (\ (c, a) -> first (c,) (prj a)) (\ (c, a) b -> (c, set a b)) + +instance Choice (UnpackedOptional a b) where + left' (UnpackedOptional r) = r $ \ prj set -> unpackedOptional (either (either (Left . Left) Right . prj) (Left . Right)) (\ e b -> first (`set` b) e) + right' (UnpackedOptional r) = r $ \ prj set -> unpackedOptional (either (Left . Left) (either (Left . Right) Right . prj)) (\ e b -> fmap (`set` b) e) + +instance IsIso (UnpackedOptional a b) +instance IsLens (UnpackedOptional a b) +instance IsPrism (UnpackedOptional a b) +instance IsOptional (UnpackedOptional a b) + + +unpackedOptional :: (s -> Either t a) -> (s -> b -> t) -> UnpackedOptional a b s t +unpackedOptional prj set = UnpackedOptional (\ k -> k prj set) diff --git a/src/Fresnel/Optional/Internal.hs b/src/Fresnel/Optional/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Optional/Internal.hs @@ -0,0 +1,17 @@ +module Fresnel.Optional.Internal +( IsOptional +) where + +import Control.Arrow (Kleisli) +import Data.Profunctor (Forget, Star) +import Fresnel.Lens.Internal (IsLens) +import Fresnel.Prism.Internal (IsPrism) +import Fresnel.Profunctor.OptionalStar (OptionalStar) + +class (IsLens p, IsPrism p) => IsOptional p where + +instance IsOptional (->) +instance Monad m => IsOptional (Kleisli m) +instance Monoid r => IsOptional (Forget r) +instance Applicative f => IsOptional (Star f) +instance Functor f => IsOptional (OptionalStar f) diff --git a/src/Fresnel/OptionalFold.hs b/src/Fresnel/OptionalFold.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/OptionalFold.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE RankNTypes #-} +module Fresnel.OptionalFold +( -- * Optional folds + OptionalFold +, IsOptionalFold + -- * Construction +, folding +, filtered + -- * Elimination +, is +, isn't +, traverseOf_ +, Failover(..) +) where + +import Control.Applicative ((<|>)) +import Data.Functor (void) +import Data.Maybe (isJust, isNothing) +import Data.Profunctor +import Fresnel.Bifunctor.Contravariant +import Fresnel.Fold (preview) +import Fresnel.Optic +import Fresnel.OptionalFold.Internal + +-- Optional folds + +type OptionalFold s a = forall p . IsOptionalFold p => Optic' p s a + + +-- Construction + +folding :: (s -> Maybe a) -> OptionalFold s a +folding f = contrabimap ((`maybe` Right) . Left <*> f) Left . right' + +filtered :: (a -> Bool) -> OptionalFold a a +filtered p = folding (\ a -> if p a then Just a else Nothing) + + +-- Elimination + +is :: OptionalFold s a -> (s -> Bool) +is o = isNothing . preview o + +isn't :: OptionalFold s a -> (s -> Bool) +isn't o = isJust . preview o + +traverseOf_ :: Functor f => OptionalFold s a -> ((forall x . x -> f x) -> (a -> f u) -> (s -> f ())) +traverseOf_ o point f s = maybe (point ()) (void . f) (preview o s) + + +newtype Failover s a = Failover { getFailover :: OptionalFold s a } + +instance Semigroup (Failover s a) where + Failover a1 <> Failover a2 = Failover (folding (\ s -> preview a1 s <|> preview a2 s)) diff --git a/src/Fresnel/OptionalFold/Internal.hs b/src/Fresnel/OptionalFold/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/OptionalFold/Internal.hs @@ -0,0 +1,15 @@ +module Fresnel.OptionalFold.Internal +( IsOptionalFold +) where + +import Data.Functor.Contravariant +import Data.Profunctor +import Fresnel.Getter.Internal (IsGetter) +import Fresnel.Optional.Internal (IsOptional) +import Fresnel.Profunctor.OptionalStar (OptionalStar) + +class (IsOptional p, IsGetter p) => IsOptionalFold p + +instance Monoid r => IsOptionalFold (Forget r) +instance (Applicative f, Traversable f, Contravariant f) => IsOptionalFold (Star f) +instance (Traversable f, Contravariant f) => IsOptionalFold (OptionalStar f) diff --git a/src/Fresnel/Prism.hs b/src/Fresnel/Prism.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Prism.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +module Fresnel.Prism +( -- * Prisms + Prism +, Prism' +, IsPrism + -- * Construction +, prism +, prism' + -- * Elimination +, withPrism +, matching +, matching' +, is +, isn't + -- * Relations +, only +, nearly + -- * Combinators +, without +, below +, aside + -- * Unpacked +, UnpackedPrism(..) +, unpackedPrism +) where + +import Control.Monad (guard) +import Data.Bifunctor (Bifunctor(..)) +import Data.Profunctor +import Fresnel.Iso.Internal (IsIso) +import Fresnel.Optic +import Fresnel.Optional (is, isn't, matching, matching') +import Fresnel.Prism.Internal (IsPrism) + +-- Prisms + +type Prism s t a b = forall p . IsPrism p => Optic p s t a b + +type Prism' s a = Prism s s a a + + +-- Construction + +prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b +prism inj prj = dimap prj (either id inj) . right' + +prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b +prism' inj prj = prism inj (\ s -> maybe (Left s) Right (prj s)) + + +-- Elimination + +withPrism :: Prism s t a b -> (((b -> t) -> (s -> Either t a) -> r) -> r) +withPrism o = withUnpackedPrism (o (unpackedPrism id Right)) + + +-- Relations + +only :: Eq a => a -> Prism' a () +only a = nearly a (a ==) + +nearly :: a -> (a -> Bool) -> Prism' a () +nearly a p = prism' (const a) (guard . p) + + +-- Combinators + +without :: Prism s1 t1 a1 b1 -> Prism s2 t2 a2 b2 -> Prism (Either s1 s2) (Either t1 t2) (Either a1 a2) (Either b1 b2) +without o1 o2 = withPrism o1 $ \ inj1 prj1 -> withPrism o2 $ \ inj2 prj2 -> + prism (bimap inj1 inj2) (either (bimap Left Left . prj1) (bimap Right Right . prj2)) + +below :: Traversable f => Prism' s a -> Prism' (f s) (f a) +below o = withPrism o $ \ inj prj -> prism (fmap inj) $ \ s -> first (const s) (traverse prj s) + +aside :: Prism s t a b -> Prism (e, s) (e, t) (e, a) (e, b) +aside o = withPrism o $ \ inj prj -> prism (fmap inj) $ \ (e, s) -> bimap (e,) (e,) (prj s) + + +-- Unpacked + +newtype UnpackedPrism a b s t = UnpackedPrism { withUnpackedPrism :: forall r . ((b -> t) -> (s -> Either t a) -> r) -> r } + +instance Functor (UnpackedPrism a b s) where + fmap = rmap + +instance Profunctor (UnpackedPrism a b) where + dimap f g (UnpackedPrism r) = r $ \ inj prj -> unpackedPrism (g . inj) (either (Left . g) Right . prj . f) + +instance Choice (UnpackedPrism a b) where + left' (UnpackedPrism r) = r $ \ inj prj -> unpackedPrism (Left . inj) (either (either (Left . Left) Right . prj) (Left . Right)) + +instance IsIso (UnpackedPrism a b) +instance IsPrism (UnpackedPrism a b) + + +unpackedPrism :: (b -> t) -> (s -> Either t a) -> UnpackedPrism a b s t +unpackedPrism inj prj = UnpackedPrism (\ k -> k inj prj) diff --git a/src/Fresnel/Prism/Internal.hs b/src/Fresnel/Prism/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Prism/Internal.hs @@ -0,0 +1,18 @@ +module Fresnel.Prism.Internal +( IsPrism +) where + +import Control.Arrow (Kleisli) +import Data.Profunctor (Choice, Forget, Star) +import Fresnel.Iso.Internal +import Fresnel.Profunctor.OptionalStar (OptionalStar) +import Fresnel.Profunctor.Recall (Recall) + +class (IsIso p, Choice p) => IsPrism p + +instance IsPrism (->) +instance Monad m => IsPrism (Kleisli m) +instance Monoid r => IsPrism (Forget r) +instance IsPrism (Recall e) +instance Applicative f => IsPrism (Star f) +instance Functor f => IsPrism (OptionalStar f) diff --git a/src/Fresnel/Profunctor/Coexp.hs b/src/Fresnel/Profunctor/Coexp.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Profunctor/Coexp.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +module Fresnel.Profunctor.Coexp +( -- * Coexponential profunctor + Coexp(..) + -- * Construction +, coexp + -- * Elimination +, recall +, forget +) where + +import Data.Profunctor +import Data.Profunctor.Unsafe +import Data.Coerce + +-- Coexponential + +-- | Coexponentials are the dual of functions, consisting of an argument of type @a@ (derived within an environment of type @s@) and a continuation from the return type @b@ (extending to the eventual result type @t@). As such, they naturally have the shape of optics, relating the outer context @s -> t@ to the inner @a -> b@. +newtype Coexp s t b a = Coexp { withCoexp :: forall r . ((s -> a) -> (b -> t) -> r) -> r } + +instance Functor (Coexp s t b) where + fmap = rmap + +instance Monoid t => Applicative (Coexp s t b) where + pure a = coexp (pure a) mempty + f <*> a = withCoexp f $ \ f kf -> withCoexp a $ \ a ka -> coexp (f <*> a) (mappend <$> kf <*> ka) + +instance Profunctor (Coexp s t) where + dimap f g c = withCoexp c $ \ recall forget -> coexp (g . recall) (forget . f) + lmap f c = withCoexp c $ \ recall forget -> coexp recall (forget . f) + rmap g c = withCoexp c $ \ recall forget -> coexp (g . recall) forget + (#.) = const coerce + (.#) = fmap coerce . const + +instance Semigroup (Coexp a b b a) where + c1 <> c2 = withCoexp c1 $ \ r1 f1 -> withCoexp c2 $ \ r2 f2 -> coexp (r2 . r1) (f1 . f2) + +instance Monoid (Coexp a b b a) where + mempty = coexp id id + + +-- Construction + +coexp :: (s -> a) -> (b -> t) -> Coexp s t b a +coexp recall forget = Coexp (\ k -> k recall forget) + + +-- Elimination + +recall :: Coexp s t b a -> (s -> a) +recall c = withCoexp c const + +forget :: Coexp s t b a -> (b -> t) +forget c = withCoexp c (const id) diff --git a/src/Fresnel/Profunctor/OptionalStar.hs b/src/Fresnel/Profunctor/OptionalStar.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Profunctor/OptionalStar.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +module Fresnel.Profunctor.OptionalStar +( -- * Optional star profunctors + OptionalStar(..) + -- * Construction +, optionalStar + -- * Elimination +, runOptionalStar + -- * Computation +, mapOptionalStar +) where + +import Data.Coerce +import Data.Functor.Contravariant +import Data.Profunctor +import Data.Profunctor.Unsafe +import Fresnel.Bifunctor.Contravariant + +-- Optional star profunctors + +newtype OptionalStar f a b = OptionalStar { withOptionalStar :: forall r . ((forall x . x -> f x) -> (a -> f b) -> r) -> r } + +instance Functor f => Profunctor (OptionalStar f) where + dimap f g = mapOptionalStar (dimap f (fmap g)) + lmap f = mapOptionalStar (lmap f) + rmap g = mapOptionalStar (rmap (fmap g)) + (.#) = fmap coerce . const + +instance Functor f => Choice (OptionalStar f) where + left' (OptionalStar r) = OptionalStar (\ k -> r (\ point f -> k point (either (fmap Left . f) (fmap Right . point)))) + right' (OptionalStar r) = OptionalStar (\ k -> r (\ point f -> k point (either (fmap Left . point) (fmap Right . f)))) + +instance Traversable f => Cochoice (OptionalStar f) where + unright r = withOptionalStar r $ \ point f -> let go = either (go . Left) id . sequenceA . f in optionalStar point (go . Right) + +instance Functor f => Strong (OptionalStar f) where + first' = mapOptionalStar (\ f (a, c) -> (,c) <$> f a) + second' = mapOptionalStar (\ f (c, a) -> (c,) <$> f a) + +instance Contravariant f => Bicontravariant (OptionalStar f) where + contrabimap f g = mapOptionalStar (\ h -> contramap g . h . f) + + +-- Construction + +optionalStar :: (forall x . x -> f x) -> (a -> f b) -> OptionalStar f a b +optionalStar point f = OptionalStar (\ k -> k point f) + + +-- Elimination + +runOptionalStar :: OptionalStar f a b -> (a -> f b) +runOptionalStar a = withOptionalStar a (\ _ f -> f) + + +-- Computation + +mapOptionalStar :: ((a -> f b) -> (c -> f d)) -> (OptionalStar f a b -> OptionalStar f c d) +mapOptionalStar f (OptionalStar r) = OptionalStar (\ k -> r (\ point -> k point . f)) diff --git a/src/Fresnel/Profunctor/Recall.hs b/src/Fresnel/Profunctor/Recall.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Profunctor/Recall.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module Fresnel.Profunctor.Recall +( -- * Recall profunctor + Recall(..) +) where + +import Data.Bifunctor +import Data.Coerce +import Data.Functor.Const +import Data.Profunctor +import Data.Profunctor.Rep as Pro +import Data.Profunctor.Sieve +import Data.Profunctor.Unsafe + +-- Recall profunctor + +-- | @'Recall' e@ is dual to @'Forget' r@: it ignores the argument parameter, substituting in one of its own. +newtype Recall e a b = Recall { runRecall :: e -> b } + deriving (Applicative, Functor, Monad, Monoid, Semigroup) + +instance Bifunctor (Recall e) where + bimap _ g = Recall . fmap g . runRecall + second = fmap + +instance Profunctor (Recall e) where + dimap _ g = Recall . fmap g . runRecall + lmap = const coerce + rmap = fmap + (#.) = const coerce + (.#) = fmap coerce . const + +instance Choice (Recall e) where + left' = Recall . fmap Left . runRecall + right' = Recall . fmap Right . runRecall + +instance Closed (Recall e) where + closed = Recall . fmap const . runRecall + +instance Costrong (Recall e) where + unfirst = Recall . fmap fst . runRecall + unsecond = Recall . fmap snd . runRecall + +instance Sieve (Recall e) ((->) e) where + sieve = const . runRecall + +instance Cosieve (Recall e) (Const e) where + cosieve = lmap getConst . runRecall + +instance Pro.Corepresentable (Recall e) where + type Corep (Recall e) = Const e + + cotabulate = Recall . lmap Const diff --git a/src/Fresnel/Review.hs b/src/Fresnel/Review.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Review.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE RankNTypes #-} +module Fresnel.Review +( -- * Reviews + Review +, IsReview + -- * Construction +, unto +, reviewing +, un + -- * Elimination +, reviews +, review +, (#) +, re + -- * Utilities +, lphantom +) where + +import Data.Bifunctor +import Data.Profunctor +import Data.Profunctor.Unsafe ((#.), (.#)) +import Data.Void +import Fresnel.Getter (Getter, to, view) +import Fresnel.Optic +import Fresnel.Prism.Internal (IsPrism) +import Fresnel.Profunctor.Recall + +-- Reviews + +type Review t b = forall p . IsReview p => Optic' p t b + +class (IsPrism p, Bifunctor p, Costrong p) => IsReview p + +instance IsReview (Recall e) + + +-- Construction + +unto :: (b -> t) -> Review t b +unto f = lphantom . rmap f + + +reviewing :: (Profunctor p, Bifunctor p) => Optic p s t a b -> Optic' p t b +reviewing l f = lphantom . l $ lphantom f + + +un :: Getter s a -> Review a s +un o = unto (view o) + + +-- Elimination + +reviews :: Review t b -> (e -> b) -> (e -> t) +reviews b = runRecall #. b .# Recall + +review :: Review t b -> (b -> t) +review b = reviews b id + +(#) :: Review t b -> (b -> t) +(#) = review + +infixr 8 # + + +re :: Review t b -> Getter b t +re o = to (review o) + + +-- Utilities + +lphantom :: (Bifunctor p, Profunctor p) => p b c -> p a c +lphantom = first absurd . lmap absurd diff --git a/src/Fresnel/Set.hs b/src/Fresnel/Set.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Set.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE RankNTypes #-} +module Fresnel.Set +( setmapped +, setOf +) where + +import Data.Set as Set +import Fresnel.Fold +import Fresnel.Setter + +setmapped :: Ord b => Setter (Set a) (Set b) a b +setmapped = sets Set.map + +setOf :: Ord a => Fold s a -> (s -> Set.Set a) +setOf o = Set.fromList . toListOf o diff --git a/src/Fresnel/Setter.hs b/src/Fresnel/Setter.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Setter.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE RankNTypes #-} +module Fresnel.Setter +( -- * Setters + Setter +, Setter' +, IsSetter + -- * Construction +, sets +, mapped +, contramapped + -- * Elimination +, over +, (%~) +, set +, (.~) +, (+~) +, (-~) +, (*~) +, (/~) +, (^~) +, (^^~) +, (**~) +) where + +import Data.Functor.Contravariant +import Data.Profunctor.Mapping +import Fresnel.Optic +import Fresnel.Traversal.Internal (IsTraversal) + +-- Setters + +type Setter s t a b = forall p . IsSetter p => Optic p s t a b + +type Setter' s a = Setter s s a a + +class (IsTraversal p, Mapping p) => IsSetter p + +instance IsSetter (->) + + +-- Construction + +sets :: ((a -> b) -> (s -> t)) -> Setter s t a b +sets f = (f `roam`) -- written thus to placate hlint + + +mapped :: Functor f => Setter (f a) (f b) a b +mapped = sets fmap + +contramapped :: Contravariant f => Setter (f a) (f b) b a +contramapped = sets contramap + + +-- Elimination + +over, (%~) :: Setter s t a b -> (a -> b) -> (s -> t) +over o = o + +(%~) = over + +infixr 4 %~ + + +set, (.~) :: Setter s t a b -> b -> s -> t +set o = over o . const + +(.~) = set + +infixr 4 .~ + + +(+~), (-~), (*~) :: Num a => Setter s t a a -> a -> s -> t +o +~ a = over o (+ a) +o -~ a = over o (subtract a) +o *~ a = over o (* a) + +infixr 4 +~, -~, *~ + +(/~) :: Fractional a => Setter s t a a -> a -> s -> t +o /~ a = over o (/ a) + +infixr 4 /~ + +(^~) :: (Num a, Integral b) => Setter s t a a -> b -> s -> t +o ^~ a = over o (^ a) + +infixr 4 ^~ + +(^^~) :: (Fractional a, Integral b) => Setter s t a a -> b -> s -> t +o ^^~ a = over o (^^ a) + +infixr 4 ^^~ + +(**~) :: Floating a => Setter s t a a -> a -> s -> t +o **~ a = over o (** a) + +infixr 4 **~ diff --git a/src/Fresnel/Traversal.hs b/src/Fresnel/Traversal.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Traversal.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE RankNTypes #-} +module Fresnel.Traversal +( -- * Traversals + Traversal +, Traversal' +, IsTraversal + -- * Construction +, traversed +, backwards + -- * Elimination +, traverseOf +, forOf +, sequenceOf +, transposeOf +, mapAccumLOf +, mapAccumROf +, scanl1Of +, scanr1Of +) where + +import Control.Applicative (ZipList(..)) +import Control.Monad.Trans.State +import Data.Profunctor +import Data.Profunctor.Traversing (Traversing(..)) +import Data.Profunctor.Unsafe ((#.)) +import Fresnel.Functor.Backwards +import Fresnel.Optic +import Fresnel.Traversal.Internal (IsTraversal) + +-- Traversals + +type Traversal s t a b = forall p . IsTraversal p => Optic p s t a b + +type Traversal' s a = Traversal s s a a + + +-- Construction + +traversed :: Traversable t => Traversal (t a) (t b) a b +traversed = wander traverse + +backwards :: Traversal s t a b -> Traversal s t a b +backwards o = wander (\ f -> forwards . traverseOf o (Backwards . f)) + + +-- Elimination + +traverseOf :: Applicative f => Traversal s t a b -> ((a -> f b) -> (s -> f t)) +traverseOf o = runStar . o . Star + +forOf :: Applicative f => Traversal s t a b -> (s -> (a -> f b) -> f t) +forOf o = flip (traverseOf o) + +sequenceOf :: Applicative f => Traversal s t (f b) b -> (s -> f t) +sequenceOf o = traverseOf o id + +transposeOf :: Traversal s t [a] a -> s -> [t] +transposeOf o = getZipList #. traverseOf o ZipList + +mapAccumLOf :: Traversal s t a b -> (accum -> a -> (b, accum)) -> accum -> s -> (t, accum) +mapAccumLOf o f z s = + let g a = state $ \ accum -> f accum a + in runState (traverseOf o g s) z + +mapAccumROf :: Traversal s t a b -> (accum -> a -> (b, accum)) -> accum -> s -> (t, accum) +mapAccumROf o = mapAccumLOf (backwards o) + +scanl1Of :: Traversal s t a a -> (a -> a -> a) -> s -> t +scanl1Of o f = + let step Nothing a = (a, Just a) + step (Just s) a = let r = f s a in (r, Just r) + in fst . mapAccumLOf o step Nothing + +scanr1Of :: Traversal s t a a -> (a -> a -> a) -> s -> t +scanr1Of o f = + let step Nothing a = (a, Just a) + step (Just s) a = let r = f s a in (r, Just r) + in fst . mapAccumROf o step Nothing diff --git a/src/Fresnel/Traversal/Internal.hs b/src/Fresnel/Traversal/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Traversal/Internal.hs @@ -0,0 +1,15 @@ +module Fresnel.Traversal.Internal +( IsTraversal +) where + +import Control.Arrow (Kleisli) +import Data.Profunctor (Forget, Star) +import Data.Profunctor.Traversing (Traversing) +import Fresnel.Optional.Internal (IsOptional) + +class (IsOptional p, Traversing p) => IsTraversal p + +instance IsTraversal (->) +instance Monad m => IsTraversal (Kleisli m) +instance Monoid r => IsTraversal (Forget r) +instance Applicative f => IsTraversal (Star f) diff --git a/src/Fresnel/Tuple.hs b/src/Fresnel/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Fresnel/Tuple.hs @@ -0,0 +1,15 @@ +module Fresnel.Tuple +( -- * Lenses + fst_ +, snd_ +) where + +import Fresnel.Lens + +-- Lenses + +fst_ :: Lens (a, b) (a', b) a a' +fst_ = lens fst (\ s a' -> (a', snd s)) + +snd_ :: Lens (a, b) (a, b') b b' +snd_ = lens snd (\ s b' -> (fst s, b')) diff --git a/test/Fold/Test.hs b/test/Fold/Test.hs new file mode 100644 --- /dev/null +++ b/test/Fold/Test.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +module Fold.Test +( tests +) where + +import Fresnel.Fold +import Fresnel.Ixed +import Test.Group +import Test.QuickCheck + +prop_union_semigroup_assoc :: (Eq a, Show a) => ArbFold a -> ArbFold a -> ArbFold a -> [a] -> Property +prop_union_semigroup_assoc (ArbFold a) (ArbFold b) (ArbFold c) as = classifyList as $ toListOf (getUnion (Union a <> (Union b <> Union c))) as === toListOf (getUnion ((Union a <> Union b) <> Union c)) as + +prop_union_monoid_identity :: (Eq a, Show a) => ArbFold a -> [a] -> Property +prop_union_monoid_identity (ArbFold a) as = + classifyList as $ + toListOf (getUnion (mempty <> Union a)) as === toListOf a as .&&. toListOf (getUnion (Union a <> mempty)) as === toListOf a as + + +prop_failover_semigroup_assoc :: (Eq a, Show a) => ArbFold a -> ArbFold a -> ArbFold a -> [a] -> Property +prop_failover_semigroup_assoc (ArbFold a) (ArbFold b) (ArbFold c) as = classifyList as $ toListOf (getFailover (Failover a <> (Failover b <> Failover c))) as === toListOf (getFailover ((Failover a <> Failover b) <> Failover c)) as + +prop_failover_monoid_identity :: (Eq a, Show a) => ArbFold a -> [a] -> Property +prop_failover_monoid_identity (ArbFold a) as = classifyList as $ toListOf (getFailover (mempty <> Failover a)) as === toListOf a as .&&. toListOf (getFailover (Failover a <> mempty)) as === toListOf a as + + +classifyList :: Testable prop => [a] -> prop -> Property +classifyList as = classify (null as) "empty" . classify (length as == 1) "singleton" + + +newtype ArbFold a = ArbFold (Fold [a] a) + +instance Show a => Show (ArbFold a) where + showsPrec _ (ArbFold fold) = showList (toListOf fold []) -- FIXME: this is a bad instance + +instance Arbitrary a => Arbitrary (ArbFold a) where + arbitrary = oneof + [ pure (ArbFold folded) + , pure (ArbFold ignored) + , ixed <$> arbitrary + ] + where + ixed :: Int -> ArbFold a + ixed i = ArbFold (ix i) + + +pure [] + +tests :: Entry +tests = $deriveGroup diff --git a/test/Fresnel/Tropical.hs b/test/Fresnel/Tropical.hs new file mode 100644 --- /dev/null +++ b/test/Fresnel/Tropical.hs @@ -0,0 +1,16 @@ +module Fresnel.Tropical +( finite +, Tropical(..) +) where + +finite :: a -> Tropical a +finite = Tropical . Just + +newtype Tropical a = Tropical { getTropical :: Maybe a } + deriving (Eq, Ord, Show) + +instance Ord a => Semigroup (Tropical a) where + (<>) = max + +instance Ord a => Monoid (Tropical a) where + mempty = Tropical Nothing diff --git a/test/Getter/Test.hs b/test/Getter/Test.hs new file mode 100644 --- /dev/null +++ b/test/Getter/Test.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell #-} +module Getter.Test +( tests +) where + +import Fresnel.Getter +import Test.Group +import Test.QuickCheck + +prop_view_to_involution f x = view (to (applyFun f)) x === applyFun f x + + +pure [] + +tests :: Entry +tests = $deriveGroup diff --git a/test/Iso/Test.hs b/test/Iso/Test.hs new file mode 100644 --- /dev/null +++ b/test/Iso/Test.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +module Iso.Test +( validIso +, invalidIso +, withRoundtrips +, tests +) where + +import Fresnel.Getter +import Fresnel.Iso +import Fresnel.Review +import Test.Group +import Test.QuickCheck + +validIso :: (Eq a, Show a, Eq s, Show s) => Iso' s a -> s -> a -> Property +validIso o s a = withRoundtrips o $ \ ss aa -> ss s === s .&&. aa a === a + +invalidIso :: (Eq a, Show a, Eq s, Show s) => Iso' s a -> s -> a -> Property +invalidIso o s a = withRoundtrips o $ \ ss aa -> ss s =/= s .||. aa a =/= a + +withRoundtrips :: Iso' s a -> (((s -> s) -> (a -> a) -> r) -> r) +withRoundtrips o k = withIso o (\ f g -> k (g . f) (f . g)) + + +prop_view_elimination f g x = view (iso (applyFun f) (applyFun g)) x === applyFun f x + +prop_review_elimination f g x = review (iso (applyFun f) (applyFun g)) x === applyFun g x + + +prop_constant_validity c s a = withRoundtrips (constant c) $ \ sasa aa -> + sasa (const a) s === const a s .&&. aa a === a + + +prop_involuted_validity = validIso (involuted not) + +prop_involuted_invalidity = invalidIso (involuted (+ (1 :: Integer))) + + +pure [] + +tests :: Entry +tests = $deriveGroup diff --git a/test/Monoid/Fork/Test.hs b/test/Monoid/Fork/Test.hs new file mode 100644 --- /dev/null +++ b/test/Monoid/Fork/Test.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE TemplateHaskell #-} +module Monoid.Fork.Test +( tests +) where + +import Data.Foldable (toList) +import Data.Ratio +import Fresnel.Monoid.Fork (Fork(runFork), singleton) +import Test.Group +import Test.QuickCheck hiding (total) + +prop_semigroup_assoc :: (Eq a, Show a) => ArbFork a -> ArbFork a -> ArbFork a -> Property +prop_semigroup_assoc (ArbFork a) (ArbFork b) (ArbFork c) = + label (summarize a) . label (summarize b) . label (summarize c) $ + (toList (a <> (b <> c)) === toList ((a <> b) <> c)) + +prop_monoid_identity :: (Eq a, Show a) => ArbFork a -> Property +prop_monoid_identity (ArbFork a) = label (summarize a) $ toList (mempty <> a) === toList a .&&. toList (a <> mempty) === toList a + + +newtype ArbFork a = ArbFork (Fork a) + deriving (Show) + +instance Arbitrary a => Arbitrary (ArbFork a) where + arbitrary = ArbFork <$> sized go where + go 0 = pure mempty + go i = oneof + [ chooseInt (0, i) >>= \ j -> (<>) <$> go (i - j) <*> go j + , singleton <$> arbitrary + , pure mempty + ] + + +summarize :: Fork a -> String +summarize r + | total' == nils = "nil" + | ratio nils > 0.4 = "nil-heavy" + | total' == leaves = "leaf" + | ratio leaves > 0.4 = "leaf-heavy" + | ratio forks > 0.4 = "fork-heavy" + | otherwise = "fork" + where + (total', Counts forks leaves nils) = (,) . total <*> id $ runFork r (\ l r -> fork <> l <> r) (const leaf) nil + ratio a = realToFrac (a % total') :: Double + +data Counts = Counts + { forks :: {-# UNPACK #-} !Int + , leaves :: {-# UNPACK #-} !Int + , nils :: {-# UNPACK #-} !Int + } + +instance Semigroup Counts where + c1 <> c2 = Counts (forks c1 + forks c2) (leaves c1 + leaves c2) (nils c1 + nils c2) + +fork :: Counts +fork = Counts 1 0 0 + +leaf :: Counts +leaf = Counts 0 1 0 + +nil :: Counts +nil = Counts 0 0 1 + +total :: Counts -> Int +total (Counts f l n) = f + l + n + + +pure [] + +tests :: Entry +tests = $deriveGroup diff --git a/test/Profunctor/Coexp/Test.hs b/test/Profunctor/Coexp/Test.hs new file mode 100644 --- /dev/null +++ b/test/Profunctor/Coexp/Test.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TemplateHaskell #-} +module Profunctor.Coexp.Test +( tests +) where + +import Fresnel.Profunctor.Coexp +import Test.Group +import Test.QuickCheck + +prop_semigroup_assoc :: (Eq b, Eq a, Show b, Show a) => ArbCoexp b a a b -> ArbCoexp b a a b -> ArbCoexp b a a b -> b -> a -> Property +prop_semigroup_assoc a b c x y = + appCoexp (toCoexp a <> (toCoexp b <> toCoexp c)) x y === appCoexp ((toCoexp a <> toCoexp b) <> toCoexp c) x y + +prop_monoid_identity :: (Eq b, Show b) => ArbCoexp b a a b -> b -> Property +prop_monoid_identity a x = recall (mempty <> toCoexp a) x === recall (toCoexp a) x .&&. recall (toCoexp a <> mempty) x === recall (toCoexp a) x + + +data ArbCoexp e r a b = ArbCoexp (Fun e b) (Fun a r) + deriving (Show) + +instance (Function e, Function a, CoArbitrary e, CoArbitrary a, Arbitrary b, Arbitrary r) => Arbitrary (ArbCoexp e r a b) where + arbitrary = ArbCoexp <$> arbitrary <*> arbitrary + +toCoexp :: ArbCoexp e r a b -> Coexp e r a b +toCoexp (ArbCoexp eb ar) = coexp (applyFun eb) (applyFun ar) + +appCoexp :: Coexp e r a b -> e -> a -> (b, r) +appCoexp c e a = withCoexp c $ \ recall forget -> (recall e, forget a) + + +pure [] + +tests :: Entry +tests = $deriveGroup diff --git a/test/Review/Test.hs b/test/Review/Test.hs new file mode 100644 --- /dev/null +++ b/test/Review/Test.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +module Review.Test +( tests +) where +import Fresnel.Review +import Test.Group +import Test.QuickCheck + +prop_review_unto_involution f x = review (unto (applyFun f)) x === applyFun f x + + +pure [] + +tests :: Entry +tests = $deriveGroup diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +module Main +( main +) where + +import qualified Fold.Test +import qualified Getter.Test +import qualified Iso.Test +import qualified Monoid.Fork.Test +import qualified Profunctor.Coexp.Test +import qualified Review.Test +import System.Environment (getArgs) +import Test.Group +import Test.Options +import Test.Run +import qualified Tropical.Test + +main :: IO () +main = getArgs >>= withOptions defaultOpts (runEntries tests) + +tests :: [Entry] +tests = + [ Fold.Test.tests + , Getter.Test.tests + , Iso.Test.tests + , Monoid.Fork.Test.tests + , Profunctor.Coexp.Test.tests + , Review.Test.tests + , Tropical.Test.tests + ] diff --git a/test/Test/Group.hs b/test/Test/Group.hs new file mode 100644 --- /dev/null +++ b/test/Test/Group.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TemplateHaskell #-} +module Test.Group +( Entry(..) +, mkGroup +, deriveGroup +, mkProp +, entryName +, Loc(..) +, here +, zero +, Semiring(..) +, Unital(..) +, horizontal +, sumWidths +, vertical +, maxWidths +, Width(..) +, HasWidth(..) + -- * Statuses +, stat +, Status(..) + -- * Tallies +, hasFailures +, hasSuccesses +, unit +, Tally(..) +) where + +import Data.Char (isSpace) +import Fresnel.Tropical +import GHC.Stack +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax (Module(..), modString) +import Numeric (readDec) +import Test.QuickCheck (Property, allProperties) + +data Entry + = Group String [Entry] + | Prop String Loc Property + +mkGroup :: String -> [(String, Property)] -> Entry +mkGroup name = Group name . map (uncurry mkProp) + +deriveGroup :: ExpQ +deriveGroup = [e| mkGroup $(thisModule >>= \ (Module _ name) -> stringE (modString name)) $allProperties |] + +mkProp :: String -> Property -> Entry +mkProp s = Prop name Loc{ path, lineNumber } + where + (name, path, lineNumber) = case breaks [isSpace, not . isSpace, isSpace, not . isSpace, (== ':'), (/= ':')] s of + [n, _, _, _, p, _, l] -> (unwords (filter (\ s -> s /= "_" && s /= "prop") (breakAll (== '_') n)), p, fst (head (readDec l))) + _ -> ("", "", 0) + +entryName :: Entry -> String +entryName = \case + Group name _ -> name + Prop name _ _ -> name + + +data Loc = Loc { path :: FilePath, lineNumber :: Int } + +here :: HasCallStack => Loc +here = Loc{ path = srcLocFile srcLoc, lineNumber = srcLocStartLine srcLoc } + where + (_, srcLoc) = head (getCallStack callStack) + + +breaks :: [a -> Bool] -> [a] -> [[a]] +breaks ps as = case ps of + [] -> [as] + p:ps -> let (h, t) = break p as in h : breaks ps t + +breakAll :: (a -> Bool) -> [a] -> [[a]] +breakAll p = go False where + go b = \case + [] -> [] + as -> let (h, t) = break (if b then not . p else p) as in h : go (not b) t + + +zero :: Monoid s => s +zero = mempty + +class Semigroup s => Semiring s where + (><) :: s -> s -> s + infixr 7 >< + +instance (Semigroup a, Ord a) => Semiring (Tropical a) where + Tropical a1 >< Tropical a2 = Tropical ((<>) <$> a1 <*> a2) + +class (Monoid s, Semiring s) => Unital s where + one :: s + +instance (Monoid a, Ord a) => Unital (Tropical a) where + one = finite zero + + +horizontal :: (Foldable t, Unital r) => (a -> r) -> t a -> r +horizontal f = foldr ((><) . f) one + +sumWidths :: (Foldable t, HasWidth a) => t a -> Tropical Width +sumWidths = horizontal maxWidth + +vertical :: (Foldable t, Semiring r, Monoid r) => (a -> r) -> t a -> r +vertical f = foldr ((<>) . f) zero + +maxWidths :: (Foldable t, HasWidth a) => t a -> Tropical Width +maxWidths = vertical maxWidth + +newtype Width = Width { width :: Int } + deriving (Eq, Ord) + +instance Semigroup Width where + Width a1 <> Width a2 = Width (a1 + a2) + +instance Monoid Width where + mempty = Width 0 + +instance Semiring Width where + Width a1 >< Width a2 = Width (a1 * a2) + +instance Unital Width where + one = Width 1 + + +class HasWidth t where + maxWidth :: t -> Tropical Width + +instance HasWidth Char where + maxWidth _ = finite one + +instance HasWidth Entry where + maxWidth = \case + Group groupName entries -> sumWidths groupName <> maxWidths entries + Prop name _ _ -> sumWidths name + + +-- Statuses + +stat :: a -> a -> Status -> a +stat pass fail = \case{ Pass -> pass ; Fail -> fail } + +data Status = Pass | Fail + deriving (Eq) + + +-- Tallies + +hasSuccesses :: Tally -> Bool +hasSuccesses = (/= 0) . successes + +hasFailures :: Tally -> Bool +hasFailures = (/= 0) . failures + +unit :: Status -> Tally +unit = stat (Tally 1 0) (Tally 0 1) + +data Tally = Tally { successes :: Int, failures :: Int } + +instance Semigroup Tally where + Tally s1 f1 <> Tally s2 f2 = Tally (s1 + s2) (f1 + f2) + +instance Monoid Tally where + mempty = Tally 0 0 diff --git a/test/Test/Options.hs b/test/Test/Options.hs new file mode 100644 --- /dev/null +++ b/test/Test/Options.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Test.Options +( -- * Options + Options(..) +, defaultOptions +, entries_ +, args_ + -- * Args optics +, maxSuccess_ +, maxSize_ +, maxShrinks_ +, replay_ + -- * CLI options +, parseOpts +, defaultOpts +, printErrors +, header +, withOptions +) where + +import Control.Monad ((<=<)) +import Data.Bool (bool) +import Data.Foldable (traverse_) +import Data.List (intercalate) +import Fresnel.Lens (Lens', lens) +import Fresnel.Setter (set, (%~)) +import Numeric (readDec) +import System.Console.GetOpt +import System.Environment (getProgName) +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStrLn, stderr) +import Test.QuickCheck (Args(..), stdArgs) +import Test.QuickCheck.Random (QCGen) + +-- Options + +data Options = Options + { entries :: [String] + , args :: Args + } + +defaultOptions :: Options +defaultOptions = Options{ entries = [], args = stdArgs{ maxSuccess = 250, chatty = False }} + +entries_ :: Lens' Options [String] +entries_ = lens entries (\ o entries -> o{ entries }) + +args_ :: Lens' Options Args +args_ = lens args (\ o args -> o{ args }) + + +-- Args optics + +maxSuccess_ :: Lens' Args Int +maxSuccess_ = lens maxSuccess (\ a maxSuccess -> a{ maxSuccess }) + +maxSize_ :: Lens' Args Int +maxSize_ = lens maxSize (\ a maxSize -> a{ maxSize }) + +maxShrinks_ :: Lens' Args Int +maxShrinks_ = lens maxShrinks (\ a maxShrinks -> a{ maxShrinks }) + +replay_ :: Lens' Args (Maybe (QCGen, Int)) +replay_ = lens replay (\ a replay -> a{ replay }) + + +-- CLI options + +parseOpts :: [OptDescr (Options -> Options)] -> [String] -> Either [String] Options +parseOpts opts args + | null other + , null errs = Right options + | otherwise = Left (map ("Unrecognized argument: " ++) other ++ errs) + where + options = foldr ($) defaultOptions mods + (mods, other, errs) = getOpt RequireOrder opts args + +defaultOpts :: [OptDescr (Options -> Options)] +defaultOpts = + [ Option "n" ["successes"] (ReqArg (set (args_.maxSuccess_) . int) "N") "require N successful tests before concluding the property passes" + , Option "z" ["size"] (ReqArg (set (args_.maxSize_) . int) "N") "increase the size parameter to a maximum of N for successive tests of a property" + , Option "s" ["shrinks"] (ReqArg (set (args_.maxShrinks_) . int) "N") "perform a maximum of N shrinks; setting this to 0 disables shrinking" + , Option "m" ["match"] (ReqArg (\ s -> entries_ %~ (s:)) "NAME") "include the named group or property; can be used multiple times to include multiple groups/properties" + , Option "r" ["replay"] (ReqArg (set (args_.replay_) . Just . read) "SEED") "the seed and size to repeat" + ] + where + int = fst . head . readDec + +printErrors :: [OptDescr a] -> [String] -> IO Bool +printErrors opts errs = do + name <- getProgName + False <$ traverse_ (hPutStrLn stderr) (errs ++ [usageInfo (header name opts) opts]) + +header :: String -> [OptDescr a] -> String +header name opts = "Usage: " ++ name ++ " " ++ unwords (map opt opts) where + opt (Option short long a _) = bracket (intercalate "|" ([ arg a ['-',c] | c <- short ] ++ map (arg a . ("--"++)) long)) + arg (NoArg _) = id + arg (ReqArg _ s) = (++ " " ++ s) + arg (OptArg _ s) = (++ bracket s) + bracket s = "[" ++ s ++ "]" + +withOptions :: [OptDescr (Options -> Options)] -> (Options -> IO Bool) -> [String] -> IO () +withOptions opts f = bool exitFailure exitSuccess <=< either (printErrors opts) f . parseOpts opts diff --git a/test/Test/Print.hs b/test/Test/Print.hs new file mode 100644 --- /dev/null +++ b/test/Test/Print.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE FlexibleContexts #-} +module Test.Print +( withSGR +, success +, failure +, failure' +, sparkify +, topIndent +, withHandle +, line +, section +, space +, bullet +, heading1 +, headingN +, arrow +, vline +, hline +, gtally +, end +, nl +, putS +, sepBy_ +) where + +import Control.Effect.Reader +import Control.Effect.State +import Control.Monad (join, when) +import Control.Monad.IO.Class +import Data.Bool (bool) +import Data.List (intersperse) +import Data.Monoid (Ap(..)) +import Fresnel.Maybe (_Just) +import Fresnel.Optional (is) +import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..), SGR(..), hSetSGR) +import System.IO (Handle, hPutStr, hPutStrLn) +import Test.Group + +withSGR :: (Has (Reader Handle) sig m, MonadIO m) => [SGR] -> m a -> m a +withSGR sgr m = withHandle $ \ h -> liftIO (hSetSGR h sgr) *> m <* liftIO (hSetSGR h []) + +colour :: (Has (Reader Handle) sig m, MonadIO m) => ColorIntensity -> Color -> m a -> m a +colour i c = withSGR [SetColor Foreground i c] + +success, failure, failure' :: (Has (Reader Handle) sig m, MonadIO m) => m a -> m a + +success = colour Vivid Green +failure = colour Vivid Red +failure' = colour Dull Red + + +sparks :: String +sparks = " ▁▂▃▄▅▆▇█" + +sparkify :: Real a => [a] -> String +sparkify bins = sparkifyRelativeTo sparks (maximum bins) bins + +sparkifyRelativeTo :: Real a => String -> a -> [a] -> String +sparkifyRelativeTo sparks max = fmap spark + where + spark n = sparks !! round (realToFrac n / realToFrac max * realToFrac (length sparks - 1) :: Double) + + +topIndent :: (Has (Reader Handle) sig m, Has (State Tally) sig m, MonadIO m) => String -> m () +topIndent m = gets hasFailures >>= failure' . putS . bool space m + +withHandle :: Has (Reader Handle) sig m => (Handle -> m a) -> m a +withHandle = join . asks + + +line :: (Has (Reader Handle) sig m, Has (State Tally) sig m, MonadIO m) => m () +line = topIndent vline *> putS vline + +section :: (Has (Reader Handle) sig m, Has (Reader Width) sig m, Has (State Tally) sig m, MonadIO m) => Maybe Status -> m a -> m a +section s m = do + fullWidth <- asks ((+ (3 + length "Success")) . width) + let rule corner = indent *> maybe id (stat success failure) s (putS (corner : h : replicate fullWidth h)) *> nl + rule '╭' *> m <* rule '╰' + where + indent = topIndent vline *> when (is _Just s) (putS vline) + h = '─' + + +space, bullet, heading1, headingN, arrow, vline, hline, gtally, end :: String +space = " " +bullet = "☙ " +heading1 = "╭─" +headingN = "├─" +arrow = "▶ " +vline = "│ " +hline = "──" +gtally = "┤ " +end = "╰─┤ " + + +nl :: (Has (Reader Handle) sig m, MonadIO m) => m () +nl = withHandle (liftIO . (`hPutStrLn` "")) + +putS :: (Has (Reader Handle) sig m, MonadIO m) => String -> m () +putS s = withHandle (liftIO . (`hPutStr` s)) + + +sepBy_ :: Applicative m => m () -> [m ()] -> m () +sepBy_ sep = getAp . foldMap Ap . intersperse sep diff --git a/test/Test/Run.hs b/test/Test/Run.hs new file mode 100644 --- /dev/null +++ b/test/Test/Run.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} +module Test.Run +( runEntries +) where + +import Control.Carrier.Reader +import Control.Carrier.State.Church +import Control.Exception (SomeException) +import Control.Monad (guard, when) +import Control.Monad.IO.Class +import Data.Bool (bool) +import Data.Foldable (for_, toList) +import qualified Data.IntMap as IntMap +import Data.List (elemIndex, intercalate, intersperse, sortBy) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Monoid (Ap(..)) +import Data.Ord (comparing) +import Fresnel.Tropical +import GHC.Exception.Type (Exception(displayException)) +import Numeric (showFFloatAlt) +import System.Console.ANSI +import System.IO +import Test.Group as Group +import Test.Options +import Test.Print +import Test.QuickCheck (Args(..), isSuccess, quickCheckWithResult) +import qualified Test.QuickCheck as QC + +runEntries :: [Entry] -> Options -> IO Bool +runEntries groups (Options es args) = runReader w . runReader args . runReader stdout . runState (const . pure . not . hasFailures) mempty $ do + t <- getAp (foldMap Ap (intersperse (mempty <$ blank <* blank) (map runEntry (matching ((==) . entryName) es groups)))) + when (hasSuccesses t || hasFailures t) (blank *> topIndent end *> runTally t) + where + blank = topIndent vline <* nl + w = fromMaybe zero (getTropical (maxWidths groups)) + matching _ [] = id + matching f fs = filter (\ g -> foldr ((||) . f g) False fs) + +runEntry :: (Has (Reader Args) sig m, Has (Reader Handle) sig m, Has (Reader Width) sig m, Has (State Tally) sig m, MonadIO m) => Entry -> m Tally +runEntry = \case + Group name entries -> runGroup name entries + Prop name loc prop -> runProp name loc prop + + +runGroup :: (Has (Reader Args) sig m, Has (Reader Handle) sig m, Has (Reader Width) sig m, Has (State Tally) sig m, MonadIO m) => String -> [Entry] -> m Tally +runGroup groupName entries = do + topIndent vline + withSGR [SetConsoleIntensity BoldIntensity] (putS (space ++ groupName) *> nl) + w <- ask + t <- local (<> Width 2) (section Nothing (getAp (foldMap Ap (intersperse (mempty <$ line <* nl) (map (local (const (w :: Width)) . runEntry) entries))))) + when (hasSuccesses t || hasFailures t) $ do + if hasFailures t then + failure' (putS (headingN <> gtally)) + else + topIndent vline *> putS space + runTally t + pure t + +runProp :: (Has (Reader Args) sig m, Has (Reader Handle) sig m, Has (Reader Width) sig m, Has (State Tally) sig m, MonadIO m) => String -> Loc -> QC.Property -> m Tally +runProp name loc property = runPropWith (ask >>= \ args -> fromQC <$> liftIO (quickCheckWithResult args property)) name loc + +runPropWith :: (Has (Reader Args) sig m, Has (Reader Handle) sig m, Has (Reader Width) sig m, Has (State Tally) sig m, MonadIO m) => m Result -> String -> Loc -> m Tally +runPropWith run name Loc{ path, lineNumber } = withHandle $ \ h -> do + isTerminal <- liftIO (hIsTerminalDevice h) + + when isTerminal (title Pass False) + + failedPreviously <- gets hasFailures + Result{ stats, status, failed } <- run + modify (<> unit status) + + when isTerminal $ do + liftIO (hClearFromCursorToLineBeginning h) + liftIO (hSetCursorColumn h 0) + + title status failedPreviously + + putS " " *> stat (success (putS "Success")) (failure (putS "Failure")) status *> nl + + maxSuccess <- asks maxSuccess + let details = numTests stats == maxSuccess && not (null (classes stats)) + labels = runLabels status stats + ln b = line *> stat success failure status (putS vline) *> b *> nl + output + | details || status == Fail || not (null labels) = section (Just status) + | otherwise = id + + unit status <$ output (sepBy_ (ln (pure ())) (concat + [ [ ln (sepBy_ (putS " ") (runStats maxSuccess stats ++ runClasses stats)) | details ] + , do + Failure{ seed, reason, exception, testCase } <- toList failed + let len = length testCase + concat + [ [ do + ln (putS (path ++ ':' : show lineNumber ++ ':' : ' ' : reason)) + for_ exception (ln . putS . displayException) ] + , [ for_ (enumerate (init testCase)) (\ (i, s) -> ln (putS (i ++ s))) | len >= 2 ] + , [ ln (failure (putS (last testCase))) | len >= 1 ] + , [ ln (putS ("--replay '" ++ seed ++ "'")) ] ] + , labels + , runTables stats ])) + where + title s failedPreviously = do + topIndent (stat vline (bool heading1 headingN failedPreviously) s) + stat (putS vline) (failure' (putS (hline ++ arrow))) s + w <- asks width + withSGR (SetConsoleIntensity BoldIntensity:stat [] [ SetColor Foreground Vivid Red ] s) (putS (bullet ++ name ++ replicate (w - length name) ' ')) + withHandle (liftIO . hFlush) + +data Result = Result + { stats :: Stats + , status :: Status + , failed :: Maybe Failure + } + +data Failure = Failure + { seed :: String + , reason :: String + , exception :: Maybe SomeException + , testCase :: [String] + } + +data Stats = Stats + { numTests :: Int + , numDiscarded :: Int + , numShrinks :: Int + , labels :: Map.Map [String] Int + , classes :: Map.Map String Int + , tables :: Map.Map String (Map.Map String Int) + } + +defaultStats :: Stats +defaultStats = Stats + { numTests = 0 + , numDiscarded = 0 + , numShrinks = 0 + , labels = Map.empty + , classes = Map.empty + , tables = Map.empty + } + +fromQC :: QC.Result -> Result +fromQC r = Result (resultStats r) (bool Fail Pass (isSuccess r)) $ case r of + QC.Failure{ usedSeed, usedSize, reason, theException, failingTestCase } -> Just Failure{ seed = show (usedSeed, usedSize), reason, exception = theException, testCase = failingTestCase } + _ -> Nothing + +resultStats :: QC.Result -> Stats +resultStats = \case + QC.Success{ numTests, numDiscarded, labels, classes, tables } -> defaultStats{ numTests, numDiscarded, labels, classes, tables } + QC.GaveUp{ numTests, numDiscarded, labels, classes, tables } -> defaultStats{ numTests, numDiscarded, labels, classes, tables } + QC.Failure{ numTests, numDiscarded, numShrinks, failingLabels, failingClasses } -> defaultStats{ numTests, numDiscarded, numShrinks, labels = Map.fromList (map ((, numTests) . pure) failingLabels), classes = Map.fromList (map (,numTests) (toList failingClasses)) } + QC.NoExpectedFailure{ numTests, numDiscarded, labels, classes, tables } -> defaultStats{ numTests, numDiscarded, labels, classes, tables } + +runStats :: (Has (Reader Handle) sig m, MonadIO m) => Int -> Stats -> [m ()] +runStats maxSuccess Stats{ numTests, numDiscarded, numShrinks } = [ sepBy_ (putS ", ") entries *> putS "." | not (null entries) ] + where + entries = concat + [ [ putS (show numTests ++ " test" ++ singular numTests) | numTests > 0, numTests /= maxSuccess ] + , [ putS (show numDiscarded ++ " discarded") | numDiscarded > 0 ] + , [ putS (show numShrinks ++ " shrink" ++ singular numShrinks) | numShrinks > 0 ] + ] + + +runLabels :: (Has (Reader Handle) sig m, Has (State Tally) sig m, MonadIO m) => Status -> Stats -> [m ()] +runLabels s Stats{ numTests, labels } + | null labels = [] + | otherwise = IntMap.elems numberedLabels >>= \ m -> + let sorted = sortBy (flip (comparing snd) <> flip (comparing fst)) (Map.toList m) + scaled = map (fmap (\ v -> realToFrac v / n * 100)) sorted + sparked = sparkify (Map.elems m) + ln l = line *> stat success failure s (putS vline) *> putS l *> nl + in + [ for_ (enumerate scaled) $ \ (i, (key, v)) -> ln (i ++ (' ' <$ guard (v < 10)) ++ showFFloatAlt (Just 1) v "" ++ "% " ++ key) + , do + ln [ c | e <- sparked, c <- [e, e, e] ] + ln [ c | k <- Map.keys m, i <- maybe [] (pure . succ) (elemIndex k (map fst sorted)), c <- ' ':show i ++ " " ] ] + where + numberedLabels = IntMap.fromListWith (Map.unionWith (+)) + [ (i, Map.singleton l n) + | (labels, n) <- Map.toList labels + , (i, l) <- zip [(0 :: Int)..] labels ] + n = realToFrac numTests :: Double + +enumerate :: [a] -> [(String, a)] +enumerate as = foldr (\ (i, a) as -> (show (i :: Int) ++ ". " ++ replicate (maxDigits - digits i) ' ', a):as) [] (zip [1 :: Int ..] as) where + digits i = ceiling (logBase 10 (realToFrac (i + 1) :: Double)) + maxDigits = digits (length as) + +runClasses :: (Has (Reader Handle) sig m, MonadIO m) => Stats -> [m ()] +runClasses Stats{ numTests = n, classes } = [ putS (intercalate ", " (map (uncurry (class_ n)) (Map.toList classes)) ++ ".") | not (null classes) ] where + class_ n label n' = if n == n' then label else showFFloatAlt (Just 1) (fromIntegral n' / fromIntegral n * 100 :: Double) ('%':' ':label) + +runTables :: Stats -> [m ()] +runTables _ = [] + + +plural :: Int -> a -> a -> a +plural 1 s _ = s +plural _ _ p = p + +singular :: Int -> String +singular 1 = "s" +singular _ = "" + +runTally :: (Has (Reader Handle) sig m, MonadIO m) => Tally -> m () +runTally t = sepBy_ (putS ", " ) (map success (tally "✓" "success" "successes" (successes t)) ++ map failure (tally "✗" "failure" "failures" (failures t))) *> putS "." *> nl + where + tally prefix s p n = [ sepBy_ (putS " ") [ putS prefix, putS (show n), putS (plural n s p) ] | n /= 0 ] diff --git a/test/Tropical/Test.hs b/test/Tropical/Test.hs new file mode 100644 --- /dev/null +++ b/test/Tropical/Test.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TemplateHaskell #-} +module Tropical.Test +( tests +) where + +import Data.Monoid (Sum) +import Fresnel.Tropical +import Test.Group +import Test.QuickCheck hiding ((><)) + +prop_semigroup_assoc (ArbTropical a) (ArbTropical b) (ArbTropical c) = label (summarize a) . label (summarize b) . label (summarize c) $ a <> (b <> c) === (a <> b) <> c + +prop_monoid_identity (ArbTropical a) = label (summarize a) $ (mempty <> a) === a .&&. (a <> mempty) === a + +prop_semiring_assoc (ArbTropical a) (ArbTropical b) (ArbTropical c) = label (summarize a) . label (summarize b) . label (summarize c) $ a >< (b >< c) === (a >< b) >< c + +prop_unital_identity (ArbTropical a) = label (summarize a) $ (one >< a) === a .&&. (a >< one) === a + + +summarize :: Tropical (Sum Int) -> String +summarize (Tropical a) = case a of + Nothing -> "zero" + Just a + | signum a > 0 -> "pos" + | signum a < 0 -> "neg" + | otherwise -> "one" + + +newtype ArbTropical = ArbTropical (Tropical (Sum Int)) + deriving (Eq, Ord, Show) + +instance Arbitrary ArbTropical where + arbitrary = oneof $ map (fmap (ArbTropical . Tropical)) + [ pure Nothing + , Just <$> arbitrary + , pure (Just 0) + ] + + +pure [] + +tests :: Entry +tests = $deriveGroup