module Sound.Hommage.Misc
 ( 
 -- * Imperative control structure
   for                 
 , for'                

 -- * Usefull list functions 
 , map_ 
 , foldr_ 
 , merge 
 , mergeSet 
 , uneitherlist 

 , walk
 , appendmaps 
 , appendmaps'

 , qsort 
 , qsortM 

 -- * More usefull functions
 , head_opt 
 , newFilePath 

 -- * Embedding IO in a list (-map)
 , inList
 , inList' 
 , inList''
 , toList
 , toList'
 , inListE
 , inListE' 
 , inListE''
 , toListE
 , toListE'

 )
 where

import System.Directory
import System.IO.Unsafe
import Data.Int
import Data.List

---------------------------------------------------------------------------------------------------
for :: Monad m => a -> (a -> Bool) -> (a -> a) -> (a -> m b) -> m ()
for count test step fun | test count = fun count >> for (step count) test step fun
                        | otherwise  = return ()

for' :: Monad m => a -> (a -> Bool) -> (a -> a) -> b -> (a -> b -> m b) -> m b
for' count test step state fun | test count = do state' <- fun count state
                                                 for' (step count) test step state' fun 
                               | otherwise  = return state
---------------------------------------------------------------------------------------------------
-- | a pseudo-strict 'map' version. does not touch the elements but reconstructs the whole list 
--   structure before the function is applied to the value
map_ :: (a -> b) -> [a] -> [b]
map_ f []     = []
map_ f (x:xs) = let r = map_ f xs in seq r (f x : r)

-- | a pseudo-strict 'foldr' version. does not touch the elements but reconstructs the whole list 
--   structure  before the function is applied to the values. 
foldr_ :: (a -> b -> b) -> b -> [a] -> b
foldr_ f e []     = e
foldr_ f e (x:xs) = let r = foldr_ f e xs in seq r (f x r)

-- | Similar to 'zipWith', but the result has the length of the longer input list.
merge :: (a -> a -> a) -> [a] -> [a] -> [a]
merge f = loop
 where
  loop (x:xs) (y:ys) = (f x y) : loop xs ys
  loop xs     []     = xs
  loop []     ys     = ys

mergeSet :: ([a] -> b) -> [[a]] -> [b]
mergeSet f = map f . transpose

mergeSet_ :: ([a] -> b) -> [[a]] -> [b]
mergeSet_ f = strict . map f . transpose

strict :: [a] -> [a]
strict (x:xs) = seq x (x : strict xs)
strict []     = []

head_opt :: a -> [a] -> a
head_opt _ (x:xs) = x 
head_opt x _      = x

uneitherlist :: [Either a b] -> ([a],[b])
uneitherlist []            = ([],[])
uneitherlist (Left  a : s) = let (l,r) = uneitherlist s in (a:l,r)
uneitherlist (Right b : s) = let (l,r) = uneitherlist s in (l,b:r)

walk :: ([a] -> [b]) -> [a] -> ([a],[b])
walk f a = loop a (f a)
 where
  loop (a:as) (b:bs) = let (as',bs') = loop as bs in (as',b : bs')
  loop as     []     = (as, [])
  loop []     bs     = ([], bs)

appendmaps :: [[a] -> [b]] -> [a] -> [b]
appendmaps (f:fs) as = let (as', bs) = walk f as in bs ++ appendmaps fs as'
appendmaps _      _  = []

appendmaps' :: [[a] -> [b]] -> [a] -> [[b]]
appendmaps' (f:fs) as = let (as', bs) = walk f as in bs : appendmaps' fs as'
appendmaps' _      _  = []
---------------------------------------------------------------------------------------------------
qsort :: (a -> a -> Bool) -> [a] -> [a]
qsort p i = so i
 where
  so [x]    = [x]
  so (x:xs) = let (l,r) = sp x xs in so l ++ [x] ++ so r
  so []     = []
  sp x (y:ys) = let (l,r) = sp x ys in if p y x then (y:l,r) else (l,y:r)
  sp x []     = ([],[])


qsortM :: Monad m => (a -> a -> m Bool) -> [a] -> m [a]
qsortM p = sort 
 where
  sort [x]    = return [x]
  sort (x:xs) = do (l,r) <- split x xs 
                   l'    <- sort l 
                   r'    <- sort r 
                   return (l' ++ (x : r'))
  sort []     = return []

  split y (x:xs) = do (l,r) <- split y xs 
                      b <- p x y
                      if b then return (x:l,r) else return (l,x:r)
  split y []     = return ([],[])
---------------------------------------------------------------------------------------------------
inList :: IO (Maybe a -> IO (Maybe b)) -> [a] -> [b]
inList mkf la = unsafePerformIO (mkf >>= \f -> loop f la)
 where
  loop f []    = f Nothing  >>= maybe (return []) (\b -> return (b : unsafePerformIO (loop f [])))
  loop f (a:r) = f (Just a) >>= maybe (return []) (\b -> return (b : unsafePerformIO (loop f r)))

inList' :: IO (a -> IO b) -> [a] -> [b]
inList' mkf la = unsafePerformIO (mkf >>= \f -> loop f la)
 where
  loop f []    = return []
  loop f (a:r) = f a >>= \b -> return (b : unsafePerformIO (loop f r))

inList'' :: IO (a -> IO (Maybe b)) -> [a] -> [b]
inList'' mkf la = unsafePerformIO (mkf >>= \f -> loop f la)
 where
  loop f []    = return []
  loop f (a:r) = f a >>= maybe (return []) (\b -> return (b : unsafePerformIO (loop f r)))

toList :: IO (IO a) -> [a]
toList f = unsafePerformIO (f >>= loop)
 where
  loop m = m >>= \a -> return (a : unsafePerformIO (loop m))

toList' :: IO (IO (Maybe a)) -> [a]
toList' f = unsafePerformIO (f >>= loop)
 where
  loop m = m >>= maybe (return []) (\a -> return (a : unsafePerformIO (loop m)))

---------------------------------------------------------------------------------------------------
inListE :: IO (Either (Maybe a -> IO (Maybe b)) (Maybe a -> IO (Maybe c))) -> [a] -> Either [b] [c]
inListE mkf la = unsafePerformIO (mkf >>= either (\f -> fmap Left $ loop f la) (\f -> fmap Right $ loop f la) )
 where
  loop f []    = f Nothing  >>= maybe (return []) (\b -> return (b : unsafePerformIO (loop f [])))
  loop f (a:r) = f (Just a) >>= maybe (return []) (\b -> return (b : unsafePerformIO (loop f r)))

inListE' :: IO (Either (a -> IO b) (a -> IO c)) -> [a] -> Either [b] [c]
inListE' mkf la = unsafePerformIO (mkf >>= either (\f -> fmap Left $ loop f la) (\f -> fmap Right $ loop f la) )
 where
  loop f []    = return []
  loop f (a:r) = f a >>= \b -> return (b : unsafePerformIO (loop f r))

inListE'' :: IO (Either (a -> IO (Maybe b)) (a -> IO (Maybe c))) -> [a] -> Either [b] [c]
inListE'' mkf la = unsafePerformIO (mkf >>= either (\f -> fmap Left $ loop f la) (\f -> fmap Right $ loop f la) )
 where
  loop f []    = return []
  loop f (a:r) = f a >>= maybe (return []) (\b -> return (b : unsafePerformIO (loop f r)))

toListE :: IO (Either (IO a) (IO b)) -> Either [a] [b]
toListE f = unsafePerformIO (f >>= either (fmap Left . loop) (fmap Right . loop))
 where
  loop m = m >>= \a -> return (a : unsafePerformIO (loop m))

toListE' :: IO (Either (IO (Maybe a)) (IO (Maybe b))) -> Either [a] [b]
toListE' f = unsafePerformIO (f >>= either (fmap Left . loop) (fmap Right . loop))
 where
  loop m = m >>= maybe (return []) (\a -> return (a : unsafePerformIO (loop m)))
-------------------------------------------------------------------------------
-- | the given function must create a filepath using the Int-argument. The filepath must be 
--   different for different arguments. 'newFilePath' works like Gödels mu-operator and terminates 
--   only if the filepath does not exist.
newFilePath :: (Int -> FilePath) -> IO FilePath
newFilePath filename = loop 0
 where
  loop n = do let fn = filename n 
              b <- doesFileExist fn
              if b then loop (n+1) else return fn