diff --git a/polyplate/Data/Generics/Polyplate.hs b/polyplate/Data/Generics/Polyplate.hs index f17a912..fe20aa8 100644 --- a/polyplate/Data/Generics/Polyplate.hs +++ b/polyplate/Data/Generics/Polyplate.hs @@ -110,9 +110,9 @@ instance (Monad m -- -- So I think there are two classes needed: -- - -- * One to apply monadic transformations that takes routes (covers #5, #2, #1) + -- 1. One to apply monadic transformations that takes routes (covers #5, #2, #1) -- - -- * One to apply tree-based queries that transform a whole data structure into + -- 2. One to apply tree-based queries that transform a whole data structure into -- its tree spine-view, with optional methods for flattening into a depth-first -- or breadth-first order. diff --git a/polyplate/Data/Generics/Polyplate/GenInstances.hs b/polyplate/Data/Generics/Polyplate/GenInstances.hs index af47ba8..c5799c1 100644 --- a/polyplate/Data/Generics/Polyplate/GenInstances.hs +++ b/polyplate/Data/Generics/Polyplate/GenInstances.hs @@ -16,6 +16,18 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . -} +-- | A module containing code to generate instances of the Polyplate classes for +-- you. +-- +-- Generating Polyplate instances by hand would be laborious, complex and error-prone. +-- This module provides a way, based on the Scrap Your Boilerplate ("Data.Generics") +-- generics that have built-in support in GHC. So you should just need to add +-- +-- > deriving (Data, Typeable) +-- +-- after all your data-types, then use the functions in this module to generate +-- some Haskell code with instances of the Polyplate classes. The simplest functions +-- for doing this are 'writeInstances' and 'writeInstancesTo'. module Data.Generics.Polyplate.GenInstances (GenOverlappedOption(..), GenClassOption(..), GenInstance, genInstance, genMapInstance, genSetInstance, genInstances, @@ -31,9 +43,17 @@ import Data.Ord import Data.Set (Set) import qualified Data.Set as Set +-- | The option controlling whether the generated instances can be overlapped. +-- If you choose 'GenWithOverlapped' many less instances (around half, in Tock) +-- will be generated, but you must enable the overlapping-instances flag in GHC +-- (-XOverlappingInstances in GHC 6.8 and 6.10) when compiling the instances. data GenOverlappedOption = GenWithOverlapped | GenWithoutOverlapped deriving (Eq) +-- | The option controlling whether the generated instances have one class per +-- type, or just generate instances of the primary Polyplate class. Having one +-- class per type compiles faster on GHC, but can give less clear error messages +-- due to the name munging that goes on. data GenClassOption = GenClassPerType | GenOneClass @@ -600,7 +620,8 @@ spineInstancesFrom genOverlapped genClass boxes w -- | Generates all the given instances (eliminating any duplicates) --- with the given options. +-- with the given options. The return is a pair of a list of instances of PolyplateMRoute, +-- and a list of instances of PolyplateSpine genInstances :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> IO ([String], [String]) genInstances op1 op2 insts @@ -613,14 +634,16 @@ genInstances op1 op2 insts spineInst' <- sequence spineInst return (concat inst', concat spineInst') -- | Generates the instances according to the options and writes it to stdout with --- the given header. +-- the given header (the header is a list of lines without newline characters). writeInstances :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> [String] -> IO () writeInstances op1 op2 inst header = do (instLines, spineInstLines) <- genInstances op1 op2 inst putStr (unlines (header ++ instLines ++ spineInstLines)) --- | Generates the instances according to the options and writes it to stdout with --- the given header. +-- | Generates the instances according to the options and writes the PolyplateMRoute +-- instances with the first header (the header is a list of lines without newline characters) +-- to the first filename, and the PolyplateSpine instances with the second header +-- to the second filename. writeInstancesToSep :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> ([String], [String]) -> (FilePath, FilePath) -> IO () writeInstancesToSep op1 op2 inst (header1, header2) (fileName1, fileName2) @@ -629,7 +652,7 @@ writeInstancesToSep op1 op2 inst (header1, header2) (fileName1, fileName2) writeFile fileName2 (unlines (header2 ++ spineInstLines)) -- | Generates the instances according to the options and writes it to a file with --- the given header. +-- the given header (the header is a list of lines without newline characters). writeInstancesTo :: GenOverlappedOption -> GenClassOption -> [GenInstance] -> [String] -> FilePath -> IO () writeInstancesTo op1 op2 inst header fileName diff --git a/polyplate/Data/Generics/Polyplate/Schemes.hs b/polyplate/Data/Generics/Polyplate/Schemes.hs index 135fe77..ddd768e 100644 --- a/polyplate/Data/Generics/Polyplate/Schemes.hs +++ b/polyplate/Data/Generics/Polyplate/Schemes.hs @@ -28,38 +28,24 @@ import Data.Generics.Polyplate.Route -- | Given a list of operations and a modifier function, augments that modifier -- function to first descend into the value before then applying the modifier function. -- This can be used to perform a bottom-up depth-first traversal of a structure +-- (see 'applyBottomUp'). +makeBottomUp :: Polyplate t () opT => opT -> (t -> t) -> t -> t +makeBottomUp ops f v = f (makeDescend ops v) + +-- | Given a list of operations and a monadic modifier function, augments that modifier +-- function to first descend into the value before then applying the modifier function. +-- This can be used to perform a bottom-up depth-first traversal of a structure -- (see 'applyBottomUpM'). makeBottomUpM :: PolyplateM t () opT m => opT -> (t -> m t) -> t -> m t makeBottomUpM ops f v = makeDescendM ops v >>= f +-- | As makeBottomUpM, but with routes as well. makeBottomUpMRoute :: PolyplateMRoute t () opT m outer => opT -> ((t, Route t outer) -> m t) -> (t, Route t outer) -> m t makeBottomUpMRoute ops f (v, r) = do v' <- transformMRoute () ops (v, r) f (v', r) - --- | Given a list of operations and a modifier function, augments that modifier --- function to first apply the modifier function before then descending into the value. --- This can be used to perform a top-down depth-first traversal of a structure --- (see 'applyTopDownM'). -makeTopDownM :: PolyplateM t () opT m => opT -> (t -> m t) -> t -> m t -makeTopDownM ops f v = f v >>= makeDescendM ops - -makeTopDownMRoute :: PolyplateMRoute t () opT m outer => - opT -> ((t, Route t outer) -> m t) -> (t, Route t outer) -> m t -makeTopDownMRoute ops f (v, r) - = do v' <- f (v, r) - transformMRoute () ops (v', r) - - --- | Given a list of operations and a modifier function, augments that modifier --- function to first descend into the value before then applying the modifier function. --- This can be used to perform a bottom-up depth-first traversal of a structure --- (see 'applyBottomUp'). -makeBottomUp :: Polyplate t () opT => opT -> (t -> t) -> t -> t -makeBottomUp ops f v = f (makeDescend ops v) - -- | Given a list of operations and a modifier function, augments that modifier -- function to first apply the modifier function before then descending into the value. -- This can be used to perform a top-down depth-first traversal of a structure @@ -67,6 +53,21 @@ makeBottomUp ops f v = f (makeDescend ops v) makeTopDown :: Polyplate t () opT => opT -> (t -> t) -> t -> t makeTopDown ops f v = makeDescend ops (f v) +-- | Given a list of operations and a monadic modifier function, augments that modifier +-- function to first apply the modifier function before then descending into the value. +-- This can be used to perform a top-down depth-first traversal of a structure +-- (see 'applyTopDownM'). +makeTopDownM :: PolyplateM t () opT m => opT -> (t -> m t) -> t -> m t +makeTopDownM ops f v = f v >>= makeDescendM ops + +-- | As makeTopDownM, but with routes as well. +makeTopDownMRoute :: PolyplateMRoute t () opT m outer => + opT -> ((t, Route t outer) -> m t) -> (t, Route t outer) -> m t +makeTopDownMRoute ops f (v, r) + = do v' <- f (v, r) + transformMRoute () ops (v', r) + + {- TODO makeCheckM :: PolyplateM t () opT m => opT -> (t -> m ()) -> t -> m t @@ -77,33 +78,39 @@ makeCheckM ops f v where descend = makeDescend ops -} -checkDepthM :: (Monad m, PolyplateSpine t (OneOpQ (m ()) s) () (m ())) => (s -> m ()) -> t -> m () -checkDepthM f = sequence_ . catMaybes . flatten . applyQuery f - -checkDepthM2 :: (Monad m, PolyplateSpine t (TwoOpQ (m ()) r s) () (m ())) => - (r -> m ()) -> (s -> m ()) -> t -> m () -checkDepthM2 f g = sequence_ . catMaybes . flatten . applyQuery2 f g -checkBreadthM :: (Monad m, PolyplateSpine t (OneOpQ (m ()) s) () (m ())) => (s -> m ()) -> t -> m () -checkBreadthM f = sequence_ . catMaybes . concat . levels . applyQuery f - +-- | Given a query function that turns all items of type \"s\" into results of +-- type \"a\", applies the function to every instance of \"s\" inside a larger +-- structure of type \"t\", and gives the resulting values of type \"a\" back in +-- a rose-tree. A node in the tree will be generated for every constructor in +-- the larger item (of type \"t\"). If the constructor was of type \"s\", the +-- corresponding tree node will contain Just (the result of the query function). +-- If the constructor was any other type, the corresponding tree node will contain +-- Nothing. applyQuery :: PolyplateSpine t (OneOpQ a s) () a => (s -> a) -> t -> Tree (Maybe a) applyQuery qf = transformSpine ops () where ops = baseOp `extOpQ` qf +-- | As 'applyQuery', but takes two query functions that act on different types +-- (\"sA\" and \"sB\") but return the same result type (\"a\"). applyQuery2 :: PolyplateSpine t (TwoOpQ a sA sB) () a => (sA -> a) -> (sB -> a) -> t -> Tree (Maybe a) applyQuery2 qfA qfB = transformSpine ops () where ops = baseOp `extOpQ` qfA `extOpQ` qfB +-- | Given a function that examines a type \"s\" and gives an answer (True to include +-- the item in the list, False to drop it), finds all items of type \"s\" in some +-- larger item (of type \"t\") that satisfy this function, listed in depth-first +-- order. listifyDepth :: PolyplateSpine t (OneOpQ (Maybe s) s) () (Maybe s) => (s -> Bool) -> t -> [s] listifyDepth qf = catMaybes . flatten . fmap (fromMaybe Nothing) . transformSpine ops () where qf' x = if qf x then Just x else Nothing ops = baseOp `extOpQ` qf' +-- | As 'listifyDepth', but the returned list is in breadth-first order. listifyBreadth :: PolyplateSpine t (OneOpQ (Maybe s) s) () (Maybe s) => (s -> Bool) -> t -> [s] listifyBreadth qf = catMaybes . (concat . levels) . fmap (fromMaybe Nothing) . transformSpine ops () where @@ -111,8 +118,33 @@ listifyBreadth qf = catMaybes . (concat . levels) . fmap (fromMaybe Nothing) . t ops = baseOp `extOpQ` qf' --- | Given a monadic function that applies to a particular type (s), automatically --- applies that function to every instance of s in a larger structure of type t, +-- | Given a monadic function that operates on items of type \"s\" (without modifying +-- them), applies the function to all items of types \"s\" within an item of type +-- \"t\", in depth-first order. +-- +-- This can be used, for example, to perform checks on items in an error monad, +-- or to accumulate information in a state monad. +checkDepthM :: (Monad m, PolyplateSpine t (OneOpQ (m ()) s) () (m ())) => (s -> m ()) -> t -> m () +checkDepthM f = sequence_ . catMaybes . flatten . applyQuery f + +-- | As 'checkDepthM', but takes two functions (one operating on type \"r\", the +-- other on type \"s\"). +checkDepthM2 :: (Monad m, PolyplateSpine t (TwoOpQ (m ()) r s) () (m ())) => + (r -> m ()) -> (s -> m ()) -> t -> m () +checkDepthM2 f g = sequence_ . catMaybes . flatten . applyQuery2 f g + +-- | As 'checkDepthM', but applies the checks in breadth-first order. +checkBreadthM :: (Monad m, PolyplateSpine t (OneOpQ (m ()) s) () (m ())) => (s -> m ()) -> t -> m () +checkBreadthM f = sequence_ . catMaybes . concat . levels . applyQuery f + +-- | As 'checkDepthM2', but applies the checks in breadth-first order. +checkBreadthM2 :: (Monad m, PolyplateSpine t (TwoOpQ (m ()) r s) () (m ())) => + (r -> m ()) -> (s -> m ()) -> t -> m () +checkBreadthM2 f g = sequence_ . catMaybes . concat . levels . applyQuery2 f g + + +-- | Given a monadic function that applies to a particular type (\"s\"), automatically +-- applies that function to every instance of \"s\" in a larger structure of type \"t\", -- performing the transformations in a bottom-up fashion. It does a depth first -- traversal in order of a constructor's children (assuming you are using one of -- the generated instances, not your own), descending first and applying the function @@ -124,6 +156,18 @@ applyBottomUpM f = makeRecurseM ops where ops = baseOp `extOpM` makeBottomUpM ops f +-- | As 'applyBottomUpM', but applies two functions. These should not be modifying +-- the same type. +applyBottomUpM2 :: (PolyplateM t (TwoOpM m sA sB) () m, + PolyplateM sA () (TwoOpM m sA sB) m, + PolyplateM sB () (TwoOpM m sA sB) m + ) => + (sA -> m sA) -> (sB -> m sB) -> t -> m t +applyBottomUpM2 fA fB = makeRecurseM ops + where + ops = baseOp `extOpM` makeBottomUpM ops fA `extOpM` makeBottomUpM ops fB + +-- | As 'applyBottomUpM', but non-monadic. applyBottomUp :: (Polyplate t (OneOp s) (), Polyplate s () (OneOp s)) => (s -> s) -> t -> t @@ -131,8 +175,17 @@ applyBottomUp f = makeRecurse ops where ops = baseOp `extOp` makeBottomUp ops f --- | Given a monadic function that applies to a particular type (s), automatically --- applies that function to every instance of s in a larger structure of type t, +-- | As 'applyBottomUpM2', but non-monadic. +applyBottomUp2 :: (Polyplate t (TwoOp sA sB) (), + Polyplate sA () (TwoOp sA sB), + Polyplate sB () (TwoOp sA sB)) => + (sA -> sA) -> (sB -> sB) -> t -> t +applyBottomUp2 fA fB = makeRecurse ops + where + ops = baseOp `extOp` makeBottomUp ops fA `extOp` makeBottomUp ops fB + +-- | Given a monadic function that applies to a particular type (\"s\"), automatically +-- applies that function to every instance of \"s\" in a larger structure of type \"t\", -- performing the transformations in a top-down fashion. It does a depth first -- traversal in order of a constructor's children (assuming you are using one of -- the generated instances, not your own), applying the function first and then @@ -144,17 +197,6 @@ applyTopDownM f = makeRecurseM ops where ops = baseOp `extOpM` makeTopDownM ops f --- | As applyBottomUpM, but applies two functions. These should not be modifying --- the same type. -applyBottomUpM2 :: (PolyplateM t (TwoOpM m sA sB) () m, - PolyplateM sA () (TwoOpM m sA sB) m, - PolyplateM sB () (TwoOpM m sA sB) m - ) => - (sA -> m sA) -> (sB -> m sB) -> t -> m t -applyBottomUpM2 fA fB = makeRecurseM ops - where - ops = baseOp `extOpM` makeBottomUpM ops fA `extOpM` makeBottomUpM ops fB - -- | As applyTopDownM, but applies two functions. These should not be modifying -- the same type. applyTopDownM2 :: (PolyplateM t (TwoOpM m sA sB) () m,