module Prednote.Core
(
PredM(..)
, Pred
, predicate
, predicateM
, contramapM
, (&&&)
, (|||)
, not
, switch
, any
, all
, maybe
, addLabel
, true
, false
, same
, test
, testM
, runPred
, verboseTest
, verboseTestStdout
, Condition(..)
, Value(..)
, Label(..)
, Labeled(..)
, Passed(..)
, Failed(..)
, Result(..)
, splitResult
, resultToChunks
, passedToChunks
, failedToChunks
) where
import Rainbow
import Rainbow.Types
import Data.Monoid
import Data.Functor.Contravariant
import Prelude hiding (all, any, maybe, and, or, not)
import qualified Prelude
import qualified Data.Text as X
import Data.List (intersperse)
import Data.Functor.Identity
import Control.Applicative
import qualified Data.ByteString as BS
contramapM
:: Monad m
=> (a -> m b)
-> PredM m b
-> PredM m a
contramapM conv (PredM f) = PredM $ \a -> conv a >>= f
newtype Condition = Condition [Chunk]
deriving (Eq, Ord, Show)
instance Monoid Condition where
mempty = Condition []
mappend (Condition x) (Condition y) = Condition (x ++ y)
newtype Value = Value [Chunk]
deriving (Eq, Ord, Show)
instance Monoid Value where
mempty = Value []
mappend (Value x) (Value y) = Value (x ++ y)
newtype Label = Label [Chunk]
deriving (Eq, Ord, Show)
instance Monoid Label where
mempty = Label []
mappend (Label x) (Label y) = Label (x ++ y)
data Labeled a = Labeled [Label] a
deriving (Eq, Ord, Show)
instance Functor Labeled where
fmap f (Labeled l a) = Labeled l (f a)
data Passed
= PTerminal Value Condition
| PAnd (Labeled Passed) (Labeled Passed)
| POr (Either (Labeled Passed) (Labeled Failed, Labeled Passed))
| PNot (Labeled Failed)
deriving (Eq, Ord, Show)
data Failed
= FTerminal Value Condition
| FAnd (Either (Labeled Failed) (Labeled Passed, Labeled Failed))
| FOr (Labeled Failed) (Labeled Failed)
| FNot (Labeled Passed)
deriving (Eq, Ord, Show)
newtype Result = Result (Labeled (Either Failed Passed))
deriving (Eq, Ord, Show)
splitResult
:: Result
-> Either (Labeled Failed) (Labeled Passed)
splitResult (Result (Labeled l ei)) = case ei of
Left n -> Left (Labeled l n)
Right g -> Right (Labeled l g)
newtype PredM f a = PredM { runPredM :: (a -> f Result) }
type Pred = PredM Identity
runPred :: Pred a -> a -> Result
runPred (PredM f) a = runIdentity $ f a
instance Show (PredM f a) where
show _ = "Pred"
instance Contravariant (PredM f) where
contramap f (PredM g) = PredM (g . f)
predicateM
:: Functor f
=> (a -> f (Bool, Value, Condition))
-> PredM f a
predicateM f = PredM f'
where
f' a = fmap mkResult $ f a
where
mkResult (b, val, cond) = Result (Labeled [] r)
where
r | b = Right (PTerminal val cond)
| otherwise = Left (FTerminal val cond)
predicate
:: (a -> (Bool, Value, Condition))
-> Pred a
predicate f = predicateM (fmap return f)
(&&&) :: Monad m => PredM m a -> PredM m a -> PredM m a
(PredM fL) &&& r = PredM $ \a -> do
resL <- fL a
ei <- case splitResult resL of
Left n -> return (Left (FAnd (Left n)))
Right g -> do
let PredM fR = r
resR <- fR a
return $ case splitResult resR of
Left b -> Left (FAnd (Right (g, b)))
Right g' -> Right (PAnd g g')
return (Result (Labeled [] ei))
infixr 3 &&&
(|||) :: Monad m => PredM m a -> PredM m a -> PredM m a
(PredM fL) ||| r = PredM $ \a -> do
resL <- fL a
ei <- case splitResult resL of
Left b -> do
let PredM fR = r
resR <- fR a
return $ case splitResult resR of
Left b' -> Left $ FOr b b'
Right g -> Right $ POr (Right (b, g))
Right g -> return (Right (POr (Left g)))
return (Result (Labeled [] ei))
infixr 2 |||
not :: Functor m => PredM m a -> PredM m a
not (PredM f) = PredM $ \a -> fmap g (f a)
where
g a = Result (Labeled [] rslt)
where
rslt = case splitResult a of
Left b -> Right (PNot b)
Right y -> Left (FNot y)
switch
:: PredM m a
-> PredM m b
-> PredM m (Either a b)
switch pa pb = PredM (either fa fb)
where
PredM fa = pa
PredM fb = pb
resultToBool :: Result -> Bool
resultToBool (Result (Labeled _ ei))
= either (const False) (const True) ei
true :: Applicative f => PredM f a
true = predicateM (const (pure trip))
where
trip = (True, mempty, Condition ["always returns True"])
false :: Applicative f => PredM f a
false = predicateM (const (pure trip))
where
trip = (False, mempty, Condition ["always returns False"])
same :: Applicative f => PredM f Bool
same = predicateM
(\b -> pure (b, (Value [(chunkFromText . X.pack . show $ b)]),
Condition ["is returned"]))
addLabel :: Functor f => [Chunk] -> PredM f a -> PredM f a
addLabel s (PredM f) = PredM f'
where
f' a = fmap g (f a)
where
g (Result (Labeled ss ei)) = Result (Labeled (Label s : ss) ei)
any :: (Monad m, Applicative m) => PredM m a -> PredM m [a]
any pa = contramap f (switch (addLabel ["cons cell"] pConsCell) pEnd)
where
pConsCell =
contramap fst (addLabel ["head"] pa)
||| contramap snd (addLabel ["tail"] (any pa))
f ls = case ls of
[] -> Right ()
x:xs -> Left (x, xs)
pEnd = predicateM (const (pure (False, Value ["end of list"],
Condition ["always returns False"])))
all :: (Monad m, Applicative m) => PredM m a -> PredM m [a]
all pa = contramap f (switch (addLabel ["cons cell"] pConsCell) pEnd)
where
pConsCell =
contramap fst (addLabel ["head"] pa)
&&& contramap snd (addLabel ["tail"] (all pa))
f ls = case ls of
x:xs -> Left (x, xs)
[] -> Right ()
pEnd = predicateM (const (pure (True, Value ["end of list"],
Condition ["always returns True"])))
maybe
:: Applicative m
=> Bool
-> PredM m a
-> PredM m (Maybe a)
maybe onEmp pa = contramap f
(switch emp (addLabel ["Just value"] pa))
where
emp | onEmp = predicateM (const
(pure (True, noth, Condition ["always returns True"])))
| otherwise = predicateM (const
(pure (False, noth, Condition ["always returns False"])))
noth = Value ["Nothing"]
f may = case may of
Nothing -> Left ()
Just a -> Right a
explainAnd :: [Chunk]
explainAnd = ["(and)"]
explainOr :: [Chunk]
explainOr = ["(or)"]
explainNot :: [Chunk]
explainNot = ["(not)"]
testM :: Functor f => PredM f a -> a -> f Bool
testM (PredM p) = fmap (either (const False) (const True))
. fmap splitResult . p
test :: Pred a -> a -> Bool
test p a = runIdentity $ testM p a
verboseTestM :: Functor f => PredM f a -> a -> f ([Chunk], Bool)
verboseTestM (PredM f) a = fmap g (f a)
where
g rslt = (resultToChunks rslt, resultToBool rslt)
verboseTest :: Pred a -> a -> ([Chunk], Bool)
verboseTest p a = runIdentity $ verboseTestM p a
resultToChunks :: Result -> [Chunk]
resultToChunks = either (failedToChunks 0) (passedToChunks 0)
. splitResult
lblTrue :: [Chunk]
lblTrue = ["[", fore green <> "TRUE", "]"]
lblFalse :: [Chunk]
lblFalse = ["[", fore red <> "FALSE", "]"]
(<+>) :: [Chunk] -> [Chunk] -> [Chunk]
l <+> r
| full l && full r = l <> [" "] <> r
| otherwise = l <> r
where
full = Prelude.not . chunksNull
(<->) :: [Chunk] -> [Chunk] -> [Chunk]
l <-> r
| full l && full r = l <> hyphen <> r
| otherwise = l <> r
where
full = Prelude.not . chunksNull
hyphen :: [Chunk]
hyphen = [" - "]
chunksNull :: [Chunk] -> Bool
chunksNull = Prelude.all $ Prelude.all X.null . chunkTexts
indentAmt :: Int
indentAmt = 2
spaces :: Int -> [Chunk]
spaces i = (:[]) . chunkFromText . X.replicate (i * indentAmt)
. X.singleton $ ' '
newline :: [Chunk]
newline = ["\n"]
labelToChunks :: Label -> [Chunk]
labelToChunks (Label cks) = cks
explainTerminal :: Value -> Condition -> [Chunk]
explainTerminal (Value v) (Condition c)
= v ++ (" " : c)
passedToChunks
:: Int
-> Labeled Passed
-> [Chunk]
passedToChunks i (Labeled l p) = this <> rest
where
this = spaces i <> (lblTrue <+> (labels `sep` explain)) <> newline
labels = concat . intersperse hyphen . map labelToChunks $ l
nextPass = passedToChunks (succ i)
nextFail = failedToChunks (succ i)
(explain, rest, sep) = case p of
PTerminal v c -> (explainTerminal v c, [], (<->))
PAnd p1 p2 -> (explainAnd, nextPass p1 <> nextPass p2, (<+>))
POr ei -> (explainOr, more, (<+>))
where
more = case ei of
Left y -> nextPass y
Right (n, y) -> nextFail n <> nextPass y
PNot n -> (explainNot, nextFail n, (<+>))
failedToChunks
:: Int
-> Labeled Failed
-> [Chunk]
failedToChunks i (Labeled l p) = this <> rest
where
this = spaces i <> (lblFalse <+> (labels `sep` explain)) <> newline
labels = concat . intersperse hyphen . map labelToChunks $ l
nextPass = passedToChunks (succ i)
nextFail = failedToChunks (succ i)
(explain, rest, sep) = case p of
FTerminal v c -> (explainTerminal v c, [], (<->))
FAnd ei -> (explainAnd, more, (<+>))
where
more = case ei of
Left n -> nextFail n
Right (y, n) -> nextPass y <> nextFail n
FOr n1 n2 -> (explainOr, nextFail n1 <> nextFail n2, (<+>))
FNot y -> (explainNot, nextPass y, (<+>))
verboseTestStdout :: Pred a -> a -> IO Bool
verboseTestStdout p a = do
let (cks, r) = verboseTest p a
mkr <- byteStringMakerFromEnvironment
mapM_ BS.putStr . chunksToByteStrings mkr $ cks
return r