haskell-jp / questions #51

some ::　(Ord key) => [Maybe key] -> [Maybe value] -> Maybe (M.Map key value)
some keys values = M.fromList <$> zipWithM f keys values
  where
    f :: Maybe key -> Maybe value -> Maybe (key, value)
    f mkey mvalue = (,) <$> mkey <*> mvalue

foldM step (M.empty,values) keys >>= (\(acc,l) -> acc <$ sequence_ l)
        where
        step (!acc, []) mkey = (acc, []) <$ mkey
        step (!acc, mval:vals) mkey = 
            (,vals) <$> (M.insert <$> mkey <*> mval <*> pure acc)

あ、ちなみに今回の僕のケースだとkeysとvaluesでサイズが違う場合があります

pairWith f (Just x) (Just y) = Just (f x y)
pairWith _ _        _        = Nothing

pair = pairWith (,)
left = pairWith const
-- right = pairWith (flip const)
cross f g (x, y) = (f x, g y)

some :: [Maybe a] -> [Maybe b] -> Maybe [(a, b)]
some xs ys = sequence ps `left` sequence rs
  where
    dummy = repeat (Just undefined)
    (ps, rs) = go xs ys []
    go []     ys     ps = (ps, zipWith pair dummy ys)
    go xs     []     ps = (ps, zipWith pair xs dummy)
    go (x:xs) (y:ys) ps = cross (pair x y:) id $ go xs ys ps

(<:>) = liftA2 (:)
(<.>) = liftA2 (,)
left  = liftA2 const

some :: [Maybe a] -> [Maybe b] -> Maybe [(a,b)]
some (x:xs) (y:ys) = (x <.> y) <:> some xs ys
some []     ys     = Just [] `left` sequence ys
some xs     []     = Just [] `left` sequence xs

import Data.Map (Map)
import qualified Data.Map as M

some :: Ord k => ([Maybe k], [Maybe v]) -> Maybe (Map k v)
some = hylo phi z psi
  where
    z = Just M.empty
    phi (Just Nothing, _) _ = Nothing
    phi (_, Just Nothing) _ = Nothing
    phi _ Nothing = Nothing
    phi (Nothing, _) _     = z
    phi (_, Nothing) _     = z
    phi (Just (Just k), Just (Just v)) (Just m) = Just (M.insert k v m)
    psi ([], [])   = Nothing
    psi (k:ks, []) = Just ((Just k, Nothing), (ks, []))
    psi ([], v:vs) = Just ((Nothing, Just v), ([], vs))
    psi (k:ks,v:vs) = Just ((Just k, Just v), (ks,vs))
    
hylo :: (b -> c -> c) -> c -> (a -> Maybe (b, a)) -> a -> c
hylo phi z psi x = case psi x of
  Nothing      -> z
  Just (y, x') -> phi y (hylo phi z psi x')

buildMap :: Ord k => ([Maybe k], [Maybe v]) -> Maybe (Map k v)
buildMap = hylo phi psi
  where
    z = Just M.empty
    phi Nil                                            = z
    phi (Cons (Just Nothing, _)              _      )  = Nothing
    phi (Cons (_, Just Nothing)              _      )  = Nothing
    phi (Cons _                              Nothing)  = Nothing
    phi (Cons (Nothing, _)                   _      )  = z
    phi (Cons (_, Nothing)                   _      )  = z
    phi (Cons (Just (Just k), Just (Just v)) (Just m)) = Just (M.insert k v m)
    psi ([], [])    = Nil
    psi (k:ks, [])  = Cons (Just k, Nothing) (ks, [])
    psi ([], v:vs)  = Cons (Nothing, Just v) ([], vs)
    psi (k:ks,v:vs) = Cons (Just k, Just v)  (ks,vs)