関数引数のpermutation (4) - One of the Eight Stones

いつまで引っ張るのかという感じですが…

型をrefineするcast*1が安全だと仮定すると、このように動くものが書ける。

*FunArgPerm2> [f 1 2 3 | f <- permArgsMono 3 (\a b c -> [a, b, c :: Int])]
[[1,2,3],[1,3,2],[2,1,3],[2,3,1],[3,1,2],[3,2,1]]
*FunArgPerm2> [f 1 2 3 | f <- permArgsMono 2 (\a b c -> [a, b, c :: Int])]
[[1,2,3],[2,1,3]]
*FunArgPerm2> [f 1 2 3 | f <- permArgsMono 4 (\a b c -> [a, b, c :: Int])]
*** Exception: permArgsMono

*FunArgPerm2> [f 1 2 3 | f <- unsafePermArgs 3 (,,)]
[(1,2,3),(1,3,2),(2,1,3),(2,3,1),(3,1,2),(3,2,1)]
*FunArgPerm2> [f 1 2 3 | f <- unsafePermArgs 4 (,,)]
[(1,2,3),(zsh: segmentation fault  ghci

以下のコードはGHCi, Hugsでは動くようだ。GHCは確認していない。

{-# OPTIONS -fglasgow-exts #-}
module FunArgPerm2 where
import Data.Dynamic
import Data.Typeable
import System.IO.Unsafe (unsafePerformIO)
import Data.IORef (readIORef, writeIORef, IORef, newIORef)

permArgsMono n f 
  | checkType n f = unsafePermArgs n f
  | otherwise     = error "permArgsMono"

checkType n f = n >= 1 && length as > n && (all (== head as) $ take n as)
  where 
    as = typeRepFunArgs (typeOf f)

unsafePermArgs n f = map ($ f) $ g $ map unMyDyn (encode n)
  where
    g [] = [id]
    g xxs@(x:xs) = [r . j|  r <- subs xxs, j <- g xs]
    subs xs = scanl (flip (.)) id xs
    encode n = take (n - 1) $ iterate next (MyDyn flip)
    next (MyDyn g) = MyDyn ((.) g)

data MyDyn = forall a b. MyDyn (a -> b)
unMyDyn (MyDyn x) = unsafeCast x

-- cast
unsafeCast x = unsafePerformIO $ writeIORef castref x >> readIORef castref
castref = unsafePerformIO $ newIORef undefined

-- Hugs Nov 2003 では typeRepArgs を typerepArgs に。
typeRepFunArgs t = f (typeRepArgs t)
  where
    f [b] = [b]
    f [a, b] = a:f (typeRepArgs b)

関連