wired applicative constrained normal

wired applicative constrained normal.hs

{-# language KindSignatures, RankNTypes, GADTs, LambdaCase, GeneralizedNewtypeDeriving #-}
import Data.Functor.Const
import Control.Monad.ConstrainedNormal
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Functor.Identity
import Data.ByteString (ByteString)
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import Data.Set (Set)
import Control.Monad.Trans.State.Strict

--------------------------------------------------------------------------------
-- The applicative-wired monad pattern

data Spec f m a where
  Spec :: String -> f i -> (i -> m a) -> Spec f m (f a)

newtype Action f m a = Action { runAction ::  NM Unconstrained (NAF Unconstrained (Spec f m)) a }
  deriving (Functor, Applicative, Monad)

act :: String -> f i -> (i -> m a) -> Action f m (f a)
act l i f = Action $ liftNM $ liftNAF $ Spec l i f

--------------------------------------------------------------------------------
-- An example

example :: Applicative f => Action f IO (f (ByteString, ByteString))
example = do
  file1 <- act "read_file_1" (pure ()) $ const $ S.readFile "file1.txt"
  file2 <- act "read_file_2" file1 $ S.readFile .  unwords . words . S8.unpack
  pure $ (,) <$> file1 <*> file2

--------------------------------------------------------------------------------
-- IO interpretation

runIO :: Action Identity IO a -> IO a
runIO = foldFreeNM (runNAF io) . runAction where
  io :: Spec Identity IO x -> IO x
  io = \case
    Spec name input act' -> do
      putStrLn $ "Running " ++ name
      out <- act' $ runIdentity input
      pure $ Identity out

--------------------------------------------------------------------------------
-- Graphable interpretation

newtype Value a = Value { runValue :: NAF Unconstrained Key a }
  deriving (Functor, Applicative)

data Key a = Key { unKey :: String }

graph :: Monad m => Action Value m a -> State (Map String (Set String)) a
graph = foldFreeNM (runNAF go) . runAction where
  go :: Spec Value m a -> State (Map String (Set String)) a
  go = \case
   Spec string i _ -> do
    modify (Map.insert string (keys i))
    pure $ Value $ liftNAF $ Key string

  keys ::  Value a -> Set String
  keys = runNAF_ (Set.singleton . unKey) . runValue

--------------------------------------------------------------------------------
-- Helpers

runNAF :: Applicative g => (forall x. c x => f x -> g x) -> NAF c f a -> g a
runNAF f_x = foldNAF pure (\gyz fy -> gyz <*> f_x fy)

runNAF_ :: Monoid m => (forall a. c a => f a -> m) -> NAF c f b -> m
runNAF_ f = getConst . runNAF (Const . f)

foldFreeNM :: Monad m => (forall x. c x => f x -> m x) -> NM c f a -> m a
foldFreeNM ft = foldNM pure (\fx fxma -> ft fx >>= fxma)