Phases, with Vault

Phases.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GHC2021 #-}

import Control.Applicative
import Control.Monad.ST
import Data.Kind
import Data.Map (Map)
import Data.Maybe (fromJust)
import Data.Vault.ST.Lazy
import qualified Data.Map as Map
import qualified Data.Vault.ST.Strict as Vault

type Tyype :: Type
type Tyype = Type -> Type

-- | The idea of Phases uses the structure of the Free Applicative.
--
-- `Free Applicative f a' can be viewed as a collection of f-actions,
-- and an evaluation of their result.
-- 
--   exists env. (Every f env, Every Identity env -> a)
--
-- This derives from the n-ary lifting view of Applicative:
--  + https://www.reddit.com/r/haskell/comments/1cge8rk/nary_applicative_presentation/)
-- 
--   liftA0 :: Applicative f => (a)                -> (f a)
--   liftA1 :: Functor     f => (a -> b)           -> (f a -> f b)
--   liftA2 :: Applicative f => (a -> b -> c)      -> (f a -> f b -> f c)
--   liftA3 :: Applicative f => (a -> b -> c -> d) -> (f a -> f b -> f c -> f d)
-- 
-- The `Lifting' formulation captures this arity with a type-level list.
-- 
--   class Functor f => Lifting f where
--     lifting :: (Every Identity env -> a) -> (Every f env -> f a)
-- 
--   lifting :: (Every Identity []        -> a) -> (Every f []        -> f a)
--   lifting :: (Every Identity [a]       -> b) -> (Every f [a]       -> f b)
--   lifting :: (Every Identity [a, b]    -> c) -> (Every f [a, b]    -> f c)
--   lifting :: (Every Identity [a, b, c] -> d) -> (Every f [a, b, c] -> f d)
-- 
-- The Free Applicative then consistutes the blueprint that captures
-- these operations:
--  + http://www.reddit.com/r/haskell/comments/16aa0lq/classes_as_functions_from_free
-- 
--   class Functor f => Lifting f where
--     foldLifting :: Free Applicative f ~> f
--
-- The original `Phases' defined the key by its position in a list,
-- only working for `Int' key and requiring O(|key|) traversal.
-- 
-- Instead I want to use existing containers like `Map key' or
-- `HashMap key' to take care of "sorting" the keys.
-- 
-- The difficulty is that we need a heterogeneous map. Haxl had a
-- similar problem and solved it by existential types; bundling the
-- existential type of the request with an IORef containing its
-- eventual output.
--  + https://simonmar.github.io/bib/papers/haxl-icfp14.pdf
-- 
--   data BlockedRequest where
--     BlockedRequest :: Request ex -> IORef (FetchStatus ex) -> BlockedRequest
-- 
-- I ended up using `vault', based on the 
--  + vault: a persistent store for values of arbitrary types
--  + https://hackage.haskell.org/package/vault
-- 
-- Similar to the Key Monad, suggested to me by Edward Kmett.
--  + https://web.archive.org/web/20180922033048/http://people.seas.harvard.edu:80/~pbuiras/publications/KeyMonadHaskell2016.pdf
-- 
-- This allows me to create a `newKey :: ST name (Key name a)' within
-- the `ST' Monad, that allows well-typed lookup of the value within
-- the un-typed `Vault name' environment.
-- 
--   lookup :: Key name a -> Vault name -> Maybe a 
-- 
-- This is a lot more flexible than previous approaches, where the
-- sorting is positional or built-in to the Applicative instance. 

-- | Taken from the Key monad paper.
type FLock :: Type -> Tyype -> Type
data FLock name f where
  FUnlock :: Key name a -> f a -> FLock name f

type OnVault :: Type -> Type -> Tyype -> Tyype
data OnVault name key f a where
  OnVault 
    :: { theMap :: Map key [FLock name f]
       , using  :: Vault name -> a
       }
    -> OnVault name key f a 
  deriving stock Functor

type    Phases :: Type -> Tyype -> Tyype
newtype Phases key f a = Phases (forall name. ST name (OnVault name key f a))
  deriving stock Functor

instance Ord key => Applicative (Phases key f) where
  pure :: a -> Phases key f a
  pure a = Phases do
    pure OnVault
      { theMap = Map.empty
      , using  = const a
      } 

  liftA2 :: (a -> b -> c) -> (Phases key f a -> Phases key f b -> Phases key f c)
  liftA2 (·) (Phases phase1) (Phases phase2) = Phases do
    OnVault map1 using1 <- phase1
    OnVault map2 using2 <- phase2
    pure $ OnVault 
      do Map.unionWith (++) map1 map2
      do liftA2 (·) using1 using2

phase :: key -> f a -> Phases key f a
phase key as = Phases do
  lykill <- newKey
  pure $ OnVault 
    do Map.singleton key [FUnlock lykill as]
    do unsafeGet lykill

  where
  unsafeGet :: Key name a -> Vault name -> a
  unsafeGet key vault = fromJust (Vault.lookup key vault)

runPhases :: Applicative f => Phases key f a -> f a
runPhases (Phases onVault) = runST do
  OnVault {..} <- onVault
  pure (using <$> runVault theMap)

runVault :: Applicative f => Map key [FLock name f] -> f (Vault name)
runVault map 
  | Nothing <- Map.minView map
  = pure Vault.empty
  | Just (pakkis, rest) <- Map.minView map
  = liftA2 Vault.union (runFLocks pakkis) (runVault rest)

runFLocks :: Applicative f => [FLock name f] -> f (Vault name)
runFLocks = \case
  [] -> 
    pure Vault.empty
  FUnlock lykill as:rest -> 
    liftA2 (Vault.insert lykill) as (runFLocks rest)