mirror of
https://github.com/hanshoglund/iso-deriving.git
synced 2024-11-09 00:06:01 +03:00
Run Ormolu
This commit is contained in:
Hans Hoeglund
parent
1234835d8b
commit
b4dc23f76e
105
Iso/Deriving.hs
105
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)
|
||||
|
||||
48
test/Spec.hs
48
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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user