hanshoglund/iso-deriving
1
1
Fork 0
mirror of https://github.com/hanshoglund/iso-deriving.git synced 2024-09-19 02:47:54 +03:00
Code Issues Projects Releases Wiki Activity

Run Ormolu

Browse Source
This commit is contained in:
Hans Hoeglund 2020-04-16 14:14:17 +01:00
parent 1234835d8b
commit b4dc23f76e
2 changed files with 88 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

105
Iso/Deriving.hs
View File

@ -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 module Iso.Deriving
( As(..) ( As (..),
, As1(..) As1 (..),
, As2(..) As2 (..),
, Inject(..) Inject (..),
, Project(..) Project (..),
, Isomorphic(..) Isomorphic (..),
) )
where where
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)
@ -19,7 +30,9 @@ import Control.Applicative
import Control.Category import Control.Category
import Data.Bifunctor () import Data.Bifunctor ()
-- import Data.Maybe (catMaybes) -- import Data.Maybe (catMaybes)
import Data.Profunctor (Profunctor(..)) import Data.Profunctor (Profunctor (..))
import Prelude hiding ((.), id)
-- import Control.Arrow (Kleisli(..)) -- import Control.Arrow (Kleisli(..))
-- import Control.Monad.State -- import Control.Monad.State
-- import Data.Functor.Compose -- import Data.Functor.Compose
@ -30,6 +43,7 @@ import Data.Profunctor (Profunctor(..))
-- import Control.Monad.Writer hiding (Product) -- 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 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 type Iso' s a = Iso s s a a
iso :: (s -> a) -> (b -> t) -> Iso s t a b 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@. -- 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@.
@ -55,7 +69,6 @@ newtype As1 f g a = As1 { getAs1 :: g a }
-- 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)
class Inject a b where class Inject a b where
inj :: a -> b inj :: a -> b
@ -73,18 +86,24 @@ class (Inject a b, Project a b) => Isomorphic a b where
isom = iso inj prj isom = iso inj prj
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 $ inj @a @b $ (prj a) + (prj b) (As a) + (As b) =
(As a) - (As b) = As $ inj @a @b $ (prj a) + (prj b)
As $ inj @a @b $ (prj a) - (prj b)
(As a) * (As b) = (As a) - (As b) =
As $ inj @a @b $ (prj a) * (prj b) As $ inj @a @b $ (prj a) - (prj b)
signum (As a) =
As $ inj @a @b $ signum (prj a) (As a) * (As b) =
abs (As a) = As $ inj @a @b $ (prj a) * (prj b)
As $ inj @a @b $ abs (prj a)
fromInteger x = signum (As a) =
As $ inj @a @b $ fromInteger x 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 instance (Isomorphic a b, Eq a) => Eq (As a b) where
As a == As b = prj @a @b a == prj b 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 instance (Isomorphic a b, Monoid a) => Monoid (As a b) where
mempty = As $ inj @a @b mempty 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 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 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) 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) 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
empty = As1 $ inj @(f a) @(g a) $ empty 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) 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 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 (>>=) :: 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 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 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 :: forall a. As2 f g a a
id = As2 $ inj @(f _ _) @(g _ _) $ Control.Category.id @_ @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 (.) :: 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..) As2 f . As2 g =
(prj @(f b c) @(g b c) f) (prj @(f a b) @(g a b) 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
View File

@ -1,30 +1,29 @@
{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Main where module Main where
import Iso.Deriving import Control.Monad.Writer (WriterT (..))
import Data.Monoid (Ap(..), Any(..))
import Data.Coerce (coerce) import Data.Coerce (coerce)
import Control.Monad.Writer (WriterT(..)) import Data.Monoid (Any (..), Ap (..))
import Iso.Deriving
main = pure () -- TODO main = pure () -- TODO
data Point a = Point { x :: a, y :: a } data Point a = Point {x :: a, y :: a}
deriving (Eq, Show, Functor) deriving (Eq, Show, Functor)
deriving
deriving Num (Num)
via (Squared a `As` Point a) via (Squared a `As` Point a)
deriving
deriving (Applicative, Monad) (Applicative, Monad)
via (Squared `As1` Point) via (Squared `As1` Point)
type Squared = Ap ((->) Bool) type Squared = Ap ((->) Bool)
instance Inject (Squared a) (Point a) where 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 instance Project (Squared a) (Point a) where
prj (Point x y) = coerce $ \p -> if not p then x else y 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 data NoneOrMore
= None = -- | No elements
-- ^ No elements None
| OneOrMore | -- | At least one element
-- ^ At least one element OneOrMore
deriving (Semigroup, Monoid) deriving
(Semigroup, Monoid)
via (Any `As` NoneOrMore) via (Any `As` NoneOrMore)
instance Inject Any NoneOrMore where instance Inject Any NoneOrMore where
inj (Any False) = None inj (Any False) = None
inj (Any True) = OneOrMore inj (Any True) = OneOrMore
instance Project Any NoneOrMore where instance Project Any NoneOrMore where
prj None = Any False prj None = Any False
prj OneOrMore = Any True prj OneOrMore = Any True
instance Isomorphic Any NoneOrMore instance Isomorphic Any NoneOrMore
data These a b = This a | That b | These a b data These a b = This a | That b | These a b
deriving stock (Functor) deriving stock (Functor)
deriving (Applicative, Monad) deriving
(Applicative, Monad)
via (TheseMonad a `As1` These a) via (TheseMonad a `As1` These a)
type TheseMonad a = WriterT (Maybe a) (Either 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, Nothing))) = That b
inj (WriterT (Right (b, Just a))) = These a 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)