{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | This module is a glorified wrapper over `Data.Map.Strict.lookup`. It
-- let you define computations in an applicative way that "require" some
-- optional values, defined by an identifier.
--
-- Once defined, it is possible to extract the list of identifiers, and
-- also to evaluate the computation.
--
-- > let computation = ( (+) <$> require "a" <*> require "b" )
-- > > computeRequire M.empty computation :: Maybe Int
-- > Nothing
-- > > computeRequire (M.fromList [("a", 12), ("b", 15)]) computation :: Maybe Int
-- > Just 27
-- > > computeRequire (M.fromList [("a", 12), ("c", 15)]) computation :: Maybe Int
-- > Nothing
--
module Control.Dependency ( Require
                          , require
                          , requireFilter
                          , guardResult
                          , computeRequire
                          , computeRequireIntermediate
                          , isComputable
                          , triggersAnalyzer
                          ) where

import           Control.Applicative
import           Control.Monad       (guard)
import qualified Data.Foldable       as F
import           Data.Profunctor
import qualified Data.Set            as S

-- | The main data type, used to model a computation that requires a list
-- of named parameters (the "identifier"), that are linked to a "content",
-- and that will yield a result of type "a".
data Require identifier content a where
    Require      :: (identifier -> Bool) -> Require identifier content (identifier, content)
    Pure         :: a                    -> Require identifier content a
    Ap           :: Require identifier content (a -> b) -> Require identifier content a -> Require identifier content b
    Alt          :: Require identifier content a -> Require identifier content a -> Require identifier content a
    Empty        :: Require identifier content a
    HoistContent :: (content -> prevcontent) -> Require identifier prevcontent a -> Require identifier content a
    GuardResult  :: (a -> Bool) -> Require identifier content a -> Require identifier content a

instance Functor (Require identifier content) where
    fmap :: forall a b.
(a -> b)
-> Require identifier content a -> Require identifier content b
fmap a -> b
f = Require identifier content (a -> b)
-> Require identifier content a -> Require identifier content b
forall identifier content prevcontent b.
Require identifier content (prevcontent -> b)
-> Require identifier content prevcontent
-> Require identifier content b
Ap ((a -> b) -> Require identifier content (a -> b)
forall a identifier content. a -> Require identifier content a
Pure a -> b
f)

instance Applicative (Require identifier content) where
    pure :: forall a. a -> Require identifier content a
pure  = a -> Require identifier content a
forall a identifier content. a -> Require identifier content a
Pure
    <*> :: forall a b.
Require identifier content (a -> b)
-> Require identifier content a -> Require identifier content b
(<*>) = Require identifier content (a -> b)
-> Require identifier content a -> Require identifier content b
forall identifier content prevcontent b.
Require identifier content (prevcontent -> b)
-> Require identifier content prevcontent
-> Require identifier content b
Ap

instance Alternative (Require identifier content) where
    empty :: forall a. Require identifier content a
empty = Require identifier content a
forall identifier content a. Require identifier content a
Empty
    <|> :: forall a.
Require identifier content a
-> Require identifier content a -> Require identifier content a
(<|>) = Require identifier content a
-> Require identifier content a -> Require identifier content a
forall identifier content a.
Require identifier content a
-> Require identifier content a -> Require identifier content a
Alt

instance Profunctor (Require identifier) where
    dimap :: forall a b c d.
(a -> b)
-> (c -> d) -> Require identifier b c -> Require identifier a d
dimap a -> b
f c -> d
g = (c -> d) -> Require identifier a c -> Require identifier a d
forall a b.
(a -> b) -> Require identifier a a -> Require identifier a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g (Require identifier a c -> Require identifier a d)
-> (Require identifier b c -> Require identifier a c)
-> Require identifier b c
-> Require identifier a d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> Require identifier b c -> Require identifier a c
forall content prevcontent identifier a.
(content -> prevcontent)
-> Require identifier prevcontent a -> Require identifier content a
HoistContent a -> b
f

-- | This operator let you "require" a value in a computation.
require :: Eq identifier => identifier -> Require identifier content content
require :: forall identifier content.
Eq identifier =>
identifier -> Require identifier content content
require = ((identifier, content) -> content)
-> Require identifier content (identifier, content)
-> Require identifier content content
forall a b.
(a -> b)
-> Require identifier content a -> Require identifier content b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (identifier, content) -> content
forall a b. (a, b) -> b
snd (Require identifier content (identifier, content)
 -> Require identifier content content)
-> (identifier -> Require identifier content (identifier, content))
-> identifier
-> Require identifier content content
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (identifier -> Bool)
-> Require identifier content (identifier, content)
forall identifier content.
(identifier -> Bool)
-> Require identifier content (identifier, content)
Require ((identifier -> Bool)
 -> Require identifier content (identifier, content))
-> (identifier -> identifier -> Bool)
-> identifier
-> Require identifier content (identifier, content)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. identifier -> identifier -> Bool
forall a. Eq a => a -> a -> Bool
(==)

requireFilter :: (identifier -> Bool) -> Require identifier content (identifier, content)
requireFilter :: forall identifier content.
(identifier -> Bool)
-> Require identifier content (identifier, content)
requireFilter = (identifier -> Bool)
-> Require identifier content (identifier, content)
forall identifier content.
(identifier -> Bool)
-> Require identifier content (identifier, content)
Require

-- | Will drop the result unless the predicate is true.
guardResult
  :: (result -> Bool) -- ^ predicate
  -> Require identifier content result
  -> Require identifier content result
guardResult :: forall result identifier content.
(result -> Bool)
-> Require identifier content result
-> Require identifier content result
guardResult = (result -> Bool)
-> Require identifier content result
-> Require identifier content result
forall result identifier content.
(result -> Bool)
-> Require identifier content result
-> Require identifier content result
GuardResult

data ComputeMode
    = Intermediate
    | Final
    deriving (Int -> ComputeMode -> ShowS
[ComputeMode] -> ShowS
ComputeMode -> String
(Int -> ComputeMode -> ShowS)
-> (ComputeMode -> String)
-> ([ComputeMode] -> ShowS)
-> Show ComputeMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ComputeMode -> ShowS
showsPrec :: Int -> ComputeMode -> ShowS
$cshow :: ComputeMode -> String
show :: ComputeMode -> String
$cshowList :: [ComputeMode] -> ShowS
showList :: [ComputeMode] -> ShowS
Show, ComputeMode -> ComputeMode -> Bool
(ComputeMode -> ComputeMode -> Bool)
-> (ComputeMode -> ComputeMode -> Bool) -> Eq ComputeMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ComputeMode -> ComputeMode -> Bool
== :: ComputeMode -> ComputeMode -> Bool
$c/= :: ComputeMode -> ComputeMode -> Bool
/= :: ComputeMode -> ComputeMode -> Bool
Eq, Eq ComputeMode
Eq ComputeMode =>
(ComputeMode -> ComputeMode -> Ordering)
-> (ComputeMode -> ComputeMode -> Bool)
-> (ComputeMode -> ComputeMode -> Bool)
-> (ComputeMode -> ComputeMode -> Bool)
-> (ComputeMode -> ComputeMode -> Bool)
-> (ComputeMode -> ComputeMode -> ComputeMode)
-> (ComputeMode -> ComputeMode -> ComputeMode)
-> Ord ComputeMode
ComputeMode -> ComputeMode -> Bool
ComputeMode -> ComputeMode -> Ordering
ComputeMode -> ComputeMode -> ComputeMode
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ComputeMode -> ComputeMode -> Ordering
compare :: ComputeMode -> ComputeMode -> Ordering
$c< :: ComputeMode -> ComputeMode -> Bool
< :: ComputeMode -> ComputeMode -> Bool
$c<= :: ComputeMode -> ComputeMode -> Bool
<= :: ComputeMode -> ComputeMode -> Bool
$c> :: ComputeMode -> ComputeMode -> Bool
> :: ComputeMode -> ComputeMode -> Bool
$c>= :: ComputeMode -> ComputeMode -> Bool
>= :: ComputeMode -> ComputeMode -> Bool
$cmax :: ComputeMode -> ComputeMode -> ComputeMode
max :: ComputeMode -> ComputeMode -> ComputeMode
$cmin :: ComputeMode -> ComputeMode -> ComputeMode
min :: ComputeMode -> ComputeMode -> ComputeMode
Ord, Int -> ComputeMode
ComputeMode -> Int
ComputeMode -> [ComputeMode]
ComputeMode -> ComputeMode
ComputeMode -> ComputeMode -> [ComputeMode]
ComputeMode -> ComputeMode -> ComputeMode -> [ComputeMode]
(ComputeMode -> ComputeMode)
-> (ComputeMode -> ComputeMode)
-> (Int -> ComputeMode)
-> (ComputeMode -> Int)
-> (ComputeMode -> [ComputeMode])
-> (ComputeMode -> ComputeMode -> [ComputeMode])
-> (ComputeMode -> ComputeMode -> [ComputeMode])
-> (ComputeMode -> ComputeMode -> ComputeMode -> [ComputeMode])
-> Enum ComputeMode
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ComputeMode -> ComputeMode
succ :: ComputeMode -> ComputeMode
$cpred :: ComputeMode -> ComputeMode
pred :: ComputeMode -> ComputeMode
$ctoEnum :: Int -> ComputeMode
toEnum :: Int -> ComputeMode
$cfromEnum :: ComputeMode -> Int
fromEnum :: ComputeMode -> Int
$cenumFrom :: ComputeMode -> [ComputeMode]
enumFrom :: ComputeMode -> [ComputeMode]
$cenumFromThen :: ComputeMode -> ComputeMode -> [ComputeMode]
enumFromThen :: ComputeMode -> ComputeMode -> [ComputeMode]
$cenumFromTo :: ComputeMode -> ComputeMode -> [ComputeMode]
enumFromTo :: ComputeMode -> ComputeMode -> [ComputeMode]
$cenumFromThenTo :: ComputeMode -> ComputeMode -> ComputeMode -> [ComputeMode]
enumFromThenTo :: ComputeMode -> ComputeMode -> ComputeMode -> [ComputeMode]
Enum, ComputeMode
ComputeMode -> ComputeMode -> Bounded ComputeMode
forall a. a -> a -> Bounded a
$cminBound :: ComputeMode
minBound :: ComputeMode
$cmaxBound :: ComputeMode
maxBound :: ComputeMode
Bounded)

-- | Evaluate a computation, given a map of key/values for possible
-- parameters.
computeRequire
  :: forall identifier content f a.
     (Ord identifier, Eq identifier, Monad f, Alternative f)
  => [(identifier, content)]
  -> Require identifier content a
  -> f a
computeRequire :: forall identifier content (f :: * -> *) a.
(Ord identifier, Eq identifier, Monad f, Alternative f) =>
[(identifier, content)] -> Require identifier content a -> f a
computeRequire = ComputeMode
-> [(identifier, content)] -> Require identifier content a -> f a
forall identifier content (f :: * -> *) a.
(Ord identifier, Eq identifier, Monad f, Alternative f) =>
ComputeMode
-> [(identifier, content)] -> Require identifier content a -> f a
computeRequireG ComputeMode
Final

-- | Evaluate a computation, given a map of key/values for possible
-- parameters. Returns an empty result when alternatives are present and
-- the first choice failed.
computeRequireIntermediate
  :: forall identifier content f a.
     (Ord identifier, Eq identifier, Monad f, Alternative f)
  => [(identifier, content)]
  -> Require identifier content a
  -> f a
computeRequireIntermediate :: forall identifier content (f :: * -> *) a.
(Ord identifier, Eq identifier, Monad f, Alternative f) =>
[(identifier, content)] -> Require identifier content a -> f a
computeRequireIntermediate = ComputeMode
-> [(identifier, content)] -> Require identifier content a -> f a
forall identifier content (f :: * -> *) a.
(Ord identifier, Eq identifier, Monad f, Alternative f) =>
ComputeMode
-> [(identifier, content)] -> Require identifier content a -> f a
computeRequireG ComputeMode
Intermediate

computeRequireG
  :: forall identifier content f a.
     (Ord identifier, Eq identifier, Monad f, Alternative f)
  => ComputeMode
  -> [(identifier, content)]
  -> Require identifier content a
  -> f a
computeRequireG :: forall identifier content (f :: * -> *) a.
(Ord identifier, Eq identifier, Monad f, Alternative f) =>
ComputeMode
-> [(identifier, content)] -> Require identifier content a -> f a
computeRequireG ComputeMode
mode [(identifier, content)]
s = Require identifier content a -> f a
forall x. Require identifier content x -> f x
go
  where
    go :: forall x. Require identifier content x -> f x
    go :: forall x. Require identifier content x -> f x
go Require identifier content x
rq =
      case Require identifier content x
rq of
        Require identifier content x
Empty -> f x
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty
        Pure x
x -> x -> f x
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
x
        Require identifier -> Bool
i ->
          case ((identifier, content) -> Bool)
-> [(identifier, content)] -> [(identifier, content)]
forall a. (a -> Bool) -> [a] -> [a]
filter (identifier -> Bool
i (identifier -> Bool)
-> ((identifier, content) -> identifier)
-> (identifier, content)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (identifier, content) -> identifier
forall a b. (a, b) -> a
fst) [(identifier, content)]
s of
            [] -> f x
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty
            (identifier, content)
x:[(identifier, content)]
_ -> x -> f x
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
(identifier, content)
x
        Ap Require identifier content (a -> x)
r1 Require identifier content a
r2 -> Require identifier content (a -> x) -> f (a -> x)
forall x. Require identifier content x -> f x
go Require identifier content (a -> x)
r1 f (a -> x) -> f a -> f x
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Require identifier content a -> f a
forall x. Require identifier content x -> f x
go Require identifier content a
r2
        Alt Require identifier content x
r1 Require identifier content x
r2 ->
          case ComputeMode
mode of
            ComputeMode
Intermediate -> Require identifier content x -> f x
forall x. Require identifier content x -> f x
go Require identifier content x
r1
            ComputeMode
Final -> Require identifier content x -> f x
forall x. Require identifier content x -> f x
go Require identifier content x
r1 f x -> f x -> f x
forall a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Require identifier content x -> f x
forall x. Require identifier content x -> f x
go Require identifier content x
r2
        HoistContent content -> prevcontent
f Require identifier prevcontent x
r -> ComputeMode
-> [(identifier, prevcontent)]
-> Require identifier prevcontent x
-> f x
forall identifier content (f :: * -> *) a.
(Ord identifier, Eq identifier, Monad f, Alternative f) =>
ComputeMode
-> [(identifier, content)] -> Require identifier content a -> f a
computeRequireG ComputeMode
mode (((identifier, content) -> (identifier, prevcontent))
-> [(identifier, content)] -> [(identifier, prevcontent)]
forall a b. (a -> b) -> [a] -> [b]
map ((content -> prevcontent)
-> (identifier, content) -> (identifier, prevcontent)
forall a b. (a -> b) -> (identifier, a) -> (identifier, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap content -> prevcontent
f) [(identifier, content)]
s) Require identifier prevcontent x
r
        GuardResult x -> Bool
f Require identifier content x
r -> do
          x
r' <- Require identifier content x -> f x
forall x. Require identifier content x -> f x
go Require identifier content x
r
          x
r' x -> f () -> f x
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> f ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (x -> Bool
f x
r')

-- | Checks if a computation can be completed given a set of known identifiers.
isComputable :: (Ord identifier, Eq identifier)
             => S.Set identifier
             -> Require identifier content a
             -> Bool
isComputable :: forall identifier content a.
(Ord identifier, Eq identifier) =>
Set identifier -> Require identifier content a -> Bool
isComputable Set identifier
_ Require identifier content a
Empty = Bool
False
isComputable Set identifier
_ (Pure a
_) = Bool
True
isComputable Set identifier
s (Require identifier -> Bool
i) = (identifier -> Bool) -> Set identifier -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.any identifier -> Bool
i Set identifier
s
isComputable Set identifier
s (Ap Require identifier content (a -> a)
r1 Require identifier content a
r2) = Set identifier -> Require identifier content (a -> a) -> Bool
forall identifier content a.
(Ord identifier, Eq identifier) =>
Set identifier -> Require identifier content a -> Bool
isComputable Set identifier
s Require identifier content (a -> a)
r1 Bool -> Bool -> Bool
&& Set identifier -> Require identifier content a -> Bool
forall identifier content a.
(Ord identifier, Eq identifier) =>
Set identifier -> Require identifier content a -> Bool
isComputable Set identifier
s Require identifier content a
r2
isComputable Set identifier
s (Alt Require identifier content a
r1 Require identifier content a
r2) = Set identifier -> Require identifier content a -> Bool
forall identifier content a.
(Ord identifier, Eq identifier) =>
Set identifier -> Require identifier content a -> Bool
isComputable Set identifier
s Require identifier content a
r1 Bool -> Bool -> Bool
|| Set identifier -> Require identifier content a -> Bool
forall identifier content a.
(Ord identifier, Eq identifier) =>
Set identifier -> Require identifier content a -> Bool
isComputable Set identifier
s Require identifier content a
r2
isComputable Set identifier
s (HoistContent content -> prevcontent
_ Require identifier prevcontent a
f) = Set identifier -> Require identifier prevcontent a -> Bool
forall identifier content a.
(Ord identifier, Eq identifier) =>
Set identifier -> Require identifier content a -> Bool
isComputable Set identifier
s Require identifier prevcontent a
f
isComputable Set identifier
s (GuardResult a -> Bool
_ Require identifier content a
r) = Set identifier -> Require identifier content a -> Bool
forall identifier content a.
(Ord identifier, Eq identifier) =>
Set identifier -> Require identifier content a -> Bool
isComputable Set identifier
s Require identifier content a
r

triggersAnalyzer :: identifier -> Require identifier content a -> Bool
triggersAnalyzer :: forall identifier content a.
identifier -> Require identifier content a -> Bool
triggersAnalyzer identifier
_ Require identifier content a
Empty = Bool
False
triggersAnalyzer identifier
_ (Pure a
_) = Bool
False
triggersAnalyzer identifier
s (Require identifier -> Bool
i) = identifier -> Bool
i identifier
s
triggersAnalyzer identifier
s (Ap Require identifier content (a -> a)
r1 Require identifier content a
r2) = identifier -> Require identifier content (a -> a) -> Bool
forall identifier content a.
identifier -> Require identifier content a -> Bool
triggersAnalyzer identifier
s Require identifier content (a -> a)
r1 Bool -> Bool -> Bool
|| identifier -> Require identifier content a -> Bool
forall identifier content a.
identifier -> Require identifier content a -> Bool
triggersAnalyzer identifier
s Require identifier content a
r2
triggersAnalyzer identifier
s (Alt Require identifier content a
r1 Require identifier content a
r2) = identifier -> Require identifier content a -> Bool
forall identifier content a.
identifier -> Require identifier content a -> Bool
triggersAnalyzer identifier
s Require identifier content a
r1 Bool -> Bool -> Bool
|| identifier -> Require identifier content a -> Bool
forall identifier content a.
identifier -> Require identifier content a -> Bool
triggersAnalyzer identifier
s Require identifier content a
r2
triggersAnalyzer identifier
s (HoistContent content -> prevcontent
_ Require identifier prevcontent a
f) = identifier -> Require identifier prevcontent a -> Bool
forall identifier content a.
identifier -> Require identifier content a -> Bool
triggersAnalyzer identifier
s Require identifier prevcontent a
f
triggersAnalyzer identifier
s (GuardResult a -> Bool
_ Require identifier content a
r) = identifier -> Require identifier content a -> Bool
forall identifier content a.
identifier -> Require identifier content a -> Bool
triggersAnalyzer identifier
s Require identifier content a
r