diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,30 @@ +Copyright (c) 2025 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. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +0.0.0.1 + +* The initial version of id. diff --git a/id.cabal b/id.cabal new file mode 100644 --- /dev/null +++ b/id.cabal @@ -0,0 +1,37 @@ +name: id +version: 0.0.0.1 +synopsis: Id (f a) data type +description: + (f a) data type, with optics and functions for switching the type constructor (f) + . + <> +license: BSD3 +license-file: LICENCE +author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> +maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> +copyright: Copyright (C) 2025 Tony Morris +category: Data +build-type: Simple +extra-source-files: changelog.md +cabal-version: >=1.10 +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 + +source-repository head + type: git + location: git@github.com:system-f/code/id.git + +library + exposed-modules: Data.Id + + build-depends: base >= 4.8 && < 6 + , lens >= 4 && < 6 + , mtl >= 2.2 && < 3 + , semigroupoids + , tagged + , transformers + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Data/Id.hs b/src/Data/Id.hs new file mode 100644 --- /dev/null +++ b/src/Data/Id.hs @@ -0,0 +1,330 @@ +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Id 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(..) ) +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 ) + +newtype Id f a = + Id (f a) + deriving (Eq, Ord, Show) + +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 f (Id x) (Id y) = + liftCompare f x y + +instance Show1 f => Show1 (Id f) where + liftShowsPrec sp l d (Id x) = + ("Id (" <>) . liftShowsPrec sp l d x . (")" <>) + +instance (Id f a ~ x) => + Rewrapped (Id f a') x + +instance Wrapped (Id f a) where + type Unwrapped (Id f a) = + f a + _Wrapped' = + iso (\(Id x) -> x) Id + +__Wrapped :: + Iso + (Id f a) + (Id f' a') + (f a) + (f' a') +__Wrapped = + iso + (\(Id x) -> x) + Id + +class HasId a f a' | a -> f a' where + id' :: + Lens' a (Id f a') + +instance HasId (Id f a') f a' where + id' = + id + +class AsId a f a' | a -> f a' where + _Id :: + Lens' a (Id f a') + +instance AsId (Id f a') f a' where + _Id = + id + +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 mempty + +instance Functor f => Functor (Id f) where + fmap = + over _Wrapped . fmap + +instance Apply f => Apply (Id f) where + Id x <.> Id y = + Id (x <.> y) + +instance Applicative f => Applicative (Id f) where + Id x <*> Id y = + Id (x <*> y) + pure = + Id . pure + +instance Alt f => Alt (Id f) where + Id x Id y = + Id (x y) + +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 x >>- f = + Id (x >>- view _Wrapped . f) + +instance Monad f => Monad (Id f) where + Id x >>= f = + Id (x >>= view _Wrapped . f) + +instance Foldable f => Foldable (Id f) where + foldMap f (Id x) = + foldMap f x + +instance Foldable1 f => Foldable1 (Id f) where + foldMap1 f (Id x) = + foldMap1 f x + +instance Traversable f => Traversable (Id f) where + traverse f (Id x) = + Id <$> traverse f x + +instance Traversable1 f => Traversable1 (Id f) where + traverse1 f (Id x) = + Id <$> traverse1 f x + +instance MonadIO f => MonadIO (Id f) where + liftIO = + Id . liftIO + +instance MonadTrans Id where + lift = + Id + +instance BindTrans Id where + liftB = + Id + +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 + callCC f = + Id (callCC (\k -> view _Wrapped (f (Id . k)))) + +instance MonadReader a f => MonadReader a (Id f) where + ask = + Id ask + local f (Id x) = + Id (local f x) + reader = + Id . reader + +instance MonadWriter a f => MonadWriter a (Id f) where + writer aw = + Id (writer aw) + tell = + Id . tell + listen = + over _Wrapped listen + pass = + over _Wrapped pass + +instance MonadState a f => MonadState a (Id f) where + get = + Id get + put = + Id . put + state = + Id . state + +instance MonadRWS a a a f => MonadRWS a a a (Id f) where + +type Id0 a = + Id Proxy a + +type IdB a = + Id Maybe a + +type Id1 a = + Id Identity a + +type IdTagged f a = + Id (Tagged f) a + +{-# + SPECIALIZE + idTagged :: + Iso + (Id1 a) + (Id1 a') + (IdTagged f a) + (IdTagged f a') + #-} +idTagged :: + Rewrapped (f a) (f a) => + Iso + (Id f a) + (Id1 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') + #-} +just :: + ( + 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 (Unwrapped a) (Unwrapped b) + ) => + Prism s t a b +just = + _Wrapped . _Just . _Unwrapped . _Unwrapped + +{-# + SPECIALIZE + rejust :: + Getter + (Id1 a) + (IdB a) + #-} +rejust :: + ( + 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 ()) + #-} +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, + Rewrapped (Unwrapped b) (Unwrapped a), + Rewrapped (Unwrapped a) (Unwrapped b) + ) => + Prism s t a b +nothing = + _Wrapped . _Nothing . _Unwrapped . _Unwrapped + +{-# + SPECIALIZE + renothing :: + Getter + (Id1 ()) + (IdB a) + #-} +renothing :: + ( + 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