Skip to content

Instantly share code, notes, and snippets.

@paolino
Created February 2, 2020 14:19
Show Gist options
  • Save paolino/749fd5f905a877c0857b87b404370d80 to your computer and use it in GitHub Desktop.
Save paolino/749fd5f905a877c0857b87b404370d80 to your computer and use it in GitHub Desktop.
iso based gmappend for records
{-# 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