diff --git a/Control/Applicative/Permutation.hs b/Control/Applicative/Permutation.hs new file mode 100644 --- /dev/null +++ b/Control/Applicative/Permutation.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE ExistentialQuantification #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Applicative.Permutation +-- Copyright : Ross Paterson 2009 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : existentials +-- +-- Constructing an action as a choice between all the permutations of +-- some given actions (e.g. parsers), based on \"Parsing Permutation +-- Phrases\", by Arthur Baars, Andres Loeh and S. Doaitse Swierstra, +-- /Haskell Workshop 2001/. +-- +-- This version has a slightly different interface from the paper. +----------------------------------------------------------------------------- + +module Control.Applicative.Permutation ( + -- * Permutations of actions + Perms, + -- ** Primitive permutations + atom, + optAtom, + maybeAtom, + -- ** Extracting permutation actions + runPerms, + runPermsSep + -- * Parsing example + -- $example1 + + -- * Other examples + -- $example2 + ) where + +import Control.Applicative (Applicative(..), Alternative(..), (<$>), (<$)) + +-- | A representation of a permutation of actions of an 'Alternative' type @p@. +-- The value type of the composite action is @a@. +-- +-- Permutations are constructed from the primitives 'atom', 'optAtom' +-- and 'maybeAtom', and combined using the methods of 'Functor' and +-- 'Applicative'. They are converted back to composite actions using +-- 'runPerms' and 'runPermsSep'. +-- +-- The component actions of a permutation will be executed in each +-- possible order, but the values they produce are always assembled +-- in the order they occur in the program text, as in the following +-- permutations of one, two or three component actions: +-- +-- * @'runPerms' (f '<$>' 'atom' a) = f '<$>' a@ +-- +-- * @'runPerms' (f '<$>' 'atom' a '<*>' 'atom' b) = (f '<$>' a '<*>' b) '<|>' ('flip' f '<$>' b '<*>' a)@ +-- +-- * @'runPerms' (f '<$>' 'atom' a '<*>' 'atom' b '<*>' 'atom' c) = +-- ((\\ x (y,z) -> f x y z) '<$>' a '<*>' ((,) '<$>' b '<*>' c) '<|>' ('flip' (,) '<$>' c '<*>' b)) '<|>' +-- ((\\ y (z,x) -> f x y z) '<$>' b '<*>' ((,) '<$>' a '<*>' c) '<|>' ('flip' (,) '<$>' c '<*>' a)) '<|>' +-- ((\\ z (x,y) -> f x y z) '<$>' c '<*>' ((,) '<$>' a '<*>' b) '<|>' ('flip' (,) '<$>' b '<*>' a))@ +-- +-- The permutation is encoded as a tree, with the first action +-- executed before the second selection is made. Thus failing actions, +-- e.g. parsers, prune this tree. The size of the tree is exponential +-- in the number of components, but it is constructed lazily. +data Perms p a = Choice (Maybe a) [Branch p a] +data Branch p a = forall b. Branch (Perms p (b -> a)) (p b) + +instance Functor p => Functor (Perms p) where + fmap f (Choice def bs) = Choice (fmap f def) (map (fmap f) bs) + +instance Functor p => Functor (Branch p) where + fmap f (Branch perm p) = Branch (fmap (f .) perm) p + +-- These instances actually only need Applicative p, but we specify +-- Alternative for uniformity and to preserve the abstraction. + +instance Alternative p => Applicative (Perms p) where + pure v = Choice (Just v) [] + t1@(Choice d1 bs1) <*> t2@(Choice d2 bs2) = + Choice (d1 <*> d2) (map ins2 bs1 ++ map ins1 bs2) + where + ins1 (Branch perm p) = Branch ((.) <$> t1 <*> perm) p + ins2 (Branch perm p) = Branch (flip <$> perm <*> t2) p + +instance Alternative p => Applicative (Branch p) where + pure v = branch (pure v) + Branch perm1 p1 <*> Branch perm2 p2 = + Branch (lift_id <$> perm1 <*> perm2) ((,) <$> p1 <*> p2) + +branch :: Alternative p => p a -> Branch p a +branch p = Branch (pure id) p + +lift_id :: (a -> c -> r) -> (b -> c) -> (a,b) -> r +lift_id f g (x,y) = f x (g y) + +-- Constructing primitive permutations. +-- The definitions of these three functions actually only require +-- Applicative p, but we specify Alternative for uniformity with +-- runPerms and runPermsSep, which are the only way to use the resulting +-- permutation. Thus the interface hides the implementation detail of +-- where the Alternative methods are used. + +-- | A primitive permutation consisting of a single action. +-- +-- * @'runPerms' ('atom' a) = a@ +-- +-- When building permutation parsers, the argument parser should not match +-- the empty string: use 'optAtom' or 'maybeAtom' for optional elements. +atom :: Alternative p => p a -> Perms p a +atom p = Choice Nothing [branch p] + +-- | Like 'atom', but the action may be omitted from the permutation. +-- +-- * @'runPerms' ('optAtom' d p) = p '<|>' 'pure' d@ +-- +-- When building permutation parsers, the argument parser should not match +-- the empty string. +optAtom :: Alternative p => a -> p a -> Perms p a +optAtom def p = Choice (Just def) [branch p] + +-- | Like 'atom', but the action may be omitted from the permutation. +-- +-- * @'runPerms' ('maybeAtom' p) = 'Just' '<$>' p '<|>' 'pure' 'Nothing'@ +-- +-- When building permutation parsers, the argument parser should not match +-- the empty string. +maybeAtom :: Alternative p => p a -> Perms p (Maybe a) +maybeAtom p = optAtom Nothing (Just <$> p) + +-- Extracting a permutation action from a permutation tree + +-- | Construct a permutation action. +-- +-- * @'runPerms' ('pure' x) = 'pure' x@ +-- +-- * @'runPerms' (f '<$>' p) = f '<$>' 'runPerms' p@ +runPerms :: Alternative p => Perms p a -> p a +runPerms = foldChoice pars + where pars (Branch t p) = flip ($) <$> p <*> runPerms t +-- NOT: pars (Branch t p) = runPerms t <*> p + +-- | @'runPermsSep' sep p@ is similar to @'runPerms' p@, except that the +-- action @sep@ is interleaved between atomic actions in each permutation. +-- +-- * @'runPermsSep' sep (f '<$>' 'atom' a) = f '<$>' a@ +-- +-- * @'runPermsSep' sep (f '<$>' 'atom' a '<*>' 'atom' b) = (f '<$>' a '<*' sep '<*>' b) '<|>' ('flip' f '<$>' b '<*' sep '<*>' a)@ +-- +-- It is particularly useful in constructing permutation persers, where +-- @sep@ might be a parser for a comma or other separator. +runPermsSep :: Alternative p => p b -> Perms p a -> p a +runPermsSep sep = foldChoice pars + where pars (Branch t p) = flip ($) <$> p <*> runPermsPref sep t + +runPermsPref :: Alternative p => p b -> Perms p a -> p a +runPermsPref sep = foldChoice pars + where pars (Branch t p) = flip ($) <$ sep <*> p <*> runPermsPref sep t + +foldChoice :: Alternative p => (Branch p a -> p a) -> Perms p a -> p a +foldChoice f (Choice d bs) = foldr ((<|>) . f) (maybe empty pure d) bs + +{- $example1 + +This example (based on the paper) involves parsing XHTML @img@ elements, +which have a number of attributes, some optional, that may occur in any +order, e.g. + +> Lambda + +We assume a data type for XHTML elements, with a constructor @Img@ as one +alternative: + +> data XHTML +> = ... +> | Img +> { src :: URI +> , alt :: Text +> , longdesc :: Maybe URI +> , height :: Maybe Length +> , width :: Maybe Length +> } + +> type Text = String +> type URI = String +> type Length = Int + +Suppose we have a parser type @Parser@ (an instance of 'Alternative') +with primitive parsers: + +> pToken :: String -> Parser () +> pSymbol :: Char -> Parser () +> pText :: Parser Text +> pURI :: Parser URI +> pLength :: Parser Length + +Then we can construct a parser for @img@ elements as follows: + +> pImgTag :: Parser XHTML +> pImgTag = pToken "<" *> pToken "img" *> attrs <* pToken "/>" +> where attrs = runPerms $ Img +> <$> atom (pField "src" pURI) +> <*> atom (pField "alt" pText) +> <*> maybeAtom (pField "longdesc" pURI) +> <*> maybeAtom (pField "height" pLength) +> <*> maybeAtom (pField "width" pLength) + +> pField :: String -> Parser a -> Parser a +> pField f p = pToken f *> pSymbol '=' *> p + +-} + +{- $example2 + +Although permutations are particularly useful with parsers, they may +also be used with other instances of 'Alternative'. + +For example, we can generate all the permutations of a list by permuting +@tell@ actions for the elements: + +> import Control.Monad.Writer (execWriterT, tell) +> import Data.Foldable (sequenceA_) + +> permutations :: [a] -> [[a]] +> permutations xs = +> execWriterT $ runPerms $ sequenceA_ [atom (tell [x]) | x <- xs] + +Note that if each atomic action simply returned an element on the list, +the result would be many copies of the original list, because the +combinators ensure that the results are re-assembled in the original order, +no matter what order the actions are executed. + +We can also achieve a permutation of the integers 1 to @n@ by using a +permutation of effects that increment and return a state: + +> import Control.Monad.State (evalStateT, get, put) +> import Data.Traversable (traverse) + +> permuteN :: Int -> [[Int]] +> permuteN n = evalStateT (runPerms (traverse atom (replicate n incr))) 1 +> where incr = do { n <- get; put (n+1); return n } + +A solution to the n-queens problem is such a permutation satisfying the +additional condition that no two positions are on the same diagonal. +We can adapt the previous example to implement this idea by changing +the state to a list of positions for the first @n@ rows. Then when +adding a new position we need only check that it is not on the same +diagonal as the previous positions. If this test fails, the partial +permutation will be discarded. Thus the algorithm is + +> import Control.Monad.State (evalStateT, get, put) +> import Data.Traversable (traverse) + +> queens :: Int -> [[Int]] +> queens n = evalStateT (runPerms (traverse (atom . place) [1..n])) [] + +where the auxiliary function @place@ attempts to place a queen in a given +position on the current row, returning the row number. + +> place :: Int -> StateT [Int] [] Int +> place n = do +> ns <- get +> guard (and [abs (m-n) /= k | (k, m) <- zip [1..] ns]) +> put (n:ns) +> return (length ns + 1) + +-} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +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 name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE 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 +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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/action-permutations.cabal b/action-permutations.cabal new file mode 100644 --- /dev/null +++ b/action-permutations.cabal @@ -0,0 +1,29 @@ +name: action-permutations +version: 0.0.0.0 +license: BSD3 +license-file: LICENSE +author: Ross Paterson +maintainer: Ross Paterson +category: Control +synopsis: Execute a set of actions (e.g. parsers) in each possible order +description: + Sequence a set of Alternative actions in each possible order, + based on \"Parsing Permutation Phrases\", by Arthur Baars, + Andres Loeh and S. Doaitse Swierstra, /Haskell Workshop 2001/. + This is particularly useful for constructing a parser for + permutations of elements. + This version has a slightly different interface from the paper. +build-type: Simple +cabal-version: >= 1.2 + +flag ApplicativeInBase + description: Choose the newer base package, including Applicative and other + Functor classes. + +library + if flag(ApplicativeInBase) + build-depends: base >= 2 + else + build-depends: base >= 1.0 && < 2, special-functors >=1.0 && <1.1 + exposed-modules: Control.Applicative.Permutation + extensions: ExistentialQuantification