public
Created

CartesianStore as a zipper.

  • Download Gist
multiplatezipper2.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104
{-# LANGUAGE TypeOperators, RankNTypes, GADTs #-}
 
import Control.Applicative
import Data.Type.Equality
import Control.Monad
import Control.Monad.Free
import Control.Comonad
import Control.Comonad.Trans.Store
import Data.Functor.Identity
import Data.Functor.Compose
 
 
type Plate fam f = forall x. fam x -> x -> f x
 
class EqT fam => Multiplate fam where
multiplate :: Applicative f => Plate fam f -> Plate fam f
 
 
data Zipper fam a where
Unit :: a -> Zipper fam a
Battery :: Zipper fam (b -> a) -> fam b -> b -> Zipper fam a
 
instance Functor (Zipper fam) where
fmap f (Unit a) = Unit (f a)
fmap f (Battery v w b) = Battery (fmap (f .) v) w b
 
instance Applicative (Zipper fam) where
pure = Unit
f <*> Unit a = fmap ($ a) f
f <*> Battery v w b = Battery ((.) <$> f <*> v) w b
 
 
zipperPlate :: Multiplate fam => Plate fam (Zipper fam)
zipperPlate = multiplate (Battery (Unit id))
 
enter :: Multiplate fam => fam a -> a -> Zipper fam a
enter = zipperPlate
 
next :: Zipper fam a -> Zipper fam a
next (Unit a) = Unit a
next (Battery v _ b) = v <*> pure b
 
leave :: Zipper fam a -> a
leave (Unit a) = a
leave (Battery v _ b) = leave (v <*> pure b)
 
get :: Multiplate fam => fam b -> Zipper fam a -> Maybe b
get _ (Unit _) = Nothing
get w (Battery _ w' b) = (\Refl -> b) <$> (w `eqT` w')
 
set :: Multiplate fam => fam b -> b -> Zipper fam a -> Zipper fam a
set w b = modify w (const b)
 
modify :: Multiplate fam => fam b -> (b -> b) -> Zipper fam a -> Zipper fam a
modify _ _ (Unit a) = Unit a
modify w f (Battery v w' b) = Battery v w' (maybe b (\Refl -> f b) (w `eqT` w'))
 
visit :: Multiplate fam => fam a -> (Zipper fam a -> Zipper fam a) -> a -> a
visit w f = leave . f . enter w
 
modVisit :: Multiplate fam => fam b -> (Zipper fam b -> Zipper fam b) -> Zipper fam a -> Zipper fam a
modVisit w = modify w . visit w
 
 
 
data Expr = Con Int
| Add Expr Expr
| Mul Expr Expr
| EVar Var
| Let Decl Expr
deriving (Eq, Show)
 
data Decl = Var := Expr
| Seq Decl Decl
deriving (Eq, Show)
 
type Var = String
 
data Fam a where
Expr :: Fam Expr
Decl :: Fam Decl
 
instance EqT Fam where
 
eqT Expr Expr = Just Refl
eqT Decl Decl = Just Refl
eqT _ _ = Nothing
 
instance Multiplate Fam where
 
multiplate child Expr (Add e1 e2) = Add <$> child Expr e1 <*> child Expr e2
multiplate child Expr (Mul e1 e2) = Mul <$> child Expr e1 <*> child Expr e2
multiplate child Expr (Let d e) = Let <$> child Decl d <*> child Expr e
multiplate _ Expr e = pure e
multiplate child Decl (v := e) = (v :=) <$> child Expr e
multiplate child Decl (Seq d1 d2) = Seq <$> child Decl d1 <*> child Decl d2
 
 
expr1 :: Expr
expr1 = Let ("x" := Con 42) (Let ("y" := Con 1) (Add (EVar "x") (EVar "x")))
 
expr2 :: Expr
expr2 = visit Expr (modVisit Expr (modVisit Decl (set Expr $ Con 2) . next)) expr1

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.