Permute.hs

module Data.List.Permute where

permute :: [a] -> [[a]]
permute [] = [[]]
permute xs = let picks = pick xs
                 f (x, xs') = map (x:) (permute xs')
             in concatMap f picks

pick :: [a] -> [(a, [a])]
pick [] = []
pick xs = let n = length xs
          in map (\i -> pickOne i xs) [0..(n-1)]

pickOne :: Int -> [a] -> (a, [a])
pickOne i xs = let l = take i xs
                   (x:r) = drop i xs
               in (x, l ++ r)

PermuteSpec.hs

{-# LANGUAGE ScopedTypeVariables #-}
module Data.List.PermuteSpec (main, spec) where

import Data.List (permutations, sort)
import Data.List.Permute
import Test.Hspec
import Test.QuickCheck

main :: IO ()
main = hspec spec

spec :: Spec
spec = do
  describe "permute" $ do
    it "should return [[]] for []" $
      permute ([] :: [Char]) `shouldBe` [[]]
    it "should return [[x]] for [x]" $ property $
      \(x :: Char) -> permute [x] == [[x]]
    it "should return the same results as the library function, up to order" $ property $
      \(xs :: String) -> let xs' = take 7 xs
                         in sort (permute xs') === sort (permutations xs')
  describe "pick" $ do
    it "should return an empty list for []" $
      pick ([] :: [Char]) `shouldBe` []
    it "should return [(x, [])] for [x]" $ property $
      \(x :: Char) -> pick [x] == [(x,[])]
    it "should return proper sublists for \"abc\"" $
      pick "abc" `shouldBe` [('a', "bc"), ('b', "ac"), ('c', "ab")]
  describe "pickOne" $ do
    it "should return ('a', \"bc\") for pickOne 0 \"abc\"" $
      pickOne 0 "abc" `shouldBe` ('a', "bc")