diff --git a/Iso/Deriving.hs b/Iso/Deriving.hs index 5ee4e80..bb26f21 100644 --- a/Iso/Deriving.hs +++ b/Iso/Deriving.hs @@ -1,17 +1,28 @@ -{-# LANGUAGE DerivingVia, RankNTypes, InstanceSigs, TypeOperators, TypeApplications, QuantifiedConstraints, StandaloneDeriving, KindSignatures, PolyKinds, MultiParamTypeClasses, FlexibleInstances, DeriveFunctor, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} - +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module Iso.Deriving -( As(..) -, As1(..) -, As2(..) -, Inject(..) -, Project(..) -, Isomorphic(..) -) + ( As (..), + As1 (..), + As2 (..), + Inject (..), + Project (..), + Isomorphic (..), + ) where -import Prelude hiding ((.), id) -- import Control.Lens (Iso', iso, to, from, view, coerced, enum) -- TODO loose lens dep! -- import Control.Monad.Free -- import Data.Monoid hiding (Product) @@ -19,7 +30,9 @@ import Control.Applicative import Control.Category import Data.Bifunctor () -- import Data.Maybe (catMaybes) -import Data.Profunctor (Profunctor(..)) +import Data.Profunctor (Profunctor (..)) +import Prelude hiding ((.), id) + -- import Control.Arrow (Kleisli(..)) -- import Control.Monad.State -- import Data.Functor.Compose @@ -30,6 +43,7 @@ import Data.Profunctor (Profunctor(..)) -- import Control.Monad.Writer hiding (Product) type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) + type Iso' s a = Iso s s a a iso :: (s -> a) -> (b -> t) -> Iso s t a b @@ -47,7 +61,7 @@ newtype As a b = As b -- Like @As@ for kind @k -> Type@. -- -- type As1 :: k1 -> (k2 -> Type) -> k2 -> Type -newtype As1 f g a = As1 { getAs1 :: g a } +newtype As1 f g a = As1 {getAs1 :: g a} -- | -- Like @As@ for kind @k1 -> k2 -> Type@. @@ -55,7 +69,6 @@ newtype As1 f g a = As1 { getAs1 :: g a } -- type As2 :: k1 -> (k2 -> k3 -> Type) -> k2 -> k3 -> Type newtype As2 f g a b = As2 (g a b) - class Inject a b where inj :: a -> b @@ -73,18 +86,24 @@ class (Inject a b, Project a b) => Isomorphic a b where isom = iso inj prj instance (Isomorphic a b, Num a) => Num (As a b) where - (As a) + (As b) = - As $ inj @a @b $ (prj a) + (prj b) - (As a) - (As b) = - As $ inj @a @b $ (prj a) - (prj b) - (As a) * (As b) = - As $ inj @a @b $ (prj a) * (prj b) - signum (As a) = - As $ inj @a @b $ signum (prj a) - abs (As a) = - As $ inj @a @b $ abs (prj a) - fromInteger x = - As $ inj @a @b $ fromInteger x + + (As a) + (As b) = + As $ inj @a @b $ (prj a) + (prj b) + + (As a) - (As b) = + As $ inj @a @b $ (prj a) - (prj b) + + (As a) * (As b) = + As $ inj @a @b $ (prj a) * (prj b) + + signum (As a) = + As $ inj @a @b $ signum (prj a) + + abs (As a) = + As $ inj @a @b $ abs (prj a) + + fromInteger x = + As $ inj @a @b $ fromInteger x instance (Isomorphic a b, Eq a) => Eq (As a b) where As a == As b = prj @a @b a == prj b @@ -98,35 +117,39 @@ instance (Isomorphic a b, Semigroup a) => Semigroup (As a b) where instance (Isomorphic a b, Monoid a) => Monoid (As a b) where mempty = As $ inj @a @b mempty -instance (forall x . Isomorphic (f x) (g x), Functor f) => Functor (As1 f g) where +instance (forall x. Isomorphic (f x) (g x), Functor f) => Functor (As1 f g) where fmap h (As1 x) = As1 $ inj $ fmap h $ prj @(f _) @(g _) x -instance (forall x . Isomorphic (f x) (g x), Applicative f) => Applicative (As1 f g) where +instance (forall x. Isomorphic (f x) (g x), Applicative f) => Applicative (As1 f g) where + pure x = As1 $ inj @(f _) @(g _) $ pure x - (<*>) :: forall a b . As1 f g (a -> b) -> As1 f g a -> As1 f g b + (<*>) :: forall a b. As1 f g (a -> b) -> As1 f g a -> As1 f g b As1 h <*> As1 x = As1 $ inj @(f b) @(g b) $ (prj @(f (a -> b)) @(g (a -> b)) h) <*> (prj @(f a) @(g a) x) - liftA2 :: forall a b c . (a -> b -> c) -> As1 f g a -> As1 f g b -> As1 f g c + liftA2 :: forall a b c. (a -> b -> c) -> As1 f g a -> As1 f g b -> As1 f g c liftA2 h (As1 x) (As1 y) = As1 $ inj @(f c) @(g c) $ liftA2 h (prj x) (prj y) -instance (forall x . Isomorphic (f x) (g x), Alternative f) => Alternative (As1 f g) where - empty :: forall a . As1 f g a +instance (forall x. Isomorphic (f x) (g x), Alternative f) => Alternative (As1 f g) where + + empty :: forall a. As1 f g a empty = As1 $ inj @(f a) @(g a) $ empty - (<|>) :: forall a . As1 f g a -> As1 f g a -> As1 f g a + (<|>) :: forall a. As1 f g a -> As1 f g a -> As1 f g a As1 h <|> As1 x = As1 $ inj @(f a) @(g a) $ (prj @(f a) @(g a) h) <|> (prj @(f a) @(g a) x) -instance (forall x . Isomorphic (f x) (g x), Monad f) => Monad (As1 f g) where - (>>=) :: forall a b . As1 f g a -> (a -> As1 f g b) -> As1 f g b +instance (forall x. Isomorphic (f x) (g x), Monad f) => Monad (As1 f g) where + (>>=) :: forall a b. As1 f g a -> (a -> As1 f g b) -> As1 f g b As1 k >>= f = As1 $ inj @(f b) @(g b) $ (prj @(f a) @(g a) k) >>= prj . getAs1 . f -instance (forall x y . Isomorphic (f x y) (g x y), Category f) => Category (As2 f g) where - id :: forall a . As2 f g a a +instance (forall x y. Isomorphic (f x y) (g x y), Category f) => Category (As2 f g) where + + id :: forall a. As2 f g a a id = As2 $ inj @(f _ _) @(g _ _) $ Control.Category.id @_ @a - (.) :: forall a b c . As2 f g b c -> As2 f g a b -> As2 f g a c - As2 f . As2 g = As2 $ inj @(f a c) @(g a c) $ (Control.Category..) - (prj @(f b c) @(g b c) f) (prj @(f a b) @(g a b) g) - - + (.) :: forall a b c. As2 f g b c -> As2 f g a b -> As2 f g a c + As2 f . As2 g = + As2 $ inj @(f a c) @(g a c) $ + (Control.Category..) + (prj @(f b c) @(g b c) f) + (prj @(f a b) @(g a b) g) diff --git a/test/Spec.hs b/test/Spec.hs index b11917e..6b1d79c 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,30 +1,29 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} module Main where -import Iso.Deriving -import Data.Monoid (Ap(..), Any(..)) +import Control.Monad.Writer (WriterT (..)) import Data.Coerce (coerce) -import Control.Monad.Writer (WriterT(..)) +import Data.Monoid (Any (..), Ap (..)) +import Iso.Deriving main = pure () -- TODO -data Point a = Point { x :: a, y :: a } +data Point a = Point {x :: a, y :: a} deriving (Eq, Show, Functor) - - deriving Num + deriving + (Num) via (Squared a `As` Point a) - - deriving (Applicative, Monad) + deriving + (Applicative, Monad) via (Squared `As1` Point) - type Squared = Ap ((->) Bool) instance Inject (Squared a) (Point a) where @@ -33,30 +32,31 @@ instance Inject (Squared a) (Point a) where instance Project (Squared a) (Point a) where prj (Point x y) = coerce $ \p -> if not p then x else y -instance Isomorphic (Squared a) (Point a) where - +instance Isomorphic (Squared a) (Point a) data NoneOrMore - = None - -- ^ No elements - | OneOrMore - -- ^ At least one element - deriving (Semigroup, Monoid) + = -- | No elements + None + | -- | At least one element + OneOrMore + deriving + (Semigroup, Monoid) via (Any `As` NoneOrMore) instance Inject Any NoneOrMore where - inj (Any False) = None - inj (Any True) = OneOrMore + inj (Any False) = None + inj (Any True) = OneOrMore instance Project Any NoneOrMore where - prj None = Any False - prj OneOrMore = Any True + prj None = Any False + prj OneOrMore = Any True instance Isomorphic Any NoneOrMore data These a b = This a | That b | These a b deriving stock (Functor) - deriving (Applicative, Monad) + deriving + (Applicative, Monad) via (TheseMonad a `As1` These a) type TheseMonad a = WriterT (Maybe a) (Either a) @@ -71,4 +71,4 @@ instance Inject (TheseMonad a b) (These a b) where inj (WriterT (Right (b, Nothing))) = That b inj (WriterT (Right (b, Just a))) = These a b -instance Isomorphic (TheseMonad a b) (These a b) where +instance Isomorphic (TheseMonad a b) (These a b)