module Data.Logical.Knot
( Knot
, KnotT
, MonadKnot
, askKnot
, askKnotDef
, (*=)
, accKnot
, tieKnot
, accKnotT
, tieKnotT
) where
import Data.Map (Map,fromList,fromListWith,(!),findWithDefault)
import Control.Applicative
import Control.Monad.Reader
import Control.Monad.Writer
type Constraint i x = (i,x)
type Solution i x = Map i x
newtype Knot i x a =
Knot (ReaderT (Solution i x) (Writer [Constraint i x]) a)
deriving (Functor, Applicative, Monad, MonadFix)
newtype KnotT i x m a =
KnotT (ReaderT (Solution i x) (WriterT [Constraint i x] m) a)
deriving (Functor, Applicative, Monad, MonadFix)
instance MonadTrans (KnotT i x)
where
lift = KnotT . lift . lift
class (Monad m, Ord i) => MonadKnot i x m | m -> i x
where
askKnot :: i -> m x
askKnotDef :: x -> i -> m x
(*=) :: i -> x -> m ()
instance Ord i => MonadKnot i x (Knot i x)
where
askKnot i = Knot $ asks (! i)
askKnotDef def i = Knot $ asks $ findWithDefault def i
i *= x = Knot $ tell [(i,x)]
instance (Monad m, Ord i) => MonadKnot i x (KnotT i x m)
where
askKnot i = KnotT $ asks (! i)
askKnotDef def i = KnotT $ asks $ findWithDefault def i
i *= x = KnotT $ tell [(i,x)]
accKnot :: Ord i => (x -> x -> x) -> Knot i x a -> (a, Map i x)
accKnot acc (Knot knot) = (a,solution)
where
(a,ass) = runWriter $ runReaderT knot solution
solution = fromListWith acc ass
tieKnot :: Ord i => Knot i x a -> (a, Map i x)
tieKnot = accKnot (error "tieKnot: Over-constrained")
accKnotT
:: (Ord i, MonadFix m)
=> (x -> x -> x) -> KnotT i x m a -> m (a, Map i x)
accKnotT acc (KnotT knot) = mdo
(a,ass) <- runWriterT $ runReaderT knot solution
let solution = fromListWith acc ass
return (a,solution)
tieKnotT :: (Ord i, MonadFix m) => KnotT i x m a -> m (a, Map i x)
tieKnotT = accKnotT (error "tieKnot: Over-constrained")