git.iko.soy/patch
on f78dd16 help sign in
patch/src/Data/Patch/Class.hs
168 lines 5.7 kB history raw
1{-# LANGUAGE DefaultSignatures #-}
2{-# LANGUAGE DeriveTraversable #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE PolyKinds #-}
6{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeOperators #-}
8-- | The interface for types which represent changes made to other types
9module Data.Patch.Class where
11import Data.Functor.Identity
12import Data.Maybe
13import Data.Semigroup (Semigroup(..))
14import Data.Proxy
15import Data.Type.Equality ((:~:) (..))
17class PatchHet p where
18 type PatchSource p :: *
19 type PatchTarget p :: *
20 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
21 -- 'Nothing'.
22 applyHet
23 :: p
24 -> PatchSource p
25 -> Either (PatchSource p :~: PatchTarget p) (PatchTarget p)
26 default applyHet
27 :: Patch p
28 => p
29 -> PatchSource p
30 -> Either (PatchSource p :~: PatchTarget p) (PatchTarget p)
31 applyHet p a = case apply p a of
32 Nothing -> Left Refl
33 Just a' -> Right a'
35-- | Apply a 'PatchHet'; if it does nothing, return the original value
36applyAlwaysHet :: PatchHet p => p -> PatchSource p -> PatchTarget p
37applyAlwaysHet p t = case applyHet p t of
38 Left Refl -> t
39 Right t' -> t'
41-- | A 'Patch' type represents a kind of change made to a datastructure.
42--
43-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey
44-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
45class ( PatchHet p
46 , PatchSource p ~ PatchTarget p
47 ) => Patch p where
48 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
49 -- 'Nothing'.
50 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
52-- | Apply a 'Patch'; if it does nothing, return the original value
53applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
54applyAlways p t = fromMaybe t $ apply p t
56-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
57instance PatchHet (Identity a) where
58 type PatchSource (Identity a) = a
59 type PatchTarget (Identity a) = a
60instance Patch (Identity a) where
61 apply (Identity a) _ = Just a
63-- | 'Proxy' can be used as a 'Patch' that always fully replaces the value
64instance PatchHet (Proxy (a :: *)) where
65 type PatchSource (Proxy a) = a
66 type PatchTarget (Proxy a) = a
67instance Patch (Proxy (a :: *)) where
68 apply ~Proxy _ = Nothing
70-- | Like '(.)', but composes functions that return patches rather than
71-- functions that return new values. The Semigroup instance for patches must
72-- apply patches right-to-left, like '(.)'.
73composePatchFunctions
74 :: (Patch p, Semigroup p)
75 => (PatchTarget p -> p)
76 -> (PatchTarget p -> p)
77 -> PatchTarget p -> p
78composePatchFunctions g f a =
79 let fp = f a
80 in g (applyAlways fp a) <> fp
83class PatchHet2Base (p :: k -> k -> *) where
84 type PatchSource1 p :: k -> *
85 type PatchTarget1 p :: k -> *
87class ( PatchHet2Base p
88 , PatchHet (p from to)
89 , PatchSource1 p from ~ PatchSource (p from to)
90 , PatchTarget1 p to ~ PatchTarget (p from to)
91 ) => PatchHet2Locally (p :: k -> k -> *) from to where
92instance ( PatchHet2Base p
93 , PatchHet (p from to)
94 , PatchSource1 p from ~ PatchSource (p from to)
95 , PatchTarget1 p to ~ PatchTarget (p from to)
96 ) => PatchHet2Locally (p :: k -> k -> *) from to where
98applyHet2Locally
99 :: PatchHet2Locally p from to
100 => p from to
101 -> PatchSource1 p from
102 -> Either (PatchSource1 p from :~: PatchTarget1 p to) (PatchTarget1 p to)
103applyHet2Locally = applyHet
105applyAlwaysHet2Locally
106 :: PatchHet2Locally p from to
107 => p from to
108 -> PatchSource1 p from
109 -> PatchTarget1 p to
110applyAlwaysHet2Locally = applyAlwaysHet
112-- TODO once we can use quantified constraints, perhaps combine PatchHet2Base and
113-- PatchHet2Locally, or at least get rid of this.
114class PatchHet2Base p => PatchHet2 (p :: k -> k -> *) where
115 applyHet2
116 :: p from to
117 -> PatchSource1 p from
118 -> Either (PatchSource1 p from :~: PatchTarget1 p to) (PatchTarget1 p to)
120applyAlwaysHet2
121 :: PatchHet2 p
122 => p from to
123 -> PatchSource1 p from
124 -> PatchTarget1 p to
125applyAlwaysHet2 p t = case applyHet2 p t of
126 Left Refl -> t
127 Right t' -> t'
129-- | Connect the classes without quanitified constraints
130newtype ProjectLocal p from to = ProjectLocal { unProjectLocal :: p from to }
132instance PatchHet2 p => PatchHet (ProjectLocal p from to) where
133 type PatchSource (ProjectLocal p from to) = PatchSource1 p from
134 type PatchTarget (ProjectLocal p from to) = PatchTarget1 p to
135 applyHet (ProjectLocal p) src = applyHet2 p src
137instance PatchHet2 p => PatchHet2Base (ProjectLocal p) where
138 type PatchSource1 (ProjectLocal p) = PatchSource1 p
139 type PatchTarget1 (ProjectLocal p) = PatchTarget1 p
141class ( PatchHet2Base p
142 , PatchSource1 p ~ PatchTarget1 p
143 ) => Patch2 p
144instance ( PatchHet2Base p
145 , PatchSource1 p ~ PatchTarget1 p
146 ) => Patch2 p
148newtype Replace2 (t :: k -> *) (a :: k) (b :: k) = Replace2 (t b)
149 deriving ( Show, Read, Eq, Ord
150 , Functor, Foldable, Traversable
151 )
153data Proxy2 t a b = Proxy2
154 deriving ( Show, Read, Eq, Ord
155 , Functor, Foldable, Traversable
156 )
158-- | 'Replace2' can be used as a 'Patch' that always fully replaces the value
159instance PatchHet (Replace2 (t :: k -> *) (from :: k) (to :: k)) where
160 type PatchSource (Replace2 t from to) = t from
161 type PatchTarget (Replace2 t from to) = t to
162 applyHet (Replace2 val) _ = Right val
164-- | 'Proxy2' can be used as a 'Patch' that always does nothing
165instance PatchHet (Proxy2 (t :: k -> *) (a :: k) (a :: k)) where
166 type PatchSource (Proxy2 t a a) = t a
167 type PatchTarget (Proxy2 t a a) = t a
168 applyHet ~Proxy2 _ = Left Refl