[Haskell-cafe] Two mysteries

[Henry Laxen]

-- run this with ghci -package microlens-platform -package stm -package containers SC.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}

module Games.SC where

import qualified Data.Map.Strict        as M
import           GHC.IO.Unsafe          ( unsafePerformIO )
import           Lens.Micro.Platform
import           Control.Concurrent.STM.TVar
import           Control.Concurrent.STM
import           Control.Monad.IO.Class

type Lenstype f a b = (b -> f b) -> a -> f a
instance Show a => Show (TVar a) where
  show x = unsafePerformIO $ do
          sx <- readTVarIO x
          return ("TVar: " <> show sx)

newtype TMap k v = TMap (TVar (M.Map k (TVar v))) deriving Show

-- TMap (TVar (Map k (TVar v)))
--       ^^^^ modify this TVar to add/delete a key
-- TMap (TVar (Map k (TVar v)))
--                    ^^^^ modify this TVar to change a value

withKey :: (MonadIO m, Ord k) => k -> (Maybe v -> v) -> TMap k v -> m ()
withKey k f (TMap x) = liftIO $ do
  atomically $ do
    tMap <- readTVar x
    let
      mbK = M.lookup k tMap
    case mbK of -- insert a new (key,value) into the map
      Nothing -> do
        v' <- newTVar (f Nothing)
        let
          newMap = M.insert k v' tMap
        writeTVar x newMap
      Just tv -> do -- modify the value of an existing key
        v' <- readTVar tv
        let newV = f (Just v')
        writeTVar tv newV
  return ()

class State a  where
  type StateKey   a :: *
  type StateValue a :: *
  lensTmap          :: Functor f => Lenstype f a (TMap (StateKey a) (StateValue a))
  lensKey           :: Functor f => Lenstype f a (StateKey a)
  lensCounter       :: Functor f => Lenstype f (StateValue a) Int

updateState state f = liftIO $ do
  let
    key      = state ^. lensKey   -- read the key
    mutable  = state ^. lensTmap  -- find the TVar of the TMap
  withKey key (\(Just x) -> x & lensCounter %~ f) mutable -- update it

-- THE FIRST MYSTERY: If I use the inferred type explicitly for updateState
-- above, this no longer compiles.  I get a "could not deduce" error
-- reproduced below:

-- xupdateState
--   :: (MonadIO m, Ord (StateKey s), State s, State a,
--       StateValue s ~ StateValue a) =>
--      s -> (Int -> Int) -> m ()
-- xupdateState state f = liftIO $ do
--   let
--     key      = state ^. lensKey   -- read the key
--     mutable  = state ^. lensTmap  -- find the TVar of the TMap
--   withKey key (\(Just x) -> x & lensCounter %~ f) mutable -- update it

-- /home/henry/nadineloveshenry/projects/nlh/src/Games/SC.hs:84:33-43: error:
--     • Could not deduce: StateValue a0 ~ StateValue a
--       from the context: (MonadIO m, Ord (StateKey s), State s, State a,
--                          StateValue s ~ StateValue a)
--         bound by the type signature for:
--                    xupdateState :: forall (m :: * -> *) s a.
--                                    (MonadIO m, Ord (StateKey s), State s, State a,
--                                     StateValue s ~ StateValue a) =>
--                                    s -> (Int -> Int) -> m ()
--         at /home/henry/nadineloveshenry/projects/nlh/src/Games/SC.hs:(76,1)-(79,30)
--       Expected type: ASetter (StateValue a) (StateValue a) Int Int
--         Actual type: Lenstype
--                        Data.Functor.Identity.Identity (StateValue a0) Int
--       NB: ‘StateValue’ is a non-injective type family
--       The type variable ‘a0’ is ambiguous
--     • In the first argument of ‘(%~)’, namely ‘lensCounter’
--       In the second argument of ‘(&)’, namely ‘lensCounter %~ f’
--       In the expression: x & lensCounter %~ f
--     • Relevant bindings include
--         x :: StateValue a
--           (bound at /home/henry/nadineloveshenry/projects/nlh/src/Games/SC.hs:84:23)
--         mutable :: TMap (StateKey s) (StateValue a)
--           (bound at /home/henry/nadineloveshenry/projects/nlh/src/Games/SC.hs:83:5)


data SampleState = SampleState
  {
    _key  :: String
  , _tMap :: TMap String SampleValue
  } deriving Show

data SampleValue = SampleValue
  {
    _counter :: Int
  , _other   :: ()
  } deriving Show

$(makeLenses ''SampleState)
$(makeLenses ''SampleValue)

makeSampleState :: IO SampleState
makeSampleState = do
  let sampleValue = SampleValue 1 ()
  tvar1 <- newTVarIO sampleValue
  let sampleTMap = M.fromList [("a", tvar1)]
  tvar2 <- newTVarIO sampleTMap
  return (SampleState "a" (TMap tvar2))

-- I can show the result of makeSampleState:
-- λ> makeSampleState
-- SampleState {_key = "a", _tMap = TMap TVar: fromList [("a",TVar: SampleValue {_counter = 1, _other = ()})]}

bump1 :: IO ()
bump1 = do
  xss <- makeSampleState
  let xTmap = xss ^. tMap
  withKey "a" (\(Just x) -> x & counter %~ (+1)) xTmap
  print xTmap
  
-- Everything here is tickety-boo  
-- λ> bump1
-- TMap TVar: fromList [("a",TVar: SampleValue {_counter = 2, _other = ()})]

-- Now let's make SampleState an instance of State

instance State SampleState where
  type StateKey SampleState   = String
  type StateValue SampleState = SampleValue
  lensTmap        =  tMap
  lensKey         =  key
  lensCounter     =  counter
  
-- THE SECOND MYSTERY: now lets try bump1 with the type family, but there is no joy

-- bump2 :: IO ()
-- bump2 = do
--   xss <- makeSampleState
--   let xTmap = xss ^. lensTmap
--   withKey "a" (\(Just x) -> x & lensCounter %~ (+1)) xTmap
--   print xTmap
  
-- SC.hs:163:33-43: error:
--     • Couldn't match type ‘StateValue a0’ with ‘SampleValue’
--       Expected type: ASetter SampleValue SampleValue Int Int
--         Actual type: Lenstype
--                        Data.Functor.Identity.Identity (StateValue a0) Int
--       The type variable ‘a0’ is ambiguous
--     • In the first argument of ‘(%~)’, namely ‘lensCounter’
--       In the second argument of ‘(&)’, namely ‘lensCounter %~ (+ 1)’
--       In the expression: x & lensCounter %~ (+ 1)

-- Can someone please explain what is going on, or point me at a book/paper
-- Thanks in advance.

-- You can load this into ghci and uncomment to "bad" code to see for
-- yourself what happens



-- 
Nadine and Henry Laxen            The rest is silence
Gral. Manuel Márquez de León 1301
Onix #2302
Zona Urban Rio                    Never try to teach a pig to sing;
Tijuana                           It wastes your time
+52 (333) 667-8633                And it annoys the pig