LocScope.hs

{-# LANGUAGE UndecidableInstances #-}

module Blanks.LocScope
  ( Colocated (..)
  , Located (..)
  , LocScope (..)
  , LocScopeRawFold
  , LocScopeFold
  , askColocated
  , colocated
  , locScopeBind
  , locScopeEmbed
  , locScopeRawFold
  , locScopeFold
  , locScopeFree
  , runColocated
  ) where

import Blanks.Class
import Blanks.RightAdjunct (RightAdjunct)
import Blanks.ScopeT (ScopeT (..), scopeTBind, scopeTFold, scopeTFree, scopeTRawFold)
import Blanks.UnderScope (EmbedScope (..), UnderScope (..), UnderScopeFold (..), underScopeFoldContraMap)
import Control.Monad (ap)
import Control.Monad.Identity (Identity (..))
import Control.Monad.Reader (MonadReader, Reader, ReaderT (..), ask, runReader)
import Data.Distributive (Distributive (..))
import Data.Functor.Adjunction (Adjunction (..))
import Data.Functor.Rep (Representable)

data Located l a = Located
  { _locatedLoc :: !l
  , _locatedVal :: !a
  } deriving (Eq, Show, Functor, Foldable, Traversable)

newtype Colocated l a = Colocated
  { unColocated :: Reader l a
  } deriving (Functor, Applicative, Monad, MonadReader l, Representable)

type instance RightAdjunct (Located l) = Colocated l

colocated :: (l -> a) -> Colocated l a
colocated f = Colocated (ReaderT (Identity . f))

askColocated :: Colocated l l
askColocated = Colocated ask

runColocated :: Colocated l a -> l -> a
runColocated = runReader . unColocated

instance Distributive (Colocated l) where
  distribute = Colocated . distribute . fmap unColocated

instance Adjunction (Located l) (Colocated l) where
  leftAdjunct v a = colocated (v . flip Located a)
  rightAdjunct h (Located l a) = runColocated (h a) l

instance Monoid l => Applicative (Located l) where
  pure = Located mempty
  (<*>) = ap

instance Monoid l => Monad (Located l) where
  return = pure
  Located l a >>= f = let Located p b = f a in Located (l <> p) b

newtype LocScope l n f a = LocScope
  { unLocScope :: ScopeT (Located l) n f a
  } deriving (Functor, Foldable, Traversable, BlankAbstract)

type instance BlankInfo (LocScope l n f) = n
type instance BlankFunctor (LocScope l n f) = f
type instance BlankCodomain (LocScope l n f) = Colocated l

instance Functor f => BlankEmbed (LocScope l n f) where
  blankEmbed = locScopeEmbed

instance (Eq (f (ScopeT (Located l) n f a)), Eq l, Eq n, Eq a) => Eq (LocScope l n f a) where
  LocScope su == LocScope sv = su == sv

instance (Show (f (ScopeT (Located l) n f a)), Show l, Show n, Show a) => Show (LocScope l n f a) where
  showsPrec d (LocScope (ScopeT tu)) = showString "LocScope " . showsPrec (d+1) tu

locScopeEmbed :: Functor f => f (LocScope l n f a) -> Colocated l (LocScope l n f a)
locScopeEmbed fe = colocated (\l -> LocScope (ScopeT (Located l (UnderEmbedScope (EmbedScope (fmap unLocScope fe))))))

locScopeBind :: Functor f => (a -> Colocated l (LocScope l n f b)) -> LocScope l n f a -> LocScope l n f b
locScopeBind f = LocScope . scopeTBind (fmap unLocScope . f) . unLocScope

locScopeFree :: a -> Colocated l (LocScope l n f a)
locScopeFree = fmap LocScope . scopeTFree

type LocScopeRawFold l n f a r = UnderScopeFold n f (LocScope l n f a) a r
type LocScopeFold l n f a r = LocScopeRawFold l n f a (Colocated l r)

locScopeRawFold :: Functor f => LocScopeRawFold l n f a r -> LocScope l n f a -> Located l r
locScopeRawFold usf = scopeTRawFold (underScopeFoldContraMap LocScope usf) . unLocScope

locScopeFold :: Functor f => LocScopeFold l n f a r -> LocScope l n f a -> r
locScopeFold usf = scopeTFold (underScopeFoldContraMap LocScope usf) . unLocScope