module Extension.Data.Label (
nthL
, imageL
, fstL
, sndL
, module Data.Label
, liftLA
, modA
, askM
, setM
, getM
, modM
, (=:)
) where
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
import Data.Label
import Data.Label.PureM ( (=:) )
import qualified Data.Label.PureM as LM
import Control.Arrow (first, second)
import Control.Applicative (Applicative, (<$>), (<*>), pure, liftA2)
import Control.Monad.State (MonadState)
import Control.Monad.Reader (MonadReader)
fstL :: ((a, b) :-> a)
fstL = lens fst (first . const)
sndL :: ((a, b) :-> b)
sndL = lens snd (second . const)
nthL :: Int -> ([a] :-> a)
nthL i = lens (!! i) updateAt
where
updateAt x xs
| 0 <= i && i < length xs = case splitAt i xs of
(prefix, _:suffix) -> prefix ++ (x:suffix)
_ -> error "nthL: impossible"
| otherwise = error $ "nthL: index " ++ show i ++ " out of range"
imageL :: Ord k => k -> (M.Map k v :-> v)
imageL k =
lens (fromMaybe (error "imageL: element not found") . M.lookup k)
(M.insert k)
liftLA :: Applicative f => (a :-> b) -> (f a :-> f b)
liftLA l = lens (get l <$>) (liftA2 (set l))
modA :: Applicative f => (a :-> b) -> (b -> f b) -> a -> f a
modA l f a = set l <$> f (get l a) <*> pure a
askM :: MonadReader r m => (r :-> a) -> m a
askM = LM.asks
setM :: MonadState s m => (s :-> a) -> a -> m ()
setM = LM.puts
getM :: MonadState s m => (s :-> a) -> m a
getM = LM.gets
modM :: MonadState s m => (s :-> a) -> (a -> a) -> m ()
modM = LM.modify