Created
February 2, 2020 14:19
-
-
Save paolino/749fd5f905a877c0857b87b404370d80 to your computer and use it in GitHub Desktop.
iso based gmappend for records
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE AllowAmbiguousTypes #-} | |
{-# LANGUAGE BlockArguments #-} | |
{-# LANGUAGE DataKinds #-} | |
{-# LANGUAGE FlexibleContexts #-} | |
{-# LANGUAGE MultiParamTypeClasses #-} | |
{-# LANGUAGE RankNTypes #-} | |
{-# LANGUAGE ScopedTypeVariables #-} | |
{-# LANGUAGE TemplateHaskell #-} | |
{-# LANGUAGE TypeApplications #-} | |
{-# LANGUAGE TypeFamilies #-} | |
{-# LANGUAGE TypeOperators #-} | |
module GMappend where | |
import Generics.SOP | |
-- for the example | |
import Control.Applicative | |
import Data.Semigroup (Sum (..)) | |
import Generics.SOP.TH | |
-- /for the example | |
type family IsoF a b where | |
IsoF '[] '[] = '[] | |
IsoF (x:xs) (y:ys) = (x -> y, y -> x) : IsoF xs ys | |
class UpOp b c where | |
upOp :: NP I (IsoF b c) -> NP I b -> NP I c | |
instance UpOp '[] '[] | |
where | |
upOp _ _ = Nil | |
instance UpOp xs ys => UpOp (x:xs) (y:ys) | |
where | |
upOp (I (f, _) :* fs) (I x :* xs) = (I $ f x) :* upOp fs xs | |
class DownOp b c where | |
downOp :: NP I (IsoF b c) -> NP I c -> NP I b | |
instance DownOp '[] '[] | |
where | |
downOp _ _ = Nil | |
instance DownOp xs ys => DownOp (x:xs) (y:ys) | |
where | |
downOp (I (_, f) :* fs) (I x :* xs) = (I $ f x) :* downOp fs xs | |
up :: forall a b xs | |
. (UpOp xs b, Generic a, Code a ~ '[xs]) | |
=> NP I (IsoF xs b) | |
-> a | |
-> NP I b | |
up f = upOp f . unZ . unSOP . from | |
down :: forall b a xs | |
. (Generic a, Code a ~ '[xs], DownOp xs b) | |
=> NP I (IsoF xs b) | |
-> NP I b | |
-> a | |
down f = to . SOP . Z . downOp f | |
gmappend :: forall ys a xs | |
. ( Code a ~ '[xs] | |
, UpOp xs ys | |
, DownOp xs ys | |
, Generic a | |
, All Semigroup ys | |
) | |
=> NP I (IsoF xs ys) | |
-> a | |
-> a | |
-> a | |
gmappend dss x y = down @ys dss $ hcliftA2 | |
do Proxy :: Proxy Semigroup | |
do liftA2 (<>) | |
do up dss x | |
do up dss y | |
type Iso a b = I (a -> b, b -> a) | |
(=:=) :: (a -> b) -> (b -> a) -> Iso a b | |
(=:=) = fmap I . (,) | |
noOp :: Iso a a | |
noOp = id =:= id | |
-- example | |
data T = T | |
{ text :: String | |
, num :: Int | |
} deriving (Show) | |
deriveGeneric ''T | |
instance Semigroup T where | |
(<>) = gmappend @'[String, Sum Int] do | |
noOp :* Sum =:= getSum :* Nil | |
mkT :: String -> T | |
mkT x = T x $ Prelude.length x | |
main :: IO () | |
main = print $ mkT "ciao " <> mkT "mamma" |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment