diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for edit + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Varun Gandhi + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Varun Gandhi nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/edit.cabal b/edit.cabal new file mode 100644 --- /dev/null +++ b/edit.cabal @@ -0,0 +1,78 @@ +name: edit +version: 0.0.1.0 +synopsis: A monad for rewriting things. +homepage: https://github.com/theindigamer/edit +license: BSD3 +license-file: LICENSE +author: Varun Gandhi +maintainer: Varun Gandhi +copyright: Varun Gandhi 2018 +category: Data +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 +description: + Edit is a monad for rewriting things. + +source-repository head + type: git + location: https://github.com/theindigamer/edit.git + +flag arbitrary_instance + description: Adds QuickCheck as a dependency to provide an Arbitrary instance. + default: False + manual: True + +flag comonad_instance + description: Adds comonad as a dependency to provide a Comonad instance. + default: False + manual: True + +flag tutorial + description: Build the tutorial. Adds dependencies on uniplate and containers. + default: False + manual: True + +library + exposed-modules: Data.Edit + Data.Edit.Tutorial + Control.Monad.Trans.Edit + build-depends: base >= 4.9 && < 4.12 + , deepseq >= 1.1 && < 1.5 + , transformers >= 0.5 && < 0.6 + ghc-options: -Wall + -Wincomplete-uni-patterns + -Wnoncanonical-monad-instances + -Wnoncanonical-monoid-instances + -Wcompat + hs-source-dirs: src + default-language: Haskell2010 + if flag(arbitrary_instance) + CPP-options: -DWITH_ARBITRARY_INSTANCE + build-depends: QuickCheck >= 2.10 && < 2.12 + if flag(comonad_instance) + CPP-options: -DWITH_COMONAD_INSTANCE + build-depends: comonad + if flag(tutorial) + CPP-options: -DTUTORIAL + build-depends: uniplate >= 1.6 && < 1.7 + , containers >= 0.5.8.1 && < 0.5.12 + +test-suite test-edit + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Driver.hs + other-modules: Data.EditSpec + Control.Monad.Trans.EditSpec + build-Depends: base + , edit + , doctest >= 0.13 && < 0.15 + , QuickCheck >= 2.10 && < 2.12 + , uniplate >= 1.6 && < 1.7 + , comonad >= 5.0 && < 5.1 + , tasty >= 1.0 && < 1.1 + , tasty-discover >= 4.2 && < 4.3 + , tasty-quickcheck >= 0.9 && < 0.10 + ghc-options: -Wall -threaded + default-language: Haskell2010 + diff --git a/src/Control/Monad/Trans/Edit.hs b/src/Control/Monad/Trans/Edit.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/Edit.hs @@ -0,0 +1,100 @@ +-- | +-- Module : Data.Edit +-- Copyright : (c) Varun Gandhi 2018 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : theindigamer15@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- A monad/comonad transformer for the 'Edit' monad. +-- +-- I'm not entirely sure what this might be useful for, but it is provided for +-- the sake of completeness. If you find a concrete use case for it, please +-- submit a PR on Github to fix this section! + +{-# LANGUAGE CPP #-} + +module Control.Monad.Trans.Edit where + +import Control.Applicative (liftA2) +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Zip +import Data.Edit +import Data.Functor.Classes + +#if defined(WITH_COMONAD_INSTANCE) +import Control.Comonad +import Control.Comonad.Trans.Class +#endif + +newtype EditT m a = EditT { runEditT :: m (Edit a) } + +instance Eq1 m => Eq1 (EditT m) where + liftEq eq (EditT x) (EditT y) = liftEq (liftEq eq) x y + +instance Show1 m => Show1 (EditT m) where + liftShowsPrec sp sl d (EditT m) = + showsUnaryWith (liftShowsPrec sp' sl') "EditT" d m + where + sp' = liftShowsPrec sp sl + sl' = liftShowList sp sl + +instance Read1 m => Read1 (EditT m) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "EditT" EditT + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl + +instance (Eq1 m, Eq a) => Eq (EditT m a) where (==) = eq1 +instance (Read1 m, Read a) => Read (EditT m a) where readsPrec = readsPrec1 +instance (Show1 m, Show a) => Show (EditT m a) where showsPrec = showsPrec1 + +mapEditT :: (m (Edit a) -> n (Edit b)) -> EditT m a -> EditT n b +mapEditT f = EditT . f . runEditT + +instance Functor m => Functor (EditT m) where + fmap f = mapEditT (fmap (fmap f)) + +instance Applicative m => Applicative (EditT m) where + pure = EditT . pure . Clean + EditT mf <*> EditT mx = EditT $ liftA2 (<*>) mf mx + +instance Monad m => Monad (EditT m) where + return = pure + EditT x >>= f = EditT $ do + v <- x + case v of + Dirty y -> dirty <$> runEditT (f y) + Clean y -> runEditT (f y) + +instance MonadTrans EditT where + lift = EditT . fmap Clean + +instance MonadIO m => MonadIO (EditT m) where + liftIO = lift . liftIO + +instance MonadZip m => MonadZip (EditT m) where + mzip (EditT x) (EditT y) = EditT (liftA2 mzip x y) + +instance Foldable f => Foldable (EditT f) where + foldMap f (EditT a) = foldMap (foldMap f) a + +instance Traversable f => Traversable (EditT f) where + traverse f (EditT a) = EditT <$> traverse (traverse f) a + +#if defined(WITH_COMONAD_INSTANCE) +instance Comonad c => Comonad (EditT c) where + extract = extract . extract . runEditT + duplicate (EditT cex) = EditT ceEcex + where + ef = case extract cex of + Dirty _ -> Dirty + Clean _ -> Clean + ceEcex = fmap (ef . EditT) (duplicate cex) + +instance ComonadTrans EditT where + lower = fmap extract . runEditT +#endif diff --git a/src/Data/Edit.hs b/src/Data/Edit.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edit.hs @@ -0,0 +1,345 @@ +-- | +-- Module : Data.Edit +-- Copyright : (c) Varun Gandhi 2018 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : theindigamer15@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- The 'Edit' type for working with rewriting systems, with associated +-- operations. +-- +-- To see a high-level overview of some use cases and a detailed example, +-- check the "Data.Edit.Tutorial" module. +-- +-- __Usage notes:__ +-- +-- 1. You probably want to import this module qualified to avoid a name +-- collision with "Data.Maybe"'s 'Data.Maybe.fromMaybe'. +-- 2. We re-export the composition operators from "Control.Monad" for +-- convenience. + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Data.Edit + ( + -- * Edit type and basic operations + Edit (..) + , fromEdit + , isClean + , isDirty + , extract + , duplicate + , extend + -- * Conversions to and from base types + , toMaybe + , fromMaybe + , edits + , toEither + , fromEither + -- * Finding a fixed point + , polish + , iterations + -- * Operations with lists + , partitionEdits + -- * Forceful conversions + , clean + , dirty + -- * Re-exports from "Control.Monad" + , (>=>) + , (<=<) + ) + where + +#define MONOID_SUPERCLASS_OF_SEMIGROUP MIN_VERSION_base(4,11,0) +#define SEMIGROUP_EXPORTED_FROM_PRELUDE MIN_VERSION_base(4,11,0) +#define LIFTREADPREC_IN_READ1 MIN_VERSION_base(4,10,0) + +import Control.Applicative +import Control.DeepSeq (NFData) +import Control.Monad ((>=>), (<=<), ap) +import Control.Monad.Zip (MonadZip (..)) +import Data.Data (Typeable, Data) +import Data.Either (partitionEithers) +import Data.List (unfoldr) +import Data.Functor.Classes +import GHC.Generics (Generic) + +#ifdef WITH_COMONAD_INSTANCE +import Control.Comonad +#endif +#if !SEMIGROUP_EXPORTED_FROM_PRELUDE +import Data.Semigroup (Semigroup (..)) +#endif +#ifdef WITH_ARBITRARY_INSTANCE +import Test.QuickCheck (Arbitrary (..), Arbitrary1 (..) + , frequency, arbitrary1, shrink1) +#endif + +-- | The 'Edit' type encapsulates rewriting. +-- +-- Since 'Edit' is also a monad, it allows you to easily "bubble up" information +-- on whether changes were made when working with nested data structures. This +-- is helpful when you want to save the fact that you've reaching a fixed point +-- while rewriting, instead of, say re-computing it after the fact using an 'Eq' +-- instance on the underlying data-type. +-- +-- For example, +-- +-- >>> halveEvens x = if x `mod` 2 == 0 then (Dirty $ x `div` 2) else (Clean x) +-- >>> traverse halveEvens [1, 2, 3] +-- Dirty [1,1,3] +-- >>> traverse halveEvens [1, 3, 5] +-- Clean [1,3,5] +-- +-- To support this behaviour, the 'Applicative' and 'Monad' instances have +-- "polluting" semantics: +-- +-- 1. 'pure' = 'Clean' = 'return'. +-- 2. The result of '<*>' is 'Clean' if and only if both the arguments are +-- 'Clean'. +-- 3. If you bind a 'Clean' value, you may get anything depending on the +-- function involved. However, if you bind a 'Dirty' value, you will +-- definitely get a 'Dirty' value back. +-- +-- If you're familiar with the Writer monad, 'Edit' is equivalent to +-- a Writer monad where @w@ is isomorphic to 'Bool' with @(<>) = (||)@. +-- +-- If you like comonads, you can use the @comonad_instance@ package flag to, +-- erm, get a legit +-- +-- instance, instead of just having the 'extract', 'duplicate' and 'extend' +-- functions. + +data Edit a + = Dirty a -- ^ A value that has been modified. + | Clean a -- ^ A value that has not been modified. + deriving + ( Eq, Show, Read + , Functor, Foldable, Traversable + , Generic, NFData, Typeable, Data + ) + +instance Applicative Edit where + pure = Clean + (<*>) = ap + +instance Monad Edit where + return = pure + Clean x >>= f = f x + Dirty x >>= f = dirty (f x) + +instance Semigroup a => Semigroup (Edit a) where + (<>) = liftA2 (<>) + +#if MONOID_SUPERCLASS_OF_SEMIGROUP +instance Monoid a => Monoid (Edit a) where +#else +instance (Semigroup a, Monoid a) => Monoid (Edit a) where +#endif + mempty = Clean mempty + mappend = (<>) + +instance MonadZip Edit where + mzip = liftA2 (,) + +-- These instances have been adapted from Maybe's instances. +instance Eq1 Edit where + liftEq eq ex ey = eq (extract ex) (extract ey) + +instance Show1 Edit where + liftShowsPrec sp _ d (Clean x) = showsUnaryWith sp "Clean" d x + liftShowsPrec sp _ d (Dirty x) = showsUnaryWith sp "Dirty" d x + +-- Mimicking Maybe's Read1 instance. +#if LIFTREADPREC_IN_READ1 +instance Read1 Edit where + liftReadPrec rp _ = + readData (readUnaryWith rp "Clean" Clean) + <|> readData (readUnaryWith rp "Dirty" Dirty) +#else +instance Read1 Edit where + liftReadsPrec rp _ d = + readsData (readsUnaryWith rp "Clean" Clean) d + `mappend` readsData (readsUnaryWith rp "Dirty" Dirty) d +#endif + +#if defined(WITH_ARBITRARY_INSTANCE) +instance Arbitrary1 Edit where + liftArbitrary arb = frequency [(1, Clean <$> arb), (4, Dirty <$> arb)] + + liftShrink shr (Dirty x) = Clean x : liftShrink shr (Clean x) ++ [Dirty x' | x' <- shr x] + liftShrink shr (Clean x) = [Clean x' | x' <- shr x] + +-- | 'arbitrary' is biased towards producing more 'Dirty' values. 'shrink' +-- shrinks the generator towards 'Clean' values. +instance Arbitrary a => Arbitrary (Edit a) where + arbitrary = arbitrary1 + shrink = shrink1 +#endif + +-- | Forcibly make the value 'Clean'. +-- You probably do not want to use this function unless you're implementing +-- some class instance for 'Edit'. +clean :: Edit a -> Edit a +clean = Clean . extract + +-- | Forcibly make the value 'Dirty'. +-- You probably do not want to use this function unless you're implementing +-- some class instance for 'Edit'. +dirty :: Edit a -> Edit a +dirty = Dirty . extract + +-- | Extract the final value after having done some edits. +-- +-- Unlike 'Data.Maybe.Maybe''s 'Data.Maybe.fromMaybe', this function doesn't +-- require a default value for totality as both constructors have a value in +-- them. +fromEdit :: Edit a -> a +fromEdit = \case + Clean x -> x + Dirty x -> x + +-- | Was an edit made (is the value 'Dirty')? If yes, returns 'Just' otherwise +-- 'Nothing'. +-- +-- >>> toMaybe (Clean "Good morning.") +-- Nothing +-- >>> toMaybe (Dirty "Wink, wink.") +-- Just "Wink, wink." +toMaybe :: Edit a -> Maybe a +toMaybe = \case + Clean _ -> Nothing + Dirty x -> Just x + +-- | Takes a clean value and a possibly dirty value and makes an 'Edit'. +-- +-- >>> fromMaybe "Hi" Nothing +-- Clean "Hi" +-- >>> defaultValue = 1000 +-- >>> correctedValue = Just 1024 +-- >>> fromMaybe defaultValue correctedValue +-- Dirty 1024 +fromMaybe :: a -> Maybe a -> Edit a +fromMaybe x = \case + Just y -> Dirty y + Nothing -> Clean x + +-- | Takes a function that may dirty a value, and returns another which +-- saves the default value if no modification is done. +-- +-- @f \`edits\` x == fromMaybe x (f x)@ +edits :: (a -> Maybe a) -> a -> Edit a +edits f x = case f x of + Just y -> Dirty y + Nothing -> Clean x + +-- | A 'Dirty' value becomes a 'Left' and a 'Clean' value becomes a 'Right'. +-- +-- Mnemonic: having things clean is usually the right situation to be in. +toEither :: Edit a -> Either a a +toEither = \case + Dirty x -> Left x + Clean x -> Right x + +-- | A 'Left' value becomes a 'Dirty' and a 'Right' value becomes a 'Clean'. +-- +-- Mnemonic: having things clean is usually the right situation to be in. +fromEither :: Either a a -> Edit a +fromEither = \case + Left x -> Dirty x + Right x -> Clean x + +-- | Return 'True' iff the argument has the form @Clean _@. +isClean :: Edit a -> Bool +isClean = \case + Clean _ -> True + Dirty _ -> False + +-- | Returns 'True' iff the argument has the form @Dirty _@. +isDirty :: Edit a -> Bool +isDirty = \case + Clean _ -> False + Dirty _ -> True + +#if defined(WITH_COMONAD_INSTANCE) +instance Comonad Edit where + extract = fromEdit + duplicate = dup + +instance ComonadApply Edit where + (<@>) = (<*>) + ( @>) = ( *>) + (<@ ) = (<* ) + +#elif 1 +-- | @extract = fromEdit@. Provided purely for aesthetic reasons. +extract :: Edit a -> a +extract = fromEdit + +-- | Wraps the value according to its current status. Like father, like son. +duplicate :: Edit a -> Edit (Edit a) +duplicate = dup + +-- | Keep track of changes while utilizing an extraction map. +-- +-- > extend f = fmap f . duplicate +extend :: (Edit a -> b) -> Edit a -> Edit b +extend f = fmap f . duplicate +#endif + +dup :: Edit a -> Edit (Edit a) +dup = \case + Clean x -> Clean (Clean x) + Dirty x -> Dirty (Dirty x) + +-- | 'Dirty' values are put on the left and 'Clean' values are put on the right. +-- +-- > partitionEdits = partitionEithers . map toEither +partitionEdits :: [Edit a] -> ([a], [a]) +partitionEdits = partitionEithers . map toEither + +-- | Keep editing till the result is 'Clean' (find the fixed point). +-- +-- >>> g x = if x >= 10 then Clean x else Dirty (x + 2) +-- >>> polish g 3 +-- 11 +-- +-- Conceptually, +-- +-- > polish f x = last $ iterations f x +polish :: (a -> Edit a) -> a -> a +polish f x = case f x of + Clean y -> y + Dirty y -> polish f y + +-- | Keep editing till the result is 'Clean', recording iterations. +-- +-- Similar to 'polish' but gets the entire list of arguments tested instead of +-- just the final result. The result is guaranteed to be non-empty because +-- the first element will always be included. If the list is finite, the last +-- element gives a 'Clean' result. +-- +-- >>> g x = if x >= 10 then Clean x else Dirty (x + 2) +-- >>> iterations g 3 +-- [3,5,7,9,11] +-- +-- This can be helpful in debugging your transformation function. For example, +-- +-- @ +-- [ (before, after) +-- | let xs = iterations f start +-- , (before, after) <- zip xs (tail xs) +-- , sanityCheck before && not (sanityCheck after)) +-- ] +-- @ +iterations :: (a -> Edit a) -> a -> [a] +iterations f = unfoldr (fmap g') . Just + where g' y = (y, toMaybe (f y)) diff --git a/src/Data/Edit/Tutorial.hs b/src/Data/Edit/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edit/Tutorial.hs @@ -0,0 +1,486 @@ +-- | +-- Module : Data.Edit +-- Copyright : (c) Varun Gandhi 2018 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : theindigamer15@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- This is a short (?) tutorial describing how you can use the 'Data.Edit' module +-- to help you with writing dataflow analysis code for a compiler. The example +-- is a bit artificial for the sake of relative conciseness -- if you have a +-- better suggestion, or find any mistakes, please let me know on the Github +-- . +-- +{-# LANGUAGE CPP #-} + +#ifdef TUTORIAL +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TupleSections #-} +#endif + +#ifdef TUTORIAL +module Data.Edit.Tutorial + ( -- * TL;DR + -- $tldr + + -- * Setup + -- $setup + + -- * Tutorial + -- + -- $identexpr + -- + -- $ConstFold + -- + -- $ConstFoldTests + -- + -- $Substitute + -- + -- $SubstituteTests + -- + -- $StmtConstProp + -- + -- $ConstFoldPass + -- + -- $ConstPropPass + -- + -- $CombinedPass + -- + -- $CombinedTest + Ident (..) + , Expr (..) + , constFold + , substitute + , Stmt + , constProp + , constFold' + , constFoldPass + , substitute' + , constProp' + , constPropPass + , constFoldAndPropPass + ) + where +#else +module Data.Edit.Tutorial + ( -- * TL;DR + -- $tldr + + -- * Setup + -- $setup + + -- * Tutorial + -- + -- $identexpr + -- + -- $ConstFold + -- + -- $ConstFoldTests + -- + -- $Substitute + -- + -- $SubstituteTests + -- + -- $CombinedPass + -- + -- $CombinedTest + ) + where +#endif + +#ifdef TUTORIAL +import Data.Data +import Data.Edit +import Data.Generics.Uniplate.Data +import Data.List (unfoldr) +import Data.Map (Map) +import qualified Data.Map as Map + +#endif + +{- $tldr +Get a fixed point from applying a sequence of transformations. + +> import Data.Edit (Edit, edits, polish, (>=>)) +> +> mkAwesome1 :: Foo -> Maybe Foo +> ... +> mkAwesomeN :: Foo -> Maybe Foo +> +> mkAwesomeAny :: Foo -> Edit Foo +> mkAwesomeAny +> = foldr (\f acc -> acc >=> (f `edits`)) pure +> [mkAwesome1, ..., mkAwesomeN] +> +> mkAsAwesomeAsPossible :: Foo -> Foo +> mkAsAwesomeAsPossible = polish mkAwesomeAny + +Transform a recursive data structure, keeping track of whether it was changed +or not, and feed the result to some high-level dataflow analysis function. + +> import DataFlowLibrary +> import PlatedLibrary +> import Data.Edit (Edit, edits, toMaybe) +> +> instance FancyPlate Foo where ... +> +> mkAwesome :: Foo -> Maybe Foo +> mkAwesome = ... +> +> mkTotallyAwesome :: Foo -> Edit Foo +> mkTotallyAwesome = transformM (mkAwesome `edits`) +> +> dataFlowAnalysis = dataFlowLibFn (toMaybe . mkTotallyAwesome) +-} + +-- $setup +-- The examples here use the +-- and +-- libraries. +-- If you want to +-- follow along as we proceed, you will want to supply the package flag +-- @tutorial@ and maybe read the docs in your browser. +-- +-- If you're testing inside a @cabal@ sandbox, this can be done using +-- +-- > cabal configure --flags="tutorial" +-- > cabal build +-- > cabal haddock +-- +-- If you're using @stack@, the same can be done using: +-- +-- > stack build --flag=edit:tutorial +-- > stack haddock --flag=edit:tutorial --open edit + +-- $identexpr +-- +-- Let's define a toy language @L@ with 'Int's and addition. +-- +-- > newtype Ident = Ident String +-- > deriving (Show, Eq) +-- > +-- > data Expr +-- > = Val Int +-- > | Var Ident +-- > | Add Expr Expr +-- > deriving (Show, Eq) + +#ifdef TUTORIAL + +newtype Ident = Ident String + deriving (Eq, Ord, Show, Typeable, Data) + +data Expr + = Val Int + | Add Expr Expr + | Var Ident + deriving (Show, Eq, Typeable, Data) + +#endif +-- $ConstFold +-- Q. How would you implement constant folding for the 'Expr' type? +-- +-- (1) Write the recursion by hand. While this is easy enough to do since +-- 'Expr' only has a few constructors, this isn't very practical when you have +-- lots of constructors. The exact point where you recognize that this is a +-- recursive descent into unmaintainability depends on your personal boilerplate +-- threshold. +-- +-- (2) Use recursion schemes and get lost in the unfathomable type errors +-- (I'm half-joking). While this is a reasonable approach, we're not going to +-- follow this here. +-- +-- (3) Use a generics library. For simplicity, we'll be using Uniplate here. +-- The particular functions that are relevant at the moment are 'rewrite' and +-- 'transform'. Let's use 'rewrite'. +-- +-- @ +-- __\{-\# LANGUAGE DeriveDataTypeable \#-\}__ +-- +-- __import Data.Data__ +-- __import Data.Generics.Uniplate.Data__ +-- +-- newtype Ident = Ident String +-- deriving (Show, Eq__, Typeable, Data__) +-- +-- data Expr +-- = Val Int +-- | Var Ident +-- | Add Expr Expr +-- deriving (Show, Eq__, Typeable, Data__) +-- +-- __constFold :: Expr -> Expr__ +-- __constFold e = rewrite go e__ +-- __where__ +-- __go (Add (Val i) (Val j)) = Just (Val (i + j))__ +-- __go _ = Nothing__ +-- @ +#ifdef TUTORIAL + +constFold :: Expr -> Expr +constFold = rewrite go + where + go (Add (Val i) (Val j)) = Just (Val (i + j)) + go _ = Nothing + +#endif +-- $ConstFoldTests +-- Test that the implementation works as expected. +-- +-- >>> two = Add (Val 1) (Val 1) +-- >>> four = Add (Val 2) (Val 2) +-- >>> constFold (Add two four) +-- Val 6 +-- >>> constFold (Add (Var "x") two) +-- Add (Var "x") (Val 2) + +-- $Substitute +-- Let's say we add assignment statements to the language and write a function +-- to do constant propagation. First we add a @substitute@ function. +-- +-- @ +-- __import Data.Map (Map)__ +-- __import qualified Data.Map as Map__ +-- +-- newtype Ident = Ident String +-- deriving (Eq, __Ord,__ Show, Typeable, Data) +-- +-- __substitute :: Map Ident Int -> Expr -> Expr__ +-- __substitute m e = rewrite go e__ +-- __where__ +-- __go (Var x) = Val \<$\> Map.lookup x m__ +-- __go _ = Nothing__ +-- @ +#ifdef TUTORIAL + +substitute :: Map Ident Int -> Expr -> Expr +substitute m = rewrite go + where + go (Var x) = Val <$> Map.lookup x m + go _ = Nothing + +#endif +-- $SubstituteTests +-- Let's test this out. +-- +-- >>> x = Var (Ident "x") +-- >>> quadrupleX = Add x (Add x (Add x x)) +-- >>> m1 = Map.fromList [(Ident "x", 5)] +-- >>> substitute m1 quadrupleX +-- Add (Val 5) (Add (Val 5) (Add (Val 5) (Val 5))) + +-- $StmtConstProp +-- Finally add in statements and a constant propagation function. +-- +-- @ +-- __infix 9 :=__ +-- __data Stmt = Ident := Expr__ +-- __deriving (Show)__ +-- +-- __constProp :: Map Ident Int -> Stmt -> (Map Ident Int, Stmt)__ +-- __constProp map_ (var := expr) = (f map_, var := expr')__ +-- __where__ +-- __expr' = substitute map_ expr__ +-- __f = case expr' of__ +-- __Val x -> Map.insert var x__ +-- ___ -> Map.delete var__ -- delete old entry if var is re-defined +-- @ +-- +-- >>> x = Var (Ident "x") +-- >>> m1 = Map.fromList [(Ident "x", 5)] +-- >>> constProp m1 (Ident "y" := Var (Ident "x")) +-- (fromList [(Ident "x",5),(Ident "y",5)],Ident "y":=Val 5) +#ifdef TUTORIAL +infix 9 := +data Stmt = Ident := Expr + deriving (Show) + +constProp :: Map Ident Int -> Stmt -> (Map Ident Int, Stmt) +constProp map_ (var := expr) = (f map_, var := expr') + where + expr' = substitute map_ expr + f = case expr' of + Val x -> Map.insert var x + _ -> id +#endif + +-- $ConstFoldPass +-- Now let's say we want to write two passes -- one for constant folding, one +-- for constant propagation, and then iterate until no more optimization can be +-- done (yes, this isn't an optimal strategy, but then this tutorial would be +-- even longer :O). +-- +-- However, the 'constFold' function, as it stands, doesn't save the +-- "information" whether it changed something or not. Consequently, we won't +-- be able to tell if we hit the fixed point or not unless we do an equality +-- check (which could be expensive if the expression trees are big). Time to +-- finally use the 'Edit' monad! +-- +-- We can use the 'edits' function, which converts a function @f: a -> Maybe a@ +-- to a function @f' : a -> Edit a@. +-- +-- @ +-- __import Data.Edit__ +-- +-- -- We don't have to alter the core logic here, neat! +-- constFold__'__ :: Expr -> __Edit__ Expr +-- constFold__'__ = __transformM__ (go __\`edits\`__) +-- where +-- go (Add (Val i) (Val j)) = Just (Val (i + j)) +-- go _ = Nothing +-- +-- __constFoldPass :: [Stmt] -> Edit [Stmt]__ +-- __constFoldPass ss = traverse (\\(v := e) -> (v :=) \<$\> constFold' e) ss__ +-- @ +-- +#ifdef TUTORIAL + +constFold' :: Expr -> Edit Expr +constFold' = transformM (go `edits`) + where + go (Add (Val i) (Val j)) = Just (Val (i + j)) + go _ = Nothing + +constFoldPass :: [Stmt] -> Edit [Stmt] +constFoldPass = traverse (\(v := e) -> (v :=) <$> constFold' e) + +#endif +-- $ConstPropPass +-- We also need slightly different versions of 'substitute' and 'constProp'. +-- Here we use the 'extract' function; it has the signature @Edit a -> a@. +-- It is fine to throw away the 'Clean'/'Dirty' information when we are updating +-- the map, because we are only interested in changes to the @Stmt@ and don't +-- care if the @Map@ gets changed or not. +-- +-- @ +-- substitute__'__ :: Map Ident Int -> Expr -> __Edit__ Expr +-- substitute__'__ m e = __transformM__ (go __\`edits\`__) e +-- where +-- go (Var x) = Val \<$\> Map.lookup x m +-- go _ = Nothing +-- +-- constProp__'__ :: Map Ident Int -> Stmt -> (Map Ident Int, __Edit__ Stmt) +-- constProp__'__ map_ (var := expr) = (f map_, (var :=) __\<$\>__ expr') +-- where +-- expr' = substitute__'__ map_ expr +-- f = case __extract__ expr' of +-- Val x -> Map.insert var x +-- _ -> id +-- @ +-- +-- Let's add a top-level function similar to 'constFoldPass'. +-- +-- Note: If you're unfamiliar with 'unfoldr', you can think of it as the +-- opposite of 'foldr'. 'foldr' takes a list and a starting value and +-- collapses it to a single value; 'unfoldr' takes a starting value (often +-- called a seed) and generates a list out of it. +-- +-- @ +-- __import Data.List (unfoldr)__ +-- +-- __constPropPass :: [Stmt] -> Edit [Stmt]__ +-- __constPropPass ss = sequence $ unfoldr go (Map.empty, ss)__ +-- __where__ +-- __go (_, []) = Nothing__ +-- __go (m, x:xs) = let (m', ex) = constProp' m x in Just (ex, (m', xs))__ +-- @ +#ifdef TUTORIAL + +substitute' :: Map Ident Int -> Expr -> Edit Expr +substitute' m e = transformM (go `edits`) e + where + go (Var x) = Val <$> Map.lookup x m + go _ = Nothing + +constProp' :: Map Ident Int -> Stmt -> (Map Ident Int, Edit Stmt) +constProp' map_ (var := expr) = (f map_, (var :=) <$> expr') + where + expr' = substitute' map_ expr + f = case extract expr' of + Val x -> Map.insert var x + _ -> Map.delete var + +constPropPass :: [Stmt] -> Edit [Stmt] +constPropPass ss = sequence $ unfoldr go (Map.empty, ss) + where + go (_, []) = Nothing + go (m, x:xs) = let (m', ex) = constProp' m x in Just (ex, (m', xs)) + +#endif +-- $CombinedPass +-- Finally putting all the pieces together. We can use the 'polish' function +-- to find the fixed point, which (in this case) is a fancy way of saying that +-- we keep iterating until we have a 'Clean' (unchanged) value. +-- +-- @ +-- __constFoldAndPropPass :: [Stmt] -> [Stmt]__ +-- __constFoldAndPropPass = polish (constFoldPass >=> constPropPass)__ +-- @ +#ifdef TUTORIAL + +constFoldAndPropPass :: [Stmt] -> [Stmt] +constFoldAndPropPass = polish (constFoldPass >=> constPropPass) + +#endif +-- $CombinedTest +-- We're not done yet though! We still need to check that this works :P. +-- +-- >>> [w, x, y] = map Ident ["w", "x", "y"] +-- >>> s1 = w := Add (Val 1) (Val 2) +-- >>> s2 = x := Add (Var w) (Var w) +-- >>> s3 = y := Add (Var w) (Add (Val 1) (Var x)) +-- >>> s4 = x := Add (Var y) (Var y) +-- >>> s5 = y := Add (Var w) (Var x) +-- >>> constFoldAndPropPass [s1, s2, s3, s4, s5] +-- [Ident "w" := Val 3,Ident "x" := Val 6,Ident "y" := Val 10,Ident "x" := Val 20,Ident "y" := Val 23] +-- +-- Yup, it works! For fun, let's see the transformation process in action. +-- We can do this using the 'iterations' function. +-- +-- >>> pprint = putStr . unlines . map (unlines . map show) +-- >>> pprint $ iterations (constFoldPass >=> constPropPass) [s1, s2, s3, s4, s5] +-- +-- The output shows the full history, with the final result that we obtained +-- earlier at the end. +-- +-- @ +-- Ident "w" := Add (Val 1) (Val 2) +-- Ident "x" := Add (Var (Ident "w")) (Var (Ident "w")) +-- Ident "y" := Add (Var (Ident "w")) (Add (Val 1) (Var (Ident "x"))) +-- Ident "x" := Add (Var (Ident "y")) (Var (Ident "y")) +-- Ident "y" := Add (Var (Ident "w")) (Var (Ident "x")) +-- +-- Ident "w" := Val 3 +-- Ident "x" := Add (Val 3) (Val 3) +-- Ident "y" := Add (Val 3) (Add (Val 1) (Var (Ident "x"))) +-- Ident "x" := Add (Var (Ident "y")) (Var (Ident "y")) +-- Ident "y" := Add (Val 3) (Var (Ident "x")) +-- +-- Ident "w" := Val 3 +-- Ident "x" := Val 6 +-- Ident "y" := Add (Val 3) (Add (Val 1) (Val 6)) +-- Ident "x" := Add (Var (Ident "y")) (Var (Ident "y")) +-- Ident "y" := Add (Val 3) (Var (Ident "x")) +-- +-- Ident "w" := Val 3 +-- Ident "x" := Val 6 +-- Ident "y" := Val 10 +-- Ident "x" := Add (Val 10) (Val 10) +-- Ident "y" := Add (Val 3) (Var (Ident "x")) +-- +-- Ident "w" := Val 3 +-- Ident "x" := Val 6 +-- Ident "y" := Val 10 +-- Ident "x" := Val 20 +-- Ident "y" := Add (Val 3) (Val 20) +-- +-- Ident "w" := Val 3 +-- Ident "x" := Val 6 +-- Ident "y" := Val 10 +-- Ident "x" := Val 20 +-- Ident "y" := Val 23 +-- @ +-- +-- Fin. diff --git a/tests/Control/Monad/Trans/EditSpec.hs b/tests/Control/Monad/Trans/EditSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Control/Monad/Trans/EditSpec.hs @@ -0,0 +1,6 @@ +module Control.Monad.Trans.EditSpec where + +runTests :: IO () +runTests = do + print "Hello" + pure () diff --git a/tests/Data/EditSpec.hs b/tests/Data/EditSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/EditSpec.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE ViewPatterns #-} + +module Data.EditSpec where + +import Data.Edit +import Test.QuickCheck.Function + +prop_EditApplicativeIdentity :: Edit Int -> Bool +prop_EditApplicativeIdentity v = (pure id <*> v) == v + +prop_EditApplicativeComposition + :: Edit (Fun Int Int) -> Edit (Fun Int Int) -> Edit Int -> Bool +prop_EditApplicativeComposition (fmap apply -> u) (fmap apply -> v) w + = (pure (.) <*> u <*> v <*> w) == (u <*> (v <*> w)) diff --git a/tests/Driver.hs b/tests/Driver.hs new file mode 100644 --- /dev/null +++ b/tests/Driver.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-}