mirror of
https://github.com/hanshoglund/iso-deriving.git
synced 2024-09-19 19:09:44 +03:00
Fix imports + add tests
This commit is contained in:
parent
4c134a3896
commit
ea098b52c3
@ -1,42 +1,56 @@
|
|||||||
|
|
||||||
{-# LANGUAGE DerivingVia, RankNTypes, InstanceSigs, TypeOperators, TypeApplications, QuantifiedConstraints, StandaloneDeriving, KindSignatures, PolyKinds, MultiParamTypeClasses, FlexibleInstances, DeriveFunctor, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
|
{-# LANGUAGE DerivingVia, RankNTypes, InstanceSigs, TypeOperators, TypeApplications, QuantifiedConstraints, StandaloneDeriving, KindSignatures, PolyKinds, MultiParamTypeClasses, FlexibleInstances, DeriveFunctor, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
|
||||||
|
|
||||||
|
|
||||||
|
module Iso.Deriving
|
||||||
|
( As(..)
|
||||||
|
, As1(..)
|
||||||
|
, As2(..)
|
||||||
|
, Isomorphic(..)
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Prelude hiding ((.), id)
|
import Prelude hiding ((.), id)
|
||||||
import Control.Lens (Iso', iso, to, from, view, coerced, enum) -- TODO loose lens dep!
|
-- import Control.Lens (Iso', iso, to, from, view, coerced, enum) -- TODO loose lens dep!
|
||||||
import Control.Monad.Free
|
-- import Control.Monad.Free
|
||||||
import Data.Monoid hiding (Product)
|
-- import Data.Monoid hiding (Product)
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Category
|
import Control.Category
|
||||||
import Data.Maybe (catMaybes)
|
import Data.Bifunctor ()
|
||||||
import Data.Profunctor (Star(..))
|
-- import Data.Maybe (catMaybes)
|
||||||
import Control.Arrow (Kleisli(..))
|
import Data.Profunctor (Profunctor(..))
|
||||||
import Control.Monad.State
|
-- import Control.Arrow (Kleisli(..))
|
||||||
import Data.Functor.Compose
|
-- import Control.Monad.State
|
||||||
import Data.Functor.Product
|
-- import Data.Functor.Compose
|
||||||
import Data.Functor.Const
|
-- import Data.Functor.Product
|
||||||
import Data.Functor.Identity
|
-- import Data.Functor.Const
|
||||||
import Data.Coerce (coerce)
|
-- import Data.Functor.Identity
|
||||||
import Control.Monad.Writer hiding (Product)
|
-- import Data.Coerce (coerce)
|
||||||
|
-- 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
|
||||||
|
iso sa bt = dimap sa (fmap bt)
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- @As a b@ is represented at runtime as @b@, but we know we can in fact
|
-- @As a b@ is represented at runtime as @b@, but we know we can in fact
|
||||||
-- convert it into an @a@ with no loss of information. We can think of it has
|
-- convert it into an @a@ with no loss of information. We can think of it has
|
||||||
-- having a *dual representation* as either @a@ or @b@.
|
-- having a *dual representation* as either @a@ or @b@.
|
||||||
--
|
--
|
||||||
type As1 :: k -> Type -> Type
|
-- type As1 :: k -> Type -> Type
|
||||||
newtype As a b = As b
|
newtype As a b = As b
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- Like @As@ for kind @k -> Type@.
|
-- Like @As@ for kind @k -> Type@.
|
||||||
--
|
--
|
||||||
type As1 :: k1 -> (k2 -> Type) -> k2 -> 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@.
|
-- Like @As@ for kind @k1 -> k2 -> Type@.
|
||||||
--
|
--
|
||||||
type As2 :: k1 -> (k2 -> k3 -> Type) -> k2 -> k3 -> Type
|
-- type As2 :: k1 -> (k2 -> k3 -> Type) -> k2 -> k3 -> Type
|
||||||
newtype As2 f g a b = As2 (g a b)
|
newtype As2 f g a b = As2 (g a b)
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
@ -49,11 +63,9 @@ class Isomorphic a b where
|
|||||||
isom :: Iso' a b
|
isom :: Iso' a b
|
||||||
isom = iso inj prj
|
isom = iso inj prj
|
||||||
|
|
||||||
inj :: Isomorphic a b => a -> b
|
-- TODO superclasses
|
||||||
inj = view isom
|
inj :: a -> b
|
||||||
|
prj :: b -> a
|
||||||
prj :: Isomorphic a b => b -> a
|
|
||||||
prj = view $ from isom
|
|
||||||
|
|
||||||
instance (Isomorphic a b, Num a) => Num (As a b) where
|
instance (Isomorphic a b, Num a) => Num (As a b) where
|
||||||
(As a) + (As b) =
|
(As a) + (As b) =
|
||||||
@ -90,7 +102,8 @@ instance (forall x . Isomorphic (f x) (g x), Applicative f) => Applicative (As1
|
|||||||
(<*>) :: 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)
|
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 h (As1 x) (As1 y) = As1 $ inj $ liftA2 h (prj x) (prj y)
|
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
|
instance (forall x . Isomorphic (f x) (g x), Alternative f) => Alternative (As1 f g) where
|
||||||
empty :: forall a . As1 f g a
|
empty :: forall a . As1 f g a
|
||||||
|
63
test/Spec.hs
Normal file
63
test/Spec.hs
Normal file
@ -0,0 +1,63 @@
|
|||||||
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
|
{-# LANGUAGE DerivingVia #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE TypeSynonymInstances #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
|
||||||
|
module Main where
|
||||||
|
|
||||||
|
import Iso.Deriving
|
||||||
|
import Data.Monoid (Ap(..), Any(..))
|
||||||
|
import Data.Coerce (coerce)
|
||||||
|
import Control.Monad.Writer (WriterT(..))
|
||||||
|
|
||||||
|
main = pure () -- TODO
|
||||||
|
|
||||||
|
data Point a = Point { x :: a, y :: a }
|
||||||
|
deriving (Eq, Show, Functor)
|
||||||
|
|
||||||
|
deriving Num
|
||||||
|
via (Squared a `As` Point a)
|
||||||
|
|
||||||
|
deriving (Applicative, Monad)
|
||||||
|
via (Squared `As1` Point)
|
||||||
|
|
||||||
|
|
||||||
|
type Squared = Ap ((->) Bool)
|
||||||
|
|
||||||
|
instance Isomorphic (Squared a) (Point a) where
|
||||||
|
prj (Point x y) = coerce $ \p -> if not p then x else y
|
||||||
|
inj x = Point (coerce x $ False) (coerce x $ True)
|
||||||
|
|
||||||
|
|
||||||
|
data NoneOrMore
|
||||||
|
= None
|
||||||
|
-- ^ No elements
|
||||||
|
| OneOrMore
|
||||||
|
-- ^ At least one element
|
||||||
|
deriving (Semigroup, Monoid)
|
||||||
|
via (Any `As` NoneOrMore)
|
||||||
|
|
||||||
|
instance Isomorphic Any NoneOrMore where
|
||||||
|
inj (Any False) = None
|
||||||
|
inj (Any True) = OneOrMore
|
||||||
|
prj None = Any False
|
||||||
|
prj OneOrMore = Any True
|
||||||
|
|
||||||
|
data These a b = This a | That b | These a b
|
||||||
|
deriving stock (Functor)
|
||||||
|
deriving (Applicative, Monad)
|
||||||
|
via (TheseMonad a `As1` These a)
|
||||||
|
|
||||||
|
type TheseMonad a = WriterT (Maybe a) (Either a)
|
||||||
|
|
||||||
|
instance Isomorphic (TheseMonad a b) (These a b) where
|
||||||
|
prj (This a) = WriterT (Left a)
|
||||||
|
prj (That b) = WriterT (Right (b, Nothing))
|
||||||
|
prj (These a b) = WriterT (Right (b, Just a))
|
||||||
|
|
||||||
|
inj (WriterT (Left a)) = This a
|
||||||
|
inj (WriterT (Right (b, Nothing))) = That b
|
||||||
|
inj (WriterT (Right (b, Just a))) = These a b
|
Loading…
Reference in New Issue
Block a user