diff --git a/LICENCE b/LICENCE --- a/LICENCE +++ b/LICENCE @@ -1,30 +1,27 @@ -Copyright (c) 2025 Tony Morris +Copyright 2025-2026 Tony Morris 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 Tony Morris nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the author nor the names of his 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. +THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,16 @@ -0.0.0.1 +0.0.2 + +* Add type classes: GetterId, HasId, ReviewId, AsId +* Add type aliases: IdProxy, IdMaybe, IdIdentity, IdEither, IdWriter, IdList, IdNonEmpty, IdConst, IdTagged +* Add functions: unId, mapId +* Add __Wrapped iso (fully type-changing) with specializations for all type aliases +* Add optics: idTagged, idProxy, just, rejust, nothing, renothing +* Add instances: Read, Data, Generic1, Eq1, Ord1, Show1, Read1, Selective, MonadFix, MonadFail, MonadPlus, MonadZip, Contravariant, Divisible, Decidable, Plus, Extend, FunctorWithIndex, FoldableWithIndex, TraversableWithIndex +* Add efficiency methods for Applicative and Foldable +* Fix MonadRWS instance to use distinct type variables +* Add contravariant dependency +* Add doctest suite, CI, ormolu/hlint configuration + +0.0.1 * The initial version of id. diff --git a/id.cabal b/id.cabal --- a/id.cabal +++ b/id.cabal @@ -1,37 +1,48 @@ +cabal-version: 2.4 name: id -version: 0.0.0.1 +version: 0.0.2 synopsis: Id (f a) data type -description: - (f a) data type, with optics and functions for switching the type constructor (f) - . - <> -license: BSD3 +description: (f a) data type, with optics and functions for switching the type constructor (f) +license: BSD-3-Clause license-file: LICENCE author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> -copyright: Copyright (C) 2025 Tony Morris +copyright: Copyright (C) 2025-2026 Tony Morris category: Data build-type: Simple -extra-source-files: changelog.md -cabal-version: >=1.10 +extra-doc-files: changelog.md homepage: https://gitlab.com/system-f/code/id bug-reports: https://gitlab.com/system-f/code/id/issues -tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.5, GHC == 9.4.8, GHC == 9.6.7 +tested-with: GHC == 9.6.7 source-repository head type: git - location: git@github.com:system-f/code/id.git + location: git@gitlab.com:system-f/code/id.git library exposed-modules: Data.Id build-depends: base >= 4.8 && < 6 + , contravariant >= 1.4 && < 2 , lens >= 4 && < 6 , mtl >= 2.2 && < 3 - , semigroupoids - , tagged - , transformers + , semigroupoids >= 6 && < 7 + , tagged >= 0.8 && < 1 + , selective >= 0.7 && < 1 + , transformers >= 0.5 && < 1 hs-source-dirs: src + + default-language: Haskell2010 + + ghc-options: -Wall + +test-suite doctest + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base >= 4.8 && < 6 + , process >= 1 && < 2 + build-tool-depends: doctest:doctest >= 0.22 default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Data/Id.hs b/src/Data/Id.hs --- a/src/Data/Id.hs +++ b/src/Data/Id.hs @@ -1,75 +1,248 @@ -{-# OPTIONS_GHC -Wall #-} - -{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wall -Werror #-} -module Data.Id where +-- | +-- @Id f a@ — a newtype around @f a@, with optics and instances for switching +-- the type constructor @f@. +module Data.Id + ( -- * Id data type + Id (..), -import Control.Applicative ( Alternative(empty, (<|>)) ) + -- * Functions + unId, + mapId, + + -- * Type aliases + IdProxy, + IdMaybe, + IdIdentity, + IdEither, + IdWriter, + IdList, + IdNonEmpty, + IdConst, + IdTagged, + + -- * Type classes + + -- ** GetterId + GetterId (..), + + -- ** HasId + HasId (..), + + -- ** ReviewId + ReviewId (..), + + -- ** AsId + AsId (..), + + -- * Optics + __Wrapped, + idTagged, + idProxy, + just, + rejust, + nothing, + renothing, + ) +where + +import Control.Applicative (Alternative (empty, (<|>))) import Control.Lens - ( Wrapped(..), - Rewrapped, - Iso, - Lens', - Prism, - Getter, - iso, - over, - _Wrapped, - view, - _Just, - _Unwrapped, - re, - _Nothing ) -import Control.Monad.Cont ( MonadCont(..) ) -import Control.Monad.Error.Class ( MonadError(..) ) -import Control.Monad.IO.Class ( MonadIO(..) ) -import Control.Monad.Reader.Class ( MonadReader(..) ) -import Control.Monad.RWS.Class ( MonadRWS ) -import Control.Monad.State.Class ( MonadState(..) ) -import Control.Monad.Trans.Class ( MonadTrans(..) ) -import Control.Monad.Writer( MonadWriter(..) ) -import Data.Functor.Alt ( Alt(()) ) -import Data.Functor.Apply ( Apply((<.>)) ) -import Data.Functor.Bind ( Bind((>>-)) ) -import Data.Functor.Bind.Trans ( BindTrans(..) ) + ( FoldableWithIndex (..), + FunctorWithIndex (..), + Getter, + Iso, + Lens', + Prism, + Prism', + Review, + Rewrapped, + TraversableWithIndex (..), + Wrapped (..), + iso, + lens, + over, + prism', + re, + review, + unto, + view, + _Just, + _Nothing, + _Unwrapped, + _Wrapped, + ) +import Control.Monad (MonadPlus (..)) +import Control.Monad.Cont (MonadCont (..)) +import Control.Monad.Error.Class (MonadError (..)) +import Control.Monad.Fix (MonadFix (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.RWS.Class (MonadRWS) +import Control.Monad.Reader.Class (MonadReader (..)) +import Control.Monad.State.Class (MonadState (..)) +import Control.Monad.Trans.Class (MonadTrans (..)) +import Control.Monad.Writer (MonadWriter (..)) +import Control.Monad.Zip (MonadZip (..)) +import Control.Selective (Selective (..)) +import Data.Data (Data) +import Data.Functor.Alt (Alt (())) +import Data.Functor.Apply (Apply ((<.>))) +import Data.Functor.Bind (Bind ((>>-))) +import Data.Functor.Bind.Trans (BindTrans (..)) import Data.Functor.Classes - ( Eq1(..), Ord1(..), Show1(liftShowsPrec) ) -import Data.Functor.Identity ( Identity(Identity) ) -import Data.Semigroup.Foldable ( Foldable1(foldMap1) ) -import Data.Semigroup.Traversable ( Traversable1(traverse1) ) -import Data.Tagged ( Tagged(Tagged), untag ) -import Data.Proxy ( Proxy ) + ( Eq1 (..), + Ord1 (..), + Read1 (..), + Show1 (liftShowsPrec), + ) +import Data.Functor.Const (Const) +import Data.Functor.Contravariant (Contravariant (..)) +import Data.Functor.Contravariant.Divisible (Decidable (..), Divisible (..)) +import Data.Functor.Extend (Extend (..)) +import Data.Functor.Identity (Identity (Identity)) +import Data.Functor.Plus (Plus (..)) +import Data.List.NonEmpty (NonEmpty) +import Data.Proxy (Proxy (..)) +import Data.Semigroup.Foldable (Foldable1 (foldMap1)) +import Data.Semigroup.Traversable (Traversable1 (traverse1)) +import Data.Tagged (Tagged (Tagged), untag) +import GHC.Generics (Generic, Generic1) -newtype Id f a = - Id (f a) - deriving (Eq, Ord, Show) +-- $setup +-- >>> import Control.Lens (set, preview, review, from) +-- >>> import Data.Functor.Const (Const(..)) +-- >>> import Data.List.NonEmpty (NonEmpty(..)) +-- >>> import Data.Semigroup (Sum(..)) -instance Eq1 f => Eq1 (Id f) where +-- | +-- >>> Id [1,2,3] +-- Id [1,2,3] +-- +-- >>> Id [1,2,3] == Id [1,2,3] +-- True +-- +-- >>> Id [1,2,3] == Id [4,5,6] +-- False +-- +-- >>> compare (Id [1,2,3]) (Id [1,2,4]) +-- LT +-- +-- >>> Id [1,2,3] <= Id [1,2,3] +-- True +newtype Id f a + = Id (f a) + deriving (Eq, Ord, Show, Read, Data, Generic, Generic1) + +-- | +-- >>> liftEq (==) (Id [1,2,3]) (Id [1,2,3]) +-- True +-- +-- >>> liftEq (==) (Id [1,2,3]) (Id [4,5,6]) +-- False +-- +-- >>> liftEq (\_ _ -> True) (Id [1,2,3]) (Id [4,5,6]) +-- True +instance (Eq1 f) => Eq1 (Id f) where liftEq f (Id x) (Id y) = liftEq f x y -instance Ord1 f => Ord1 (Id f) where +-- | +-- >>> liftCompare compare (Id [1,2,3]) (Id [1,2,4]) +-- LT +-- +-- >>> liftCompare compare (Id [1,2,3]) (Id [1,2,3]) +-- EQ +-- +-- >>> liftCompare (\_ _ -> GT) (Id [1]) (Id [2]) +-- GT +instance (Ord1 f) => Ord1 (Id f) where liftCompare f (Id x) (Id y) = liftCompare f x y -instance Show1 f => Show1 (Id f) where +-- | +-- >>> liftShowsPrec showsPrec showList 0 (Id [1,2,3]) "" +-- "Id [1,2,3]" +-- +-- >>> liftShowsPrec showsPrec showList 0 (Id (Just 'x')) "" +-- "Id (Just 'x')" +-- +-- >>> liftShowsPrec showsPrec showList 11 (Id [1,2,3]) "" +-- "(Id [1,2,3])" +instance (Show1 f) => Show1 (Id f) where liftShowsPrec sp l d (Id x) = - ("Id (" <>) . liftShowsPrec sp l d x . (")" <>) + showParen (d > 10) $ showString "Id " . liftShowsPrec sp l 11 x -instance (Id f a ~ x) => +-- | +-- >>> liftReadsPrec readsPrec readList 0 "Id [1,2,3]" :: [(Id [] Int, String)] +-- [(Id [1,2,3],"")] +-- +-- >>> liftReadsPrec readsPrec readList 0 "Id (Just 'x')" :: [(Id Maybe Char, String)] +-- [(Id (Just 'x'),"")] +-- +-- >>> liftReadsPrec readsPrec readList 11 "(Id [1,2,3])" :: [(Id [] Int, String)] +-- [(Id [1,2,3],"")] +instance (Read1 f) => Read1 (Id f) where + liftReadsPrec rp rl d = + readParen + (d > 10) + (\s -> [(Id x, t) | ("Id", r) <- lex s, (x, t) <- liftReadsPrec rp rl 11 r]) + +instance + (Id f a ~ x) => Rewrapped (Id f a') x +-- | +-- >>> view _Wrapped' (Id [1,2,3]) +-- [1,2,3] +-- +-- >>> set _Wrapped' [4,5] (Id [1,2,3]) +-- Id [4,5] instance Wrapped (Id f a) where - type Unwrapped (Id f a) = - f a + type + Unwrapped (Id f a) = + f a _Wrapped' = iso (\(Id x) -> x) Id +-- | +-- >>> view __Wrapped (Id [1,2,3]) +-- [1,2,3] +-- +-- >>> view (from __Wrapped) [1,2,3] :: Id [] Int +-- Id [1,2,3] +-- +-- >>> over __Wrapped (fmap (+1)) (Id [1,2,3]) +-- Id [2,3,4] +{-# SPECIALIZE __Wrapped :: + Iso (IdMaybe a) (IdMaybe a') (Maybe a) (Maybe a') + #-} +{-# SPECIALIZE __Wrapped :: + Iso (IdIdentity a) (IdIdentity a') (Identity a) (Identity a') + #-} +{-# SPECIALIZE __Wrapped :: + Iso (IdEither e a) (IdEither e' a') (Either e a) (Either e' a') + #-} +{-# SPECIALIZE __Wrapped :: + Iso (IdWriter w a) (IdWriter w' a') (w, a) (w', a') + #-} +{-# SPECIALIZE __Wrapped :: + Iso (IdList a) (IdList a') [a] [a'] + #-} +{-# SPECIALIZE __Wrapped :: + Iso (IdNonEmpty a) (IdNonEmpty a') (NonEmpty a) (NonEmpty a') + #-} +{-# SPECIALIZE __Wrapped :: + Iso (IdConst c a) (IdConst c' a') (Const c a) (Const c' a') + #-} __Wrapped :: Iso (Id f a) @@ -81,101 +254,322 @@ (\(Id x) -> x) Id -class HasId a f a' | a -> f a' where - id' :: - Lens' a (Id f a') +-- | +-- >>> unId (Id [1,2,3]) +-- [1,2,3] +-- +-- >>> unId (Id (Identity 7)) +-- Identity 7 +unId :: Id f a -> f a +unId (Id x) = x -instance HasId (Id f a') f a' where - id' = +-- | +-- >>> mapId reverse (Id [1,2,3]) +-- Id [3,2,1] +-- +-- >>> mapId (Just . head) (Id [1,2,3]) +-- Id (Just 1) +-- +-- >>> mapId Identity (Id [1,2,3]) +-- Id (Identity [1,2,3]) +mapId :: (f a -> g b) -> Id f a -> Id g b +mapId = over __Wrapped + +-- | +-- >>> view getId (Id [1,2,3]) +-- Id [1,2,3] +-- +-- >>> view getId (Id (Identity 7)) +-- Id (Identity 7) +class GetterId a f x | a -> f x where + getId :: + Getter a (Id f x) + +instance GetterId (Id f a) f a where + getId = id -class AsId a f a' | a -> f a' where - _Id :: - Lens' a (Id f a') +-- | +-- >>> view id' (Id [1,2,3]) +-- Id [1,2,3] +-- +-- >>> set id' (Id [4,5]) (Id [1,2,3]) +-- Id [4,5] +class (GetterId a f x) => HasId a f x | a -> f x where + {-# MINIMAL setId #-} + setId :: + Id f x -> a -> a + id' :: + Lens' a (Id f x) + id' = + lens (view getId) (flip setId) -instance AsId (Id f a') f a' where +instance HasId (Id f a) f a where + setId = + const + +-- | +-- >>> review reviewId [1,2,3] :: Id [] Int +-- Id [1,2,3] +-- +-- >>> review reviewId (Identity 7) :: IdIdentity Int +-- Id (Identity 7) +class ReviewId a f x | a -> f x where + reviewId :: + Review a (f x) + +instance ReviewId (Id f a) f a where + reviewId = + unto Id + +-- | +-- >>> preview _Id (Id [1,2,3]) +-- Just (Id [1,2,3]) +-- +-- >>> review _Id (Id [1,2,3]) :: Id [] Int +-- Id [1,2,3] +class (ReviewId a f x) => AsId a f x | a -> f x where + {-# MINIMAL matchId #-} + matchId :: + a -> Maybe (Id f x) + _Id :: + Prism' a (Id f x) _Id = - id + prism' (review reviewId . unId) matchId -instance Semigroup (f a) => Semigroup (Id f a) where +instance AsId (Id f a) f a where + matchId = + Just + +-- | +-- >>> Id [1,2,3] <> Id [4,5] +-- Id [1,2,3,4,5] +-- +-- >>> Id "hello" <> Id " world" +-- Id "hello world" +instance (Semigroup (f a)) => Semigroup (Id f a) where Id x <> Id y = Id (x <> y) -instance Monoid (f a) => Monoid (Id f a) where +-- | +-- >>> mempty :: Id [] Int +-- Id [] +-- +-- >>> Id [1,2] <> mempty +-- Id [1,2] +-- +-- >>> mempty <> Id [1,2] :: Id [] Int +-- Id [1,2] +instance (Monoid (f a)) => Monoid (Id f a) where mempty = Id mempty -instance Functor f => Functor (Id f) where +-- | +-- >>> fmap (+1) (Id [1,2,3]) +-- Id [2,3,4] +-- +-- >>> fmap (*2) (Id (Identity 5)) +-- Id (Identity 10) +-- +-- >>> fmap show (Id [1,2,3]) +-- Id ["1","2","3"] +instance (Functor f) => Functor (Id f) where fmap = over _Wrapped . fmap -instance Apply f => Apply (Id f) where +-- | +-- >>> Id [(+1), (*2)] <.> Id [3,4] +-- Id [4,5,6,8] +-- +-- >>> Id (Identity (+1)) <.> Id (Identity 5) +-- Id (Identity 6) +instance (Apply f) => Apply (Id f) where Id x <.> Id y = Id (x <.> y) -instance Applicative f => Applicative (Id f) where +-- | +-- >>> Id [(+1), (*2)] <*> Id [3,4] +-- Id [4,5,6,8] +-- +-- >>> pure 7 :: Id [] Int +-- Id [7] +-- +-- >>> pure 'x' :: Id Identity Char +-- Id (Identity 'x') +instance (Applicative f) => Applicative (Id f) where Id x <*> Id y = Id (x <*> y) pure = Id . pure + liftA2 f (Id x) (Id y) = + Id (liftA2 f x y) + Id x *> Id y = + Id (x *> y) + Id x <* Id y = + Id (x <* y) -instance Alt f => Alt (Id f) where +-- | +-- >>> select (Id [Right 7]) (Id [const 0]) +-- Id [7] +-- +-- >>> select (Id [Left 3]) (Id [(+1)]) +-- Id [4] +-- +-- >>> select (Id [Left 3, Right 7]) (Id [(+1), (*2)]) +-- Id [4,6,7] +instance (Selective f) => Selective (Id f) where + select (Id x) (Id y) = + Id (select x y) + +-- | +-- >>> Id [1,2] Id [3,4] +-- Id [1,2,3,4] +-- +-- >>> Id (Just 1) Id (Just 2) +-- Id (Just 1) +-- +-- >>> Id Nothing Id (Just 2) +-- Id (Just 2) +instance (Alt f) => Alt (Id f) where Id x Id y = Id (x y) -instance Alternative f => Alternative (Id f) where +-- | +-- >>> Id [1,2] <|> Id [3,4] +-- Id [1,2,3,4] +-- +-- >>> Id Nothing <|> Id (Just 2) +-- Id (Just 2) +-- +-- >>> empty :: Id [] Int +-- Id [] +-- +-- >>> empty :: Id Maybe Int +-- Id Nothing +instance (Alternative f) => Alternative (Id f) where Id x <|> Id y = Id (x <|> y) empty = Id empty -instance Bind f => Bind (Id f) where +-- | +-- >>> Id [1,2,3] >>- (\x -> Id [x, x*10]) +-- Id [1,10,2,20,3,30] +-- +-- >>> Id (Identity 5) >>- (Id . Identity . (+1)) +-- Id (Identity 6) +instance (Bind f) => Bind (Id f) where Id x >>- f = Id (x >>- view _Wrapped . f) -instance Monad f => Monad (Id f) where +-- | +-- >>> Id [1,2,3] >>= (\x -> Id [x, x*10]) +-- Id [1,10,2,20,3,30] +-- +-- >>> Id (Identity 5) >>= (Id . Identity . (+1)) +-- Id (Identity 6) +instance (Monad f) => Monad (Id f) where Id x >>= f = Id (x >>= view _Wrapped . f) -instance Foldable f => Foldable (Id f) where +-- | +-- >>> foldMap show (Id [1,2,3]) +-- "123" +-- +-- >>> foldMap Sum (Id [1,2,3]) +-- Sum {getSum = 6} +-- +-- >>> foldr (:) [] (Id [1,2,3]) +-- [1,2,3] +instance (Foldable f) => Foldable (Id f) where foldMap f (Id x) = foldMap f x + foldr f z (Id x) = + foldr f z x + null (Id x) = + null x + length (Id x) = + length x -instance Foldable1 f => Foldable1 (Id f) where +-- | +-- >>> foldMap1 show (Id (Identity 7)) +-- "7" +instance (Foldable1 f) => Foldable1 (Id f) where foldMap1 f (Id x) = foldMap1 f x -instance Traversable f => Traversable (Id f) where +-- | +-- >>> traverse Just (Id [1,2,3]) +-- Just (Id [1,2,3]) +-- +-- >>> traverse (\x -> if x > 2 then Nothing else Just x) (Id [1,2,3]) +-- Nothing +-- +-- >>> traverse (\x -> if x > 3 then Nothing else Just x) (Id [1,2,3]) +-- Just (Id [1,2,3]) +instance (Traversable f) => Traversable (Id f) where traverse f (Id x) = Id <$> traverse f x -instance Traversable1 f => Traversable1 (Id f) where +-- | +-- >>> traverse1 Just (Id (Identity 7)) +-- Just (Id (Identity 7)) +instance (Traversable1 f) => Traversable1 (Id f) where traverse1 f (Id x) = Id <$> traverse1 f x -instance MonadIO f => MonadIO (Id f) where +-- | +-- >>> unId (liftIO (pure 7) :: Id IO Int) +-- 7 +instance (MonadIO f) => MonadIO (Id f) where liftIO = Id . liftIO +-- | +-- >>> lift [1,2,3] :: Id [] Int +-- Id [1,2,3] +-- +-- >>> lift (Identity 5) :: Id Identity Int +-- Id (Identity 5) instance MonadTrans Id where lift = Id +-- | +-- >>> liftB [1,2,3] :: Id [] Int +-- Id [1,2,3] instance BindTrans Id where liftB = Id -instance MonadError a f => MonadError a (Id f) where +-- | +-- >>> throwError "oops" :: Id (Either String) Int +-- Id (Left "oops") +-- +-- >>> catchError (Id (Left "oops")) (\_ -> Id (Right 42)) :: Id (Either String) Int +-- Id (Right 42) +instance (MonadError a f) => MonadError a (Id f) where throwError = Id . throwError catchError (Id x) f = Id (catchError x (view _Wrapped . f)) -instance MonadCont f => MonadCont (Id f) where +-- | +-- >>> import Control.Monad.Cont (runCont) +-- >>> runCont (callCC (\k -> k (Id [7]))) unId :: [Int] +-- [7] +instance (MonadCont f) => MonadCont (Id f) where callCC f = Id (callCC (\k -> view _Wrapped (f (Id . k)))) -instance MonadReader a f => MonadReader a (Id f) where +-- | +-- >>> import Control.Monad.Reader (runReader) +-- >>> runReader (unId ask) "hello" +-- "hello" +-- +-- >>> runReader (unId (local (++" world") ask)) "hello" +-- "hello world" +instance (MonadReader a f) => MonadReader a (Id f) where ask = Id ask local f (Id x) = @@ -183,7 +577,14 @@ reader = Id . reader -instance MonadWriter a f => MonadWriter a (Id f) where +-- | +-- >>> import Control.Monad.Writer (runWriter) +-- >>> runWriter (unId (tell "hello" >> tell " world")) +-- ((),"hello world") +-- +-- >>> runWriter (unId (writer (7, "log"))) +-- (7,"log") +instance (MonadWriter a f) => MonadWriter a (Id f) where writer aw = Id (writer aw) tell = @@ -193,7 +594,11 @@ pass = over _Wrapped pass -instance MonadState a f => MonadState a (Id f) where +-- | +-- >>> import Control.Monad.State (runState) +-- >>> runState (unId (get >>= \s -> put (s + 1) >> pure s)) 10 +-- (10,11) +instance (MonadState a f) => MonadState a (Id f) where get = Id get put = @@ -201,91 +606,291 @@ state = Id . state -instance MonadRWS a a a f => MonadRWS a a a (Id f) where +instance (MonadRWS r w s f) => MonadRWS r w s (Id f) -type Id0 a = +-- | +-- >>> mfix (\_ -> Id [1,2,3]) +-- Id [1,2,3] +instance (MonadFix f) => MonadFix (Id f) where + mfix g = + Id (mfix (unId . g)) + +-- | +-- >>> fail "oops" :: Id Maybe Int +-- Id Nothing +instance (MonadFail f) => MonadFail (Id f) where + fail = + Id . fail + +-- | +-- >>> mzero :: Id [] Int +-- Id [] +-- +-- >>> mplus (Id [1,2]) (Id [3,4]) +-- Id [1,2,3,4] +instance (MonadPlus f) => MonadPlus (Id f) + +-- | +-- >>> mzipWith (+) (Id [1,2,3]) (Id [10,20,30]) +-- Id [11,22,33] +instance (MonadZip f) => MonadZip (Id f) where + mzipWith f (Id x) (Id y) = + Id (mzipWith f x y) + +-- | +-- >>> import Data.Functor.Contravariant (Predicate(..), getPredicate) +-- >>> getPredicate (unId (contramap length (Id (Predicate (> 3))))) "hello" +-- True +-- +-- >>> getPredicate (unId (contramap length (Id (Predicate (> 3))))) "hi" +-- False +instance (Contravariant f) => Contravariant (Id f) where + contramap f (Id x) = + Id (contramap f x) + +-- | +-- >>> import Data.Functor.Contravariant (Predicate(..), getPredicate) +-- >>> import Data.Functor.Contravariant.Divisible (divided) +-- >>> getPredicate (unId (divided (Id (Predicate even)) (Id (Predicate (> 0))))) (4, 1) +-- True +-- +-- >>> getPredicate (unId (divided (Id (Predicate even)) (Id (Predicate (> 0))))) (3, 1) +-- False +instance (Divisible f) => Divisible (Id f) where + divide f (Id x) (Id y) = + Id (divide f x y) + conquer = + Id conquer + +-- | +-- >>> import Data.Functor.Contravariant (Predicate(..), getPredicate) +-- >>> import Data.Functor.Contravariant.Divisible (chosen) +-- >>> getPredicate (unId (chosen (Id (Predicate even)) (Id (Predicate (> 0))))) (Left 4) +-- True +-- +-- >>> getPredicate (unId (chosen (Id (Predicate even)) (Id (Predicate (> 0))))) (Right 0) +-- False +instance (Decidable f) => Decidable (Id f) where + choose f (Id x) (Id y) = + Id (choose f x y) + lose f = + Id (lose f) + +-- | +-- >>> zero :: Id [] Int +-- Id [] +instance (Plus f) => Plus (Id f) where + zero = + Id zero + +-- | +-- >>> duplicated (Id (Identity 7)) +-- Id (Identity (Id (Identity 7))) +instance (Extend f) => Extend (Id f) where + duplicated (Id x) = + Id (Id <$> duplicated x) + +-- | +-- >>> import Control.Lens (imap) +-- >>> imap (+) (Id [10,20,30]) +-- Id [10,21,32] +instance (FunctorWithIndex i f) => FunctorWithIndex i (Id f) where + imap f (Id x) = + Id (imap f x) + +-- | +-- >>> import Control.Lens (ifoldMap) +-- >>> ifoldMap (\i x -> [(i, x)]) (Id [10,20,30]) +-- [(0,10),(1,20),(2,30)] +instance (FoldableWithIndex i f) => FoldableWithIndex i (Id f) where + ifoldMap f (Id x) = + ifoldMap f x + +-- | +-- >>> import Control.Lens (itraverse) +-- >>> itraverse (\i x -> if i > 1 then Nothing else Just (x * 10)) (Id [1,2,3]) +-- Nothing +-- +-- >>> itraverse (\i x -> if i > 2 then Nothing else Just (x * 10)) (Id [1,2,3]) +-- Just (Id [10,20,30]) +instance (TraversableWithIndex i f) => TraversableWithIndex i (Id f) where + itraverse f (Id x) = + Id <$> itraverse f x + +-- | +-- >>> let x = Id Proxy :: IdProxy Int in x +-- Id Proxy +type IdProxy a = Id Proxy a -type IdB a = +-- | +-- >>> Id (Just 3) :: IdMaybe Int +-- Id (Just 3) +-- +-- >>> Id Nothing :: IdMaybe Int +-- Id Nothing +type IdMaybe a = Id Maybe a -type Id1 a = +-- | +-- >>> Id (Identity 7) :: IdIdentity Int +-- Id (Identity 7) +type IdIdentity a = Id Identity a +-- | +-- >>> Id (Left "err") :: IdEither String Int +-- Id (Left "err") +-- +-- >>> Id (Right 7) :: IdEither String Int +-- Id (Right 7) +type IdEither e a = + Id (Either e) a + +-- | +-- >>> Id ("log", 7) :: IdWriter String Int +-- Id ("log",7) +type IdWriter w a = + Id ((,) w) a + +-- | +-- >>> Id [1,2,3] :: IdList Int +-- Id [1,2,3] +-- +-- >>> Id [] :: IdList Int +-- Id [] +type IdList a = + Id [] a + +-- | +-- >>> Id (1 :| [2,3]) :: IdNonEmpty Int +-- Id (1 :| [2,3]) +type IdNonEmpty a = + Id NonEmpty a + +-- | +-- >>> Id (Const "hello") :: IdConst String Int +-- Id (Const "hello") +type IdConst c a = + Id (Const c) a + +-- | +-- >>> Id (Tagged 7) :: IdTagged Bool Int +-- Id (Tagged 7) type IdTagged f a = Id (Tagged f) a -{-# - SPECIALIZE - idTagged :: - Iso - (Id1 a) - (Id1 a') - (IdTagged f a) - (IdTagged f a') +-- | +-- >>> view idTagged (Id (Identity 7)) :: IdTagged Bool Int +-- Id (Tagged 7) +-- +-- >>> view (from idTagged) (Id (Tagged 7) :: IdTagged Bool Int) :: IdIdentity Int +-- Id (Identity 7) +{-# SPECIALIZE idTagged :: + Iso + (IdIdentity a) + (IdIdentity a') + (IdTagged f a) + (IdTagged f a') #-} idTagged :: - Rewrapped (f a) (f a) => + (Rewrapped (f a) (f a)) => Iso (Id f a) - (Id1 a') + (IdIdentity a') (Id (Tagged s) (Unwrapped (f a))) (Id (Tagged s') a') idTagged = iso (over __Wrapped (Tagged . view _Wrapped)) (over __Wrapped (Identity . untag)) -{-# - SPECIALIZE - just :: - Prism - (IdB a) - (IdB a') - (Id1 a) - (Id1 a') +-- | +-- >>> view idProxy (Id Proxy :: IdProxy Int) +-- () +-- +-- >>> set idProxy () (Id Proxy :: IdProxy Int) +-- Id Proxy +idProxy :: + Iso + (IdProxy a) + (IdProxy a') + () + () +idProxy = + iso (const ()) (const (Id Proxy)) + +-- | +-- >>> preview (just :: Prism (IdMaybe Int) (IdMaybe Int) (IdIdentity Int) (IdIdentity Int)) (Id (Just 7)) +-- Just (Id (Identity 7)) +-- +-- >>> preview (just :: Prism (IdMaybe Int) (IdMaybe Int) (IdIdentity Int) (IdIdentity Int)) (Id Nothing) +-- Nothing +-- +-- >>> review (just :: Prism (IdMaybe Int) (IdMaybe Int) (IdIdentity Int) (IdIdentity Int)) (Id (Identity 7)) +-- Id (Just 7) +{-# SPECIALIZE just :: + Prism + (IdMaybe a) + (IdMaybe a') + (IdIdentity a) + (IdIdentity a') #-} just :: - ( - Unwrapped s ~ Maybe (Unwrapped (Unwrapped a)), + ( Unwrapped s ~ Maybe (Unwrapped (Unwrapped a)), Unwrapped t ~ Maybe (Unwrapped (Unwrapped b)), - Rewrapped s t, Rewrapped t s, Rewrapped b a, - Rewrapped a b, Rewrapped (Unwrapped b) (Unwrapped a), + Rewrapped s t, + Rewrapped t s, + Rewrapped b a, + Rewrapped a b, + Rewrapped (Unwrapped b) (Unwrapped a), Rewrapped (Unwrapped a) (Unwrapped b) ) => Prism s t a b just = _Wrapped . _Just . _Unwrapped . _Unwrapped -{-# - SPECIALIZE - rejust :: - Getter - (Id1 a) - (IdB a) +-- | +-- >>> view (rejust :: Getter (IdIdentity Int) (IdMaybe Int)) (Id (Identity 7)) +-- Id (Just 7) +{-# SPECIALIZE rejust :: + Getter + (IdIdentity a) + (IdMaybe a) #-} rejust :: - ( - Unwrapped t ~ Maybe (Unwrapped (Unwrapped b)), Rewrapped t t, - Rewrapped b b, Rewrapped (Unwrapped b) (Unwrapped b) + ( Unwrapped t ~ Maybe (Unwrapped (Unwrapped b)), + Rewrapped t t, + Rewrapped b b, + Rewrapped (Unwrapped b) (Unwrapped b) ) => Getter b t rejust = re just -{-# - SPECIALIZE - nothing :: - Prism - (IdB a) - (IdB a) - (Id1 ()) - (Id1 ()) +-- | +-- >>> preview (nothing :: Prism (IdMaybe Int) (IdMaybe Int) (IdIdentity ()) (IdIdentity ())) (Id Nothing) +-- Just (Id (Identity ())) +-- +-- >>> preview (nothing :: Prism (IdMaybe Int) (IdMaybe Int) (IdIdentity ()) (IdIdentity ())) (Id (Just 7)) +-- Nothing +-- +-- >>> review (nothing :: Prism (IdMaybe Int) (IdMaybe Int) (IdIdentity ()) (IdIdentity ())) (Id (Identity ())) +-- Id Nothing +{-# SPECIALIZE nothing :: + Prism + (IdMaybe a) + (IdMaybe a) + (IdIdentity ()) + (IdIdentity ()) #-} nothing :: - ( - Unwrapped t ~ Maybe x, Unwrapped s ~ Maybe x, - Unwrapped (Unwrapped a) ~ (), Unwrapped (Unwrapped b) ~ (), - Rewrapped s t, Rewrapped t s, - Rewrapped b a, Rewrapped a b, + ( Unwrapped t ~ Maybe x, + Unwrapped s ~ Maybe x, + Unwrapped (Unwrapped a) ~ (), + Unwrapped (Unwrapped b) ~ (), + Rewrapped s t, + Rewrapped t s, + Rewrapped b a, + Rewrapped a b, Rewrapped (Unwrapped b) (Unwrapped a), Rewrapped (Unwrapped a) (Unwrapped b) ) => @@ -293,38 +898,21 @@ nothing = _Wrapped . _Nothing . _Unwrapped . _Unwrapped -{-# - SPECIALIZE - renothing :: - Getter - (Id1 ()) - (IdB a) +-- | +-- >>> view (renothing :: Getter (IdIdentity ()) (IdMaybe Int)) (Id (Identity ())) +-- Id Nothing +{-# SPECIALIZE renothing :: + Getter + (IdIdentity ()) + (IdMaybe a) #-} renothing :: - ( - Unwrapped t ~ Maybe x, Unwrapped (Unwrapped a) ~ (), - Rewrapped t t, Rewrapped a a, + ( Unwrapped t ~ Maybe x, + Unwrapped (Unwrapped a) ~ (), + Rewrapped t t, + Rewrapped a a, Rewrapped (Unwrapped a) (Unwrapped a) ) => Getter a t renothing = re nothing - -{-# - SPECIALIZE - id1 :: - Iso - (Id1 a) - (Id1 a') - a - a' - #-} -id1 :: - ( - Rewrapped s t, Rewrapped t s, - Rewrapped (Unwrapped s) (Unwrapped t), - Rewrapped (Unwrapped t) (Unwrapped s) - ) => - Iso s t (Unwrapped (Unwrapped s)) (Unwrapped (Unwrapped t)) -id1 = - _Wrapped . _Wrapped diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} + +module Main where + +import System.Exit (exitWith) +import System.Process (rawSystem) + +main :: IO () +main = + exitWith + =<< rawSystem + "cabal" + [ "repl", + "--with-compiler=doctest", + "--repl-options=-w", + "--repl-options=-Wdefault", + "lib:id" + ]