Singular.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Singular where

import BasePrelude hiding (fold)
import Control.Monad.State
import Data.Functor.Identity

{-# ANN module ("HLint: ignore Redundant lambda" :: String) #-}

type Lens big small =
  forall f. (Functor f) => (small -> f small) -> (big -> f big)

type Traversal big small =
  forall ap. (Applicative ap) => (small -> ap small) -> (big -> ap big)

newtype Bazaar small big =
  Bazaar { unBazaar :: forall ap. Applicative ap => (small -> ap small) -> ap big }
  deriving Functor

instance Applicative (Bazaar small) where
  pure big =
    Bazaar (\_ -> pure big)
  Bazaar lhs <*> Bazaar rhs =
    Bazaar (\liftSmall -> lhs liftSmall <*> rhs liftSmall)

makeLens :: (big -> small) -> (big -> small -> big) -> Lens big small
makeLens getter setter =
  \liftSmall big -> setter big <$> liftSmall (getter big)

_Cons :: Traversal [a] (a, [a])
_Cons = prism (uncurry (:)) (\case (x:xs) -> Right (x, xs); [] -> Left [])

_1 :: Lens (a, b) a
_1 = makeLens fst (\(_, b) a' -> (a', b))

_head :: Traversal [a] a
_head = _Cons . _1

ix :: Int -> Traversal [a] a
ix k liftSmall big =
  if k < 0 then pure big else go big k
  where
    go [] _ = pure []
    go (x:xs) 0 = (:xs) <$> liftSmall x
    go (x:xs) i = (x:) <$> go xs (i - 1)

-- | Traverses a value of type big, accumulating the result in monoid mon
foldMapOf :: Monoid mon => Traversal big small -> (small -> mon) -> big -> mon
foldMapOf traversal fold =
  getConst . traversal (Const . fold)

-- | foldMapOf with mappend/mzero inlined
foldrOf :: Traversal big small -> (small -> r -> r) -> r -> big -> r
foldrOf traversal fold zero =
  \big -> appEndo (foldMapOf traversal (Endo . fold) big) zero

-- | Constructs a Traversal that targets zero or one
prism :: (small -> big) -> (big -> Either big small) -> Traversal big small
prism constructor getter =
  \liftSmall big -> case (fmap liftSmall . getter) big of
    Left big' -> pure big'
    Right fsmall -> fmap constructor fsmall

-- | toListOf is our debugging friend
toListOf :: Traversal big small -> big -> [small]
toListOf traversal = foldrOf traversal (:) []

singular :: forall big small. Traversal big small -> Lens big small
singular traversal liftSmall big = do
  let b = traversal (\small -> Bazaar ($ small)) big
  case toListOf traversal big of
    (x:xs) -> unsafeOuts b . (:xs) <$> liftSmall x
    [] -> unsafeOuts b . return <$> liftSmall (error "singularity")

gobble :: State [a] a
gobble = state (unconsWithDefault (error ""))

unconsWithDefault :: a -> [a] -> (a,[a])
unconsWithDefault d []     = (d,[])
unconsWithDefault _ (x:xs) = (x,xs)

unsafeOuts :: Bazaar small big -> [small] -> big
unsafeOuts (Bazaar bazaar) smalls = evalState (bazaar (\_ -> gobble)) smalls

set :: ((small -> Identity small) -> big -> Identity big) -> small -> big -> big
set setter new big =
  runIdentity (setter (\_ -> Identity new) big)

view :: ((small -> Const small small) -> big -> Const small big) -> big -> small
view getter big =
  getConst (getter Const big)

bazaarOf :: Traversal s a -> s -> Bazaar a s
bazaarOf l s =
  l (\small -> Bazaar (\liftSmall -> liftSmall small)) s

-- I was unable to get this to compile! It seems like I don't fully understand `getting` yet.
-- I was able to work around it by just calling `toListOf` on the original `big`, rather than on the bazaar.
-- Is that legal? Who knows...

-- ins :: Bazaar small big -> [small]
-- ins = toListOf (\big -> _ um big)
--   where
--     um :: Applicative f => (a -> f a) -> Bazaar a t -> f t
--     um g (Bazaar f) = f g