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