Phases

Phases.hs

{-# LANGUAGE PackageImports #-}
{-# options_ghc -Wno-partial-type-signatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE BlockArguments #-}
import Data.Map qualified as Map
import qualified Data.Map.Merge.Lazy    as Map
import Data.Functor
import Data.Bifunctor
import Data.Map (Map)
import Control.Category
import Prelude hiding (id, (.))
import Data.Align
import Control.Concurrent.MVar
import Data.Foldable
import Control.Applicative
import Data.Kind
import Data.These
import GHC.Exts (Any)
import Data.Bitraversable
import Unsafe.Coerce

type f ~> g = forall x. f x -> g x

-- | Phases
type Phases :: Type -> (Type -> Type) -> Type -> Type
data Phases key f a where
  Phases :: Map key (f Any) -> ([Any] -> a) -> Phases key f a
deriving stock 
  instance Functor (Phases key f)

instance (Ord key, Applicative f) => Applicative (Phases key f) where
  pure :: a -> Phases key f a
  pure a = Phases Map.empty \[] -> a

  liftA2 :: (a -> b -> c) -> (Phases key f a -> Phases key f b -> Phases key f c)
  liftA2 (·) (Phases as use1) (Phases bs use2) = Phases 
    do unsafeCoerce do alignWith bisequenceA as bs
    do unsafeCoerce \(partitionHereThere -> (here, there)) ->
         use1 here · use2 there

runPhases :: Applicative f => Phases key f a -> f a
runPhases (Phases run use) = fmap (toList >>> use) (sequenceA run) where

phase :: Applicative f => key -> f ~> Phases key f
phase n as = Phases 
  do Map.singleton n (toAnys as)
  do \[a] -> fromAny a

data Phase = Setup | Run | Cleanup
  deriving stock (Eq, Ord)

-- >> runPhases (one × two)
-- "initializing .."
-- "beep boop"
-- "extra work"
-- "handle"
-- ((),())
one :: Phases Phase IO ()
one = sequenceA_
  [ phase Setup   (print "initializing ..")
  , phase Run     (print "beep boop")
  , phase Cleanup (print "handle")
  ]

two :: Phases Phase IO ()
two = sequenceA_
  [ phase Run (print "extra work")
  ]

(×) :: Applicative f => f a -> f b -> f (a, b)
(×) = liftA2 (,)