├── .gitignore ├── ChangeLog.md ├── LICENSE ├── Readme.md ├── Setup.hs ├── edit.cabal ├── src ├── Control │ └── Monad │ │ └── Trans │ │ └── Edit.hs └── Data │ ├── Edit.hs │ └── Edit │ └── Tutorial.hs ├── stack.yaml └── tests ├── Control └── Monad │ └── Trans │ └── EditSpec.hs ├── Data └── EditSpec.hs └── Driver.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | cabal.sandbox.config 4 | cabal.project.local 5 | .cabal-sandbox/ 6 | .stack-work/ 7 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for `edit` 2 | 3 | ## 1.0.1.0 -- 2018-09-03 4 | 5 | * `QuickCheck` version bump. 6 | 7 | ## 1.0.0.0 -- 2018-07-19 8 | 9 | * `QuickCheck` and `comonad` are enabled by default instead of being disabled 10 | by default. The flag names have been changed to reflect this. 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Varun Gandhi 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Varun Gandhi nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | # Edit [![Hackage badge](https://img.shields.io/hackage/v/edit.svg?label=Hackage)](https://hackage.haskell.org/package/edit) [![Stackage badge](https://www.stackage.org/package/edit/badge/nightly?label=Stackage)](https://www.stackage.org/package/edit) 2 | 3 | The `Edit` monad allows you to easily bubble up whether a change was made or 4 | not when rewriting things. Some cases where this can be handy: 5 | 6 | 1. You are making a sequence of transformations on some type and want to keep 7 | track of whether any of them changed it or not. 8 | 2. You are rewriting a recursive type (or a garden of mutually recursive types!) 9 | and want to bubble up information whether something was changed or not. 10 | 11 | For example, Reddit user /u/p__bing [says](https://www.reddit.com/r/haskell/comments/8mrqfy/ann_edit_a_small_package_for_rewriting_things/e00jo8i/?utm_content=permalink&utm_medium=front&utm_source=reddit&utm_name=haskell) 12 | 13 | > [..] I work as an iOS developer and we have this same 14 | > exact idea implemented, as a monad, in Swift, to make our UI updates faster 15 | > (if a change goes through our model layer and comes out Clean, we don’t bother 16 | > touching the UI). 17 | 18 | A small example: 19 | 20 | ```haskell 21 | >>> halveEvens x = if x `mod` 2 == 0 then (Dirty $ x `div` 2) else (Clean x) 22 | >>> traverse halveEvens [1, 2, 3] 23 | Dirty [1,1,3] 24 | >>> traverse halveEvens [1, 3, 5] 25 | Clean [1,3,5] 26 | ``` 27 | 28 | More thorough documentation is available on [Hackage](https://hackage.haskell.org/package/edit) 29 | under the `Data.Edit` module. There is a tutorial too under `Data.Edit.Tutorial`. 30 | 31 | There is also a corresponding monad transformer `EditT` available under 32 | `Control.Monad.Trans.EditT`. 33 | 34 | # Contributing 35 | 36 | Please open an issue on the Github issue tracker to discuss missing documentation, 37 | API changes etc. 38 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /edit.cabal: -------------------------------------------------------------------------------- 1 | name: edit 2 | version: 1.0.1.0 3 | synopsis: A monad for rewriting things. 4 | homepage: https://github.com/theindigamer/edit 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Varun Gandhi 8 | maintainer: Varun Gandhi 9 | copyright: Varun Gandhi 2018 10 | category: Data 11 | build-type: Simple 12 | extra-source-files: ChangeLog.md, Readme.md 13 | cabal-version: >=1.10 14 | description: 15 | Edit is a monad for rewriting things. 16 | 17 | source-repository head 18 | type: git 19 | location: https://github.com/theindigamer/edit.git 20 | 21 | flag no_arbitrary 22 | description: Removes QuickCheck as a dependency (so no Arbitrary instance is provided). 23 | default: False 24 | manual: True 25 | 26 | flag no_comonad 27 | description: Removes comonad as a dependency (so no Comonad instance is provided). 28 | default: False 29 | manual: True 30 | 31 | flag tutorial 32 | description: Build the tutorial. Adds dependencies on uniplate and containers. 33 | default: False 34 | manual: True 35 | 36 | library 37 | exposed-modules: Data.Edit 38 | Data.Edit.Tutorial 39 | Control.Monad.Trans.Edit 40 | build-depends: base >= 4.9 && < 4.12 41 | , deepseq >= 1.1 && < 1.5 42 | , transformers >= 0.5 && < 0.6 43 | ghc-options: -Wall 44 | -Wincomplete-uni-patterns 45 | -Wnoncanonical-monad-instances 46 | -Wnoncanonical-monoid-instances 47 | -Wcompat 48 | hs-source-dirs: src 49 | default-language: Haskell2010 50 | if !flag(no_arbitrary) 51 | CPP-options: -DWITH_ARBITRARY_INSTANCE 52 | build-depends: QuickCheck >= 2.10 && < 2.13 53 | if !flag(no_comonad) 54 | CPP-options: -DWITH_COMONAD_INSTANCE 55 | build-depends: comonad 56 | if flag(tutorial) 57 | CPP-options: -DTUTORIAL 58 | build-depends: uniplate >= 1.6 && < 1.7 59 | , containers >= 0.5.8.1 && < 0.5.12 60 | 61 | test-suite test-edit 62 | type: exitcode-stdio-1.0 63 | hs-source-dirs: tests 64 | main-is: Driver.hs 65 | other-modules: Data.EditSpec 66 | Control.Monad.Trans.EditSpec 67 | build-Depends: base 68 | , edit 69 | , doctest >= 0.13 && < 0.17 70 | , QuickCheck >= 2.10 && < 2.13 71 | , uniplate >= 1.6 && < 1.7 72 | , comonad >= 5.0 && < 5.1 73 | , tasty >= 1.0 && < 1.2 74 | , tasty-discover >= 4.2 && < 4.3 75 | , tasty-quickcheck >= 0.9 && < 0.11 76 | ghc-options: -Wall -threaded 77 | default-language: Haskell2010 78 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/Edit.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Edit 3 | -- Copyright : (c) Varun Gandhi 2018 4 | -- License : BSD-style (see the file LICENSE) 5 | -- 6 | -- Maintainer : theindigamer15@gmail.com 7 | -- Stability : experimental 8 | -- Portability : portable 9 | -- 10 | -- A monad/comonad transformer for the 'Edit' monad. 11 | -- 12 | -- I'm not entirely sure what this might be useful for, but it is provided for 13 | -- the sake of completeness. If you find a concrete use case for it, please 14 | -- submit a PR on Github to fix this section! 15 | 16 | {-# LANGUAGE CPP #-} 17 | 18 | module Control.Monad.Trans.Edit where 19 | 20 | import Control.Applicative (liftA2) 21 | import Control.Monad.IO.Class 22 | import Control.Monad.Trans.Class 23 | import Control.Monad.Zip 24 | import Data.Edit 25 | import Data.Functor.Classes 26 | 27 | #if defined(WITH_COMONAD_INSTANCE) 28 | import Control.Comonad 29 | import Control.Comonad.Trans.Class 30 | #endif 31 | 32 | newtype EditT m a = EditT { runEditT :: m (Edit a) } 33 | 34 | instance Eq1 m => Eq1 (EditT m) where 35 | liftEq eq (EditT x) (EditT y) = liftEq (liftEq eq) x y 36 | 37 | instance Show1 m => Show1 (EditT m) where 38 | liftShowsPrec sp sl d (EditT m) = 39 | showsUnaryWith (liftShowsPrec sp' sl') "EditT" d m 40 | where 41 | sp' = liftShowsPrec sp sl 42 | sl' = liftShowList sp sl 43 | 44 | instance Read1 m => Read1 (EditT m) where 45 | liftReadsPrec rp rl = readsData $ 46 | readsUnaryWith (liftReadsPrec rp' rl') "EditT" EditT 47 | where 48 | rp' = liftReadsPrec rp rl 49 | rl' = liftReadList rp rl 50 | 51 | instance (Eq1 m, Eq a) => Eq (EditT m a) where (==) = eq1 52 | instance (Read1 m, Read a) => Read (EditT m a) where readsPrec = readsPrec1 53 | instance (Show1 m, Show a) => Show (EditT m a) where showsPrec = showsPrec1 54 | 55 | mapEditT :: (m (Edit a) -> n (Edit b)) -> EditT m a -> EditT n b 56 | mapEditT f = EditT . f . runEditT 57 | 58 | instance Functor m => Functor (EditT m) where 59 | fmap f = mapEditT (fmap (fmap f)) 60 | 61 | instance Applicative m => Applicative (EditT m) where 62 | pure = EditT . pure . Clean 63 | EditT mf <*> EditT mx = EditT $ liftA2 (<*>) mf mx 64 | 65 | instance Monad m => Monad (EditT m) where 66 | return = pure 67 | EditT x >>= f = EditT $ do 68 | v <- x 69 | case v of 70 | Dirty y -> dirty <$> runEditT (f y) 71 | Clean y -> runEditT (f y) 72 | 73 | instance MonadTrans EditT where 74 | lift = EditT . fmap Clean 75 | 76 | instance MonadIO m => MonadIO (EditT m) where 77 | liftIO = lift . liftIO 78 | 79 | instance MonadZip m => MonadZip (EditT m) where 80 | mzip (EditT x) (EditT y) = EditT (liftA2 mzip x y) 81 | 82 | instance Foldable f => Foldable (EditT f) where 83 | foldMap f (EditT a) = foldMap (foldMap f) a 84 | 85 | instance Traversable f => Traversable (EditT f) where 86 | traverse f (EditT a) = EditT <$> traverse (traverse f) a 87 | 88 | #if defined(WITH_COMONAD_INSTANCE) 89 | instance Comonad c => Comonad (EditT c) where 90 | extract = extract . extract . runEditT 91 | duplicate (EditT cex) = EditT ceEcex 92 | where 93 | ef = case extract cex of 94 | Dirty _ -> Dirty 95 | Clean _ -> Clean 96 | ceEcex = fmap (ef . EditT) (duplicate cex) 97 | 98 | instance ComonadTrans EditT where 99 | lower = fmap extract . runEditT 100 | #endif 101 | -------------------------------------------------------------------------------- /src/Data/Edit.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Edit 3 | -- Copyright : (c) Varun Gandhi 2018 4 | -- License : BSD-style (see the file LICENSE) 5 | -- 6 | -- Maintainer : theindigamer15@gmail.com 7 | -- Stability : experimental 8 | -- Portability : portable 9 | -- 10 | -- The 'Edit' type for working with rewriting systems, with associated 11 | -- operations. 12 | -- 13 | -- To see a high-level overview of some use cases and a detailed example, 14 | -- check the "Data.Edit.Tutorial" module. 15 | -- 16 | -- __Usage notes:__ 17 | -- 18 | -- 1. You probably want to import this module qualified to avoid a name 19 | -- collision with "Data.Maybe"'s 'Data.Maybe.fromMaybe'. 20 | -- 2. We re-export the composition operators from "Control.Monad" for 21 | -- convenience. 22 | 23 | {-# LANGUAGE LambdaCase #-} 24 | {-# LANGUAGE CPP #-} 25 | {-# LANGUAGE DeriveFunctor #-} 26 | {-# LANGUAGE DeriveTraversable #-} 27 | {-# LANGUAGE DeriveGeneric #-} 28 | {-# LANGUAGE DeriveDataTypeable #-} 29 | {-# LANGUAGE DeriveAnyClass #-} 30 | 31 | module Data.Edit 32 | ( 33 | -- * Edit type and basic operations 34 | Edit (..) 35 | , fromEdit 36 | , isClean 37 | , isDirty 38 | , extract 39 | , duplicate 40 | , extend 41 | -- * Conversions to and from base types 42 | , toMaybe 43 | , fromMaybe 44 | , edits 45 | , toEither 46 | , fromEither 47 | -- * Finding a fixed point 48 | , polish 49 | , iterations 50 | -- * Operations with lists 51 | , partitionEdits 52 | -- * Forceful conversions 53 | , clean 54 | , dirty 55 | -- * Re-exports from "Control.Monad" 56 | , (>=>) 57 | , (<=<) 58 | ) 59 | where 60 | 61 | #define MONOID_SUPERCLASS_OF_SEMIGROUP MIN_VERSION_base(4,11,0) 62 | #define SEMIGROUP_EXPORTED_FROM_PRELUDE MIN_VERSION_base(4,11,0) 63 | #define LIFTREADPREC_IN_READ1 MIN_VERSION_base(4,10,0) 64 | 65 | import Control.Applicative 66 | import Control.DeepSeq (NFData) 67 | import Control.Monad ((>=>), (<=<), ap) 68 | import Control.Monad.Zip (MonadZip (..)) 69 | import Data.Data (Typeable, Data) 70 | import Data.Either (partitionEithers) 71 | import Data.List (unfoldr) 72 | import Data.Functor.Classes 73 | import GHC.Generics (Generic) 74 | 75 | #ifdef WITH_COMONAD_INSTANCE 76 | import Control.Comonad 77 | #endif 78 | #if !SEMIGROUP_EXPORTED_FROM_PRELUDE 79 | import Data.Semigroup (Semigroup (..)) 80 | #endif 81 | #ifdef WITH_ARBITRARY_INSTANCE 82 | import Test.QuickCheck (Arbitrary (..), Arbitrary1 (..) 83 | , frequency, arbitrary1, shrink1) 84 | #endif 85 | 86 | -- | The 'Edit' type encapsulates rewriting. 87 | -- 88 | -- Since 'Edit' is also a monad, it allows you to easily "bubble up" information 89 | -- on whether changes were made when working with nested data structures. This 90 | -- is helpful when you want to save the fact that you've reaching a fixed point 91 | -- while rewriting, instead of, say re-computing it after the fact using an 'Eq' 92 | -- instance on the underlying data-type. 93 | -- 94 | -- For example, 95 | -- 96 | -- >>> halveEvens x = if x `mod` 2 == 0 then (Dirty $ x `div` 2) else (Clean x) 97 | -- >>> traverse halveEvens [1, 2, 3] 98 | -- Dirty [1,1,3] 99 | -- >>> traverse halveEvens [1, 3, 5] 100 | -- Clean [1,3,5] 101 | -- 102 | -- To support this behaviour, the 'Applicative' and 'Monad' instances have 103 | -- "polluting" semantics: 104 | -- 105 | -- 1. 'pure' = 'Clean' = 'return'. 106 | -- 2. The result of '<*>' is 'Clean' if and only if both the arguments are 107 | -- 'Clean'. 108 | -- 3. If you bind a 'Clean' value, you may get anything depending on the 109 | -- function involved. However, if you bind a 'Dirty' value, you will 110 | -- definitely get a 'Dirty' value back. 111 | -- 112 | -- If you're familiar with the Writer monad, 'Edit' is isomorphic to 113 | -- @Writer Any@ ('Data.Monoid.Any' is 'Bool' with @(<>) = (||)@). 114 | 115 | data Edit a 116 | = Dirty a -- ^ A value that has been modified. 117 | | Clean a -- ^ A value that has not been modified. 118 | deriving 119 | ( Eq, Show, Read 120 | , Functor, Foldable, Traversable 121 | , Generic, NFData, Typeable, Data 122 | ) 123 | 124 | instance Applicative Edit where 125 | pure = Clean 126 | (<*>) = ap 127 | 128 | instance Monad Edit where 129 | return = pure 130 | Clean x >>= f = f x 131 | Dirty x >>= f = dirty (f x) 132 | 133 | instance Semigroup a => Semigroup (Edit a) where 134 | (<>) = liftA2 (<>) 135 | 136 | #if MONOID_SUPERCLASS_OF_SEMIGROUP 137 | instance Monoid a => Monoid (Edit a) where 138 | #else 139 | instance (Semigroup a, Monoid a) => Monoid (Edit a) where 140 | #endif 141 | mempty = Clean mempty 142 | mappend = (<>) 143 | 144 | instance MonadZip Edit where 145 | mzip = liftA2 (,) 146 | 147 | -- These instances have been adapted from Maybe's instances. 148 | instance Eq1 Edit where 149 | liftEq eq ex ey = eq (extract ex) (extract ey) 150 | 151 | instance Show1 Edit where 152 | liftShowsPrec sp _ d (Clean x) = showsUnaryWith sp "Clean" d x 153 | liftShowsPrec sp _ d (Dirty x) = showsUnaryWith sp "Dirty" d x 154 | 155 | -- Mimicking Maybe's Read1 instance. 156 | #if LIFTREADPREC_IN_READ1 157 | instance Read1 Edit where 158 | liftReadPrec rp _ = 159 | readData (readUnaryWith rp "Clean" Clean) 160 | <|> readData (readUnaryWith rp "Dirty" Dirty) 161 | #else 162 | instance Read1 Edit where 163 | liftReadsPrec rp _ d = 164 | readsData (readsUnaryWith rp "Clean" Clean) d 165 | `mappend` readsData (readsUnaryWith rp "Dirty" Dirty) d 166 | #endif 167 | 168 | #if defined(WITH_ARBITRARY_INSTANCE) 169 | instance Arbitrary1 Edit where 170 | liftArbitrary arb = frequency [(1, Clean <$> arb), (4, Dirty <$> arb)] 171 | 172 | liftShrink shr (Dirty x) = Clean x : liftShrink shr (Clean x) ++ [Dirty x' | x' <- shr x] 173 | liftShrink shr (Clean x) = [Clean x' | x' <- shr x] 174 | 175 | -- | 'arbitrary' is biased towards producing more 'Dirty' values. 'shrink' 176 | -- shrinks the generator towards 'Clean' values. 177 | instance Arbitrary a => Arbitrary (Edit a) where 178 | arbitrary = arbitrary1 179 | shrink = shrink1 180 | #endif 181 | 182 | -- | Forcibly make the value 'Clean'. 183 | -- You probably do not want to use this function unless you're implementing 184 | -- some class instance for 'Edit'. 185 | clean :: Edit a -> Edit a 186 | clean = Clean . extract 187 | 188 | -- | Forcibly make the value 'Dirty'. 189 | -- You probably do not want to use this function unless you're implementing 190 | -- some class instance for 'Edit'. 191 | dirty :: Edit a -> Edit a 192 | dirty = Dirty . extract 193 | 194 | -- | Extract the final value after having done some edits. 195 | -- 196 | -- Unlike 'Data.Maybe.Maybe''s 'Data.Maybe.fromMaybe', this function doesn't 197 | -- require a default value for totality as both constructors have a value in 198 | -- them. 199 | fromEdit :: Edit a -> a 200 | fromEdit = \case 201 | Clean x -> x 202 | Dirty x -> x 203 | 204 | -- | Was an edit made (is the value 'Dirty')? If yes, returns 'Just' otherwise 205 | -- 'Nothing'. 206 | -- 207 | -- >>> toMaybe (Clean "Good morning.") 208 | -- Nothing 209 | -- >>> toMaybe (Dirty "Wink, wink.") 210 | -- Just "Wink, wink." 211 | toMaybe :: Edit a -> Maybe a 212 | toMaybe = \case 213 | Clean _ -> Nothing 214 | Dirty x -> Just x 215 | 216 | -- | Takes a clean value and a possibly dirty value and makes an 'Edit'. 217 | -- 218 | -- >>> fromMaybe "Hi" Nothing 219 | -- Clean "Hi" 220 | -- >>> defaultValue = 1000 221 | -- >>> correctedValue = Just 1024 222 | -- >>> fromMaybe defaultValue correctedValue 223 | -- Dirty 1024 224 | fromMaybe :: a -> Maybe a -> Edit a 225 | fromMaybe x = \case 226 | Just y -> Dirty y 227 | Nothing -> Clean x 228 | 229 | -- | Takes a function that may dirty a value, and returns another which 230 | -- saves the default value if no modification is done. 231 | -- 232 | -- @f \`edits\` x == fromMaybe x (f x)@ 233 | edits :: (a -> Maybe a) -> a -> Edit a 234 | edits f x = case f x of 235 | Just y -> Dirty y 236 | Nothing -> Clean x 237 | 238 | -- | A 'Dirty' value becomes a 'Left' and a 'Clean' value becomes a 'Right'. 239 | -- 240 | -- Mnemonic: having things clean is usually the right situation to be in. 241 | toEither :: Edit a -> Either a a 242 | toEither = \case 243 | Dirty x -> Left x 244 | Clean x -> Right x 245 | 246 | -- | A 'Left' value becomes a 'Dirty' and a 'Right' value becomes a 'Clean'. 247 | -- 248 | -- Mnemonic: having things clean is usually the right situation to be in. 249 | fromEither :: Either a a -> Edit a 250 | fromEither = \case 251 | Left x -> Dirty x 252 | Right x -> Clean x 253 | 254 | -- | Return 'True' iff the argument has the form @Clean _@. 255 | isClean :: Edit a -> Bool 256 | isClean = \case 257 | Clean _ -> True 258 | Dirty _ -> False 259 | 260 | -- | Returns 'True' iff the argument has the form @Dirty _@. 261 | isDirty :: Edit a -> Bool 262 | isDirty = \case 263 | Clean _ -> False 264 | Dirty _ -> True 265 | 266 | #if defined(WITH_COMONAD_INSTANCE) 267 | instance Comonad Edit where 268 | extract = fromEdit 269 | duplicate = dup 270 | 271 | instance ComonadApply Edit where 272 | (<@>) = (<*>) 273 | ( @>) = ( *>) 274 | (<@ ) = (<* ) 275 | 276 | #elif 1 277 | -- | @extract = fromEdit@. Provided purely for aesthetic reasons. 278 | extract :: Edit a -> a 279 | extract = fromEdit 280 | 281 | -- | Wraps the value according to its current status. Like father, like son. 282 | duplicate :: Edit a -> Edit (Edit a) 283 | duplicate = dup 284 | 285 | -- | Keep track of changes while utilizing an extraction map. 286 | -- 287 | -- > extend f = fmap f . duplicate 288 | extend :: (Edit a -> b) -> Edit a -> Edit b 289 | extend f = fmap f . duplicate 290 | #endif 291 | 292 | dup :: Edit a -> Edit (Edit a) 293 | dup = \case 294 | Clean x -> Clean (Clean x) 295 | Dirty x -> Dirty (Dirty x) 296 | 297 | -- | 'Dirty' values are put on the left and 'Clean' values are put on the right. 298 | -- 299 | -- > partitionEdits = partitionEithers . map toEither 300 | partitionEdits :: [Edit a] -> ([a], [a]) 301 | partitionEdits = partitionEithers . map toEither 302 | 303 | -- | Keep editing till the result is 'Clean' (find the fixed point). 304 | -- 305 | -- >>> g x = if x >= 10 then Clean x else Dirty (x + 2) 306 | -- >>> polish g 3 307 | -- 11 308 | -- 309 | -- Conceptually, 310 | -- 311 | -- > polish f x = last $ iterations f x 312 | polish :: (a -> Edit a) -> a -> a 313 | polish f x = case f x of 314 | Clean y -> y 315 | Dirty y -> polish f y 316 | 317 | -- | Keep editing till the result is 'Clean', recording iterations. 318 | -- 319 | -- Similar to 'polish' but gets the entire list of arguments tested instead of 320 | -- just the final result. The result is guaranteed to be non-empty because 321 | -- the first element will always be included. If the list is finite, the last 322 | -- element gives a 'Clean' result. 323 | -- 324 | -- >>> g x = if x >= 10 then Clean x else Dirty (x + 2) 325 | -- >>> iterations g 3 326 | -- [3,5,7,9,11] 327 | -- 328 | -- This can be helpful in debugging your transformation function. For example, 329 | -- 330 | -- @ 331 | -- [ (before, after) 332 | -- | let xs = iterations f start 333 | -- , (before, after) <- zip xs (tail xs) 334 | -- , sanityCheck before && not (sanityCheck after)) 335 | -- ] 336 | -- @ 337 | iterations :: (a -> Edit a) -> a -> [a] 338 | iterations f = unfoldr (fmap g') . Just 339 | where g' y = (y, toMaybe (f y)) 340 | -------------------------------------------------------------------------------- /src/Data/Edit/Tutorial.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Edit 3 | -- Copyright : (c) Varun Gandhi 2018 4 | -- License : BSD-style (see the file LICENSE) 5 | -- 6 | -- Maintainer : theindigamer15@gmail.com 7 | -- Stability : experimental 8 | -- Portability : portable 9 | -- 10 | -- This is a short (?) tutorial describing how you can use the 'Data.Edit' module 11 | -- to help you with writing dataflow analysis code for a compiler. The example 12 | -- is a bit artificial for the sake of relative conciseness -- if you have a 13 | -- better suggestion, or find any mistakes, please let me know on the Github 14 | -- . 15 | -- 16 | {-# LANGUAGE CPP #-} 17 | 18 | #ifdef TUTORIAL 19 | {-# LANGUAGE DeriveDataTypeable #-} 20 | {-# LANGUAGE TupleSections #-} 21 | #endif 22 | 23 | #ifdef TUTORIAL 24 | module Data.Edit.Tutorial 25 | ( -- * TL;DR 26 | -- $tldr 27 | 28 | -- * Setup 29 | -- $setup 30 | 31 | -- * Tutorial 32 | -- 33 | -- $identexpr 34 | -- 35 | -- $ConstFold 36 | -- 37 | -- $ConstFoldTests 38 | -- 39 | -- $Substitute 40 | -- 41 | -- $SubstituteTests 42 | -- 43 | -- $StmtConstProp 44 | -- 45 | -- $ConstFoldPass 46 | -- 47 | -- $ConstPropPass 48 | -- 49 | -- $CombinedPass 50 | -- 51 | -- $CombinedTest 52 | Ident (..) 53 | , Expr (..) 54 | , constFold 55 | , substitute 56 | , Stmt 57 | , constProp 58 | , constFold' 59 | , constFoldPass 60 | , substitute' 61 | , constProp' 62 | , constPropPass 63 | , constFoldAndPropPass 64 | ) 65 | where 66 | #else 67 | module Data.Edit.Tutorial 68 | ( -- * TL;DR 69 | -- $tldr 70 | 71 | -- * Setup 72 | -- $setup 73 | 74 | -- * Tutorial 75 | -- 76 | -- $identexpr 77 | -- 78 | -- $ConstFold 79 | -- 80 | -- $ConstFoldTests 81 | -- 82 | -- $Substitute 83 | -- 84 | -- $SubstituteTests 85 | -- 86 | -- $CombinedPass 87 | -- 88 | -- $CombinedTest 89 | ) 90 | where 91 | #endif 92 | 93 | #ifdef TUTORIAL 94 | import Data.Data 95 | import Data.Edit 96 | import Data.Generics.Uniplate.Data 97 | import Data.List (unfoldr) 98 | import Data.Map (Map) 99 | import qualified Data.Map as Map 100 | 101 | #endif 102 | 103 | {- $tldr 104 | Get a fixed point from applying a sequence of transformations. 105 | 106 | > import Data.Edit (Edit, edits, polish, (>=>)) 107 | > 108 | > mkAwesome1 :: Foo -> Maybe Foo 109 | > ... 110 | > mkAwesomeN :: Foo -> Maybe Foo 111 | > 112 | > mkAwesomeAny :: Foo -> Edit Foo 113 | > mkAwesomeAny 114 | > = foldr (\f acc -> acc >=> (f `edits`)) pure 115 | > [mkAwesome1, ..., mkAwesomeN] 116 | > 117 | > mkAsAwesomeAsPossible :: Foo -> Foo 118 | > mkAsAwesomeAsPossible = polish mkAwesomeAny 119 | 120 | Transform a recursive data structure, keeping track of whether it was changed 121 | or not, and feed the result to some high-level dataflow analysis function. 122 | 123 | > import DataFlowLibrary 124 | > import PlatedLibrary 125 | > import Data.Edit (Edit, edits, toMaybe) 126 | > 127 | > instance FancyPlate Foo where ... 128 | > 129 | > mkAwesome :: Foo -> Maybe Foo 130 | > mkAwesome = ... 131 | > 132 | > mkTotallyAwesome :: Foo -> Edit Foo 133 | > mkTotallyAwesome = transformM (mkAwesome `edits`) 134 | > 135 | > dataFlowAnalysis = dataFlowLibFn (toMaybe . mkTotallyAwesome) 136 | -} 137 | 138 | -- $setup 139 | -- The examples here use the 140 | -- and 141 | -- libraries. 142 | -- If you want to 143 | -- follow along as we proceed, you will want to supply the package flag 144 | -- @tutorial@ and maybe read the docs in your browser. 145 | -- 146 | -- If you're using @cabal@, this can be done using 147 | -- (tested using @cabal-install@ 2.0.0.1): 148 | -- 149 | -- > cabal new-configure --flags="tutorial" 150 | -- > cabal new-build 151 | -- > cabal new-haddock 152 | -- 153 | -- If you're using @stack@, the same can be done using: 154 | -- 155 | -- > stack build --flag=edit:tutorial 156 | -- > stack haddock --flag=edit:tutorial --open edit 157 | 158 | -- $identexpr 159 | -- 160 | -- Let's define a toy language @L@ with 'Int's and addition. 161 | -- 162 | -- > newtype Ident = Ident String 163 | -- > deriving (Show, Eq) 164 | -- > 165 | -- > data Expr 166 | -- > = Val Int 167 | -- > | Var Ident 168 | -- > | Add Expr Expr 169 | -- > deriving (Show, Eq) 170 | 171 | #ifdef TUTORIAL 172 | 173 | newtype Ident = Ident String 174 | deriving (Eq, Ord, Show, Typeable, Data) 175 | 176 | data Expr 177 | = Val Int 178 | | Add Expr Expr 179 | | Var Ident 180 | deriving (Show, Eq, Typeable, Data) 181 | 182 | #endif 183 | -- $ConstFold 184 | -- Q. How would you implement constant folding for the 'Expr' type? 185 | -- 186 | -- (1) Write the recursion by hand. While this is easy enough to do since 187 | -- 'Expr' only has a few constructors, this isn't very practical when you have 188 | -- lots of constructors. The exact point where you recognize that this is a 189 | -- recursive descent into unmaintainability depends on your personal boilerplate 190 | -- threshold. 191 | -- 192 | -- (2) Use recursion schemes and get lost in the unfathomable type errors 193 | -- (I'm half-joking). While this is a reasonable approach, we're not going to 194 | -- follow this here. 195 | -- 196 | -- (3) Use a generics library. For simplicity, we'll be using Uniplate here. 197 | -- The particular functions that are relevant at the moment are 'rewrite' and 198 | -- 'transform'. Let's use 'rewrite'. 199 | -- 200 | -- @ 201 | -- __\{-\# LANGUAGE DeriveDataTypeable \#-\}__ 202 | -- 203 | -- __import Data.Data__ 204 | -- __import Data.Generics.Uniplate.Data__ 205 | -- 206 | -- newtype Ident = Ident String 207 | -- deriving (Show, Eq__, Typeable, Data__) 208 | -- 209 | -- data Expr 210 | -- = Val Int 211 | -- | Var Ident 212 | -- | Add Expr Expr 213 | -- deriving (Show, Eq__, Typeable, Data__) 214 | -- 215 | -- __constFold :: Expr -> Expr__ 216 | -- __constFold e = rewrite go e__ 217 | -- __where__ 218 | -- __go (Add (Val i) (Val j)) = Just (Val (i + j))__ 219 | -- __go _ = Nothing__ 220 | -- @ 221 | #ifdef TUTORIAL 222 | 223 | constFold :: Expr -> Expr 224 | constFold = rewrite go 225 | where 226 | go (Add (Val i) (Val j)) = Just (Val (i + j)) 227 | go _ = Nothing 228 | 229 | #endif 230 | -- $ConstFoldTests 231 | -- Test that the implementation works as expected. 232 | -- 233 | -- >>> two = Add (Val 1) (Val 1) 234 | -- >>> four = Add (Val 2) (Val 2) 235 | -- >>> constFold (Add two four) 236 | -- Val 6 237 | -- >>> constFold (Add (Var "x") two) 238 | -- Add (Var "x") (Val 2) 239 | 240 | -- $Substitute 241 | -- Let's say we add assignment statements to the language and write a function 242 | -- to do constant propagation. First we add a @substitute@ function. 243 | -- 244 | -- @ 245 | -- __import Data.Map (Map)__ 246 | -- __import qualified Data.Map as Map__ 247 | -- 248 | -- newtype Ident = Ident String 249 | -- deriving (Eq, __Ord,__ Show, Typeable, Data) 250 | -- 251 | -- __substitute :: Map Ident Int -> Expr -> Expr__ 252 | -- __substitute m e = rewrite go e__ 253 | -- __where__ 254 | -- __go (Var x) = Val \<$\> Map.lookup x m__ 255 | -- __go _ = Nothing__ 256 | -- @ 257 | #ifdef TUTORIAL 258 | 259 | substitute :: Map Ident Int -> Expr -> Expr 260 | substitute m = rewrite go 261 | where 262 | go (Var x) = Val <$> Map.lookup x m 263 | go _ = Nothing 264 | 265 | #endif 266 | -- $SubstituteTests 267 | -- Let's test this out. 268 | -- 269 | -- >>> x = Var (Ident "x") 270 | -- >>> quadrupleX = Add x (Add x (Add x x)) 271 | -- >>> m1 = Map.fromList [(Ident "x", 5)] 272 | -- >>> substitute m1 quadrupleX 273 | -- Add (Val 5) (Add (Val 5) (Add (Val 5) (Val 5))) 274 | 275 | -- $StmtConstProp 276 | -- Finally add in statements and a constant propagation function. 277 | -- 278 | -- @ 279 | -- __infix 9 :=__ 280 | -- __data Stmt = Ident := Expr__ 281 | -- __deriving (Show)__ 282 | -- 283 | -- __constProp :: Map Ident Int -> Stmt -> (Map Ident Int, Stmt)__ 284 | -- __constProp map_ (var := expr) = (f map_, var := expr')__ 285 | -- __where__ 286 | -- __expr' = substitute map_ expr__ 287 | -- __f = case expr' of__ 288 | -- __Val x -> Map.insert var x__ 289 | -- ___ -> Map.delete var__ -- delete old entry if var is re-defined 290 | -- @ 291 | -- 292 | -- >>> x = Var (Ident "x") 293 | -- >>> m1 = Map.fromList [(Ident "x", 5)] 294 | -- >>> constProp m1 (Ident "y" := Var (Ident "x")) 295 | -- (fromList [(Ident "x",5),(Ident "y",5)],Ident "y":=Val 5) 296 | #ifdef TUTORIAL 297 | infix 9 := 298 | data Stmt = Ident := Expr 299 | deriving (Show) 300 | 301 | constProp :: Map Ident Int -> Stmt -> (Map Ident Int, Stmt) 302 | constProp map_ (var := expr) = (f map_, var := expr') 303 | where 304 | expr' = substitute map_ expr 305 | f = case expr' of 306 | Val x -> Map.insert var x 307 | _ -> id 308 | #endif 309 | 310 | -- $ConstFoldPass 311 | -- Now let's say we want to write two passes -- one for constant folding, one 312 | -- for constant propagation, and then iterate until no more optimization can be 313 | -- done (yes, this isn't an optimal strategy, but then this tutorial would be 314 | -- even longer :O). 315 | -- 316 | -- However, the 'constFold' function, as it stands, doesn't save the 317 | -- "information" whether it changed something or not. Consequently, we won't 318 | -- be able to tell if we hit the fixed point or not unless we do an equality 319 | -- check (which could be expensive if the expression trees are big). Time to 320 | -- finally use the 'Edit' monad! 321 | -- 322 | -- We can use the 'edits' function, which converts a function @f: a -> Maybe a@ 323 | -- to a function @f' : a -> Edit a@. 324 | -- 325 | -- @ 326 | -- __import Data.Edit__ 327 | -- 328 | -- -- We don't have to alter the core logic here, neat! 329 | -- constFold__'__ :: Expr -> __Edit__ Expr 330 | -- constFold__'__ = __transformM__ (go __\`edits\`__) 331 | -- where 332 | -- go (Add (Val i) (Val j)) = Just (Val (i + j)) 333 | -- go _ = Nothing 334 | -- 335 | -- __constFoldPass :: [Stmt] -> Edit [Stmt]__ 336 | -- __constFoldPass ss = traverse (\\(v := e) -> (v :=) \<$\> constFold' e) ss__ 337 | -- @ 338 | -- 339 | #ifdef TUTORIAL 340 | 341 | constFold' :: Expr -> Edit Expr 342 | constFold' = transformM (go `edits`) 343 | where 344 | go (Add (Val i) (Val j)) = Just (Val (i + j)) 345 | go _ = Nothing 346 | 347 | constFoldPass :: [Stmt] -> Edit [Stmt] 348 | constFoldPass = traverse (\(v := e) -> (v :=) <$> constFold' e) 349 | 350 | #endif 351 | -- $ConstPropPass 352 | -- We also need slightly different versions of 'substitute' and 'constProp'. 353 | -- Here we use the 'extract' function; it has the signature @Edit a -> a@. 354 | -- It is fine to throw away the 'Clean'/'Dirty' information when we are updating 355 | -- the map, because we are only interested in changes to the @Stmt@ and don't 356 | -- care if the @Map@ gets changed or not. 357 | -- 358 | -- @ 359 | -- substitute__'__ :: Map Ident Int -> Expr -> __Edit__ Expr 360 | -- substitute__'__ m e = __transformM__ (go __\`edits\`__) e 361 | -- where 362 | -- go (Var x) = Val \<$\> Map.lookup x m 363 | -- go _ = Nothing 364 | -- 365 | -- constProp__'__ :: Map Ident Int -> Stmt -> (Map Ident Int, __Edit__ Stmt) 366 | -- constProp__'__ map_ (var := expr) = (f map_, (var :=) __\<$\>__ expr') 367 | -- where 368 | -- expr' = substitute__'__ map_ expr 369 | -- f = case __extract__ expr' of 370 | -- Val x -> Map.insert var x 371 | -- _ -> id 372 | -- @ 373 | -- 374 | -- Let's add a top-level function similar to 'constFoldPass'. 375 | -- 376 | -- Note: If you're unfamiliar with 'unfoldr', you can think of it as the 377 | -- opposite of 'foldr'. 'foldr' takes a list and a starting value and 378 | -- collapses it to a single value; 'unfoldr' takes a starting value (often 379 | -- called a seed) and generates a list out of it. 380 | -- 381 | -- @ 382 | -- __import Data.List (unfoldr)__ 383 | -- 384 | -- __constPropPass :: [Stmt] -> Edit [Stmt]__ 385 | -- __constPropPass ss = sequence $ unfoldr go (Map.empty, ss)__ 386 | -- __where__ 387 | -- __go (_, []) = Nothing__ 388 | -- __go (m, x:xs) = let (m', ex) = constProp' m x in Just (ex, (m', xs))__ 389 | -- @ 390 | #ifdef TUTORIAL 391 | 392 | substitute' :: Map Ident Int -> Expr -> Edit Expr 393 | substitute' m e = transformM (go `edits`) e 394 | where 395 | go (Var x) = Val <$> Map.lookup x m 396 | go _ = Nothing 397 | 398 | constProp' :: Map Ident Int -> Stmt -> (Map Ident Int, Edit Stmt) 399 | constProp' map_ (var := expr) = (f map_, (var :=) <$> expr') 400 | where 401 | expr' = substitute' map_ expr 402 | f = case extract expr' of 403 | Val x -> Map.insert var x 404 | _ -> Map.delete var 405 | 406 | constPropPass :: [Stmt] -> Edit [Stmt] 407 | constPropPass ss = sequence $ unfoldr go (Map.empty, ss) 408 | where 409 | go (_, []) = Nothing 410 | go (m, x:xs) = let (m', ex) = constProp' m x in Just (ex, (m', xs)) 411 | 412 | #endif 413 | -- $CombinedPass 414 | -- Finally putting all the pieces together. We can use the 'polish' function 415 | -- to find the fixed point, which (in this case) is a fancy way of saying that 416 | -- we keep iterating until we have a 'Clean' (unchanged) value. 417 | -- 418 | -- @ 419 | -- __constFoldAndPropPass :: [Stmt] -> [Stmt]__ 420 | -- __constFoldAndPropPass = polish (constFoldPass >=> constPropPass)__ 421 | -- @ 422 | #ifdef TUTORIAL 423 | 424 | constFoldAndPropPass :: [Stmt] -> [Stmt] 425 | constFoldAndPropPass = polish (constFoldPass >=> constPropPass) 426 | 427 | #endif 428 | -- $CombinedTest 429 | -- We're not done yet though! We still need to check that this works :P. 430 | -- 431 | -- >>> [w, x, y] = map Ident ["w", "x", "y"] 432 | -- >>> s1 = w := Add (Val 1) (Val 2) 433 | -- >>> s2 = x := Add (Var w) (Var w) 434 | -- >>> s3 = y := Add (Var w) (Add (Val 1) (Var x)) 435 | -- >>> s4 = x := Add (Var y) (Var y) 436 | -- >>> s5 = y := Add (Var w) (Var x) 437 | -- >>> constFoldAndPropPass [s1, s2, s3, s4, s5] 438 | -- [Ident "w" := Val 3,Ident "x" := Val 6,Ident "y" := Val 10,Ident "x" := Val 20,Ident "y" := Val 23] 439 | -- 440 | -- Yup, it works! For fun, let's see the transformation process in action. 441 | -- We can do this using the 'iterations' function. 442 | -- 443 | -- >>> pprint = putStr . unlines . map (unlines . map show) 444 | -- >>> pprint $ iterations (constFoldPass >=> constPropPass) [s1, s2, s3, s4, s5] 445 | -- 446 | -- The output shows the full history, with the final result that we obtained 447 | -- earlier at the end. 448 | -- 449 | -- @ 450 | -- Ident "w" := Add (Val 1) (Val 2) 451 | -- Ident "x" := Add (Var (Ident "w")) (Var (Ident "w")) 452 | -- Ident "y" := Add (Var (Ident "w")) (Add (Val 1) (Var (Ident "x"))) 453 | -- Ident "x" := Add (Var (Ident "y")) (Var (Ident "y")) 454 | -- Ident "y" := Add (Var (Ident "w")) (Var (Ident "x")) 455 | -- 456 | -- Ident "w" := Val 3 457 | -- Ident "x" := Add (Val 3) (Val 3) 458 | -- Ident "y" := Add (Val 3) (Add (Val 1) (Var (Ident "x"))) 459 | -- Ident "x" := Add (Var (Ident "y")) (Var (Ident "y")) 460 | -- Ident "y" := Add (Val 3) (Var (Ident "x")) 461 | -- 462 | -- Ident "w" := Val 3 463 | -- Ident "x" := Val 6 464 | -- Ident "y" := Add (Val 3) (Add (Val 1) (Val 6)) 465 | -- Ident "x" := Add (Var (Ident "y")) (Var (Ident "y")) 466 | -- Ident "y" := Add (Val 3) (Var (Ident "x")) 467 | -- 468 | -- Ident "w" := Val 3 469 | -- Ident "x" := Val 6 470 | -- Ident "y" := Val 10 471 | -- Ident "x" := Add (Val 10) (Val 10) 472 | -- Ident "y" := Add (Val 3) (Var (Ident "x")) 473 | -- 474 | -- Ident "w" := Val 3 475 | -- Ident "x" := Val 6 476 | -- Ident "y" := Val 10 477 | -- Ident "x" := Val 20 478 | -- Ident "y" := Add (Val 3) (Val 20) 479 | -- 480 | -- Ident "w" := Val 3 481 | -- Ident "x" := Val 6 482 | -- Ident "y" := Val 10 483 | -- Ident "x" := Val 20 484 | -- Ident "y" := Val 23 485 | -- @ 486 | -- 487 | -- Fin. 488 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.1 2 | 3 | packages: 4 | - . 5 | -------------------------------------------------------------------------------- /tests/Control/Monad/Trans/EditSpec.hs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Trans.EditSpec where 2 | 3 | runTests :: IO () 4 | runTests = do 5 | print "Hello" 6 | pure () 7 | -------------------------------------------------------------------------------- /tests/Data/EditSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | 3 | module Data.EditSpec where 4 | 5 | import Data.Edit 6 | import Test.QuickCheck.Function 7 | 8 | prop_EditApplicativeIdentity :: Edit Int -> Bool 9 | prop_EditApplicativeIdentity v = (pure id <*> v) == v 10 | 11 | prop_EditApplicativeComposition 12 | :: Edit (Fun Int Int) -> Edit (Fun Int Int) -> Edit Int -> Bool 13 | prop_EditApplicativeComposition (fmap apply -> u) (fmap apply -> v) w 14 | = (pure (.) <*> u <*> v <*> w) == (u <*> (v <*> w)) 15 | -------------------------------------------------------------------------------- /tests/Driver.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF tasty-discover #-} 2 | --------------------------------------------------------------------------------