module Data.Prednote.Predbox
(
Label
, Hide
, Predbox(..)
, Node(..)
, predicate
, and
, or
, not
, (&&&)
, (|||)
, always
, never
, hide
, show
, hideTrue
, hideFalse
, rename
, Result(..)
, RNode(..)
, evaluate
, evaluateNode
, IndentAmt
, Level
, ShowAll
, showResult
, showTopResult
, showPredbox
, filter
, verboseFilter
, compareBy
, compareByMaybe
, greaterBy
, lessBy
, equalBy
, greaterEqBy
, lessEqBy
, notEqBy
, compare
, greater
, less
, equal
, greaterEq
, lessEq
, notEq
, parseComparer
) where
import Data.Functor.Contravariant hiding (Predicate)
import Data.Text (Text)
import qualified Data.Text as X
import Data.Monoid ((<>), mconcat, mempty)
import Data.String (fromString)
import qualified System.Console.Rainbow as R
import Prelude hiding (not, and, or, compare, filter, show)
import qualified Prelude
type Label = Text
type Hide = Bool
data Predbox a = Predbox
{ pLabel :: Label
, pHide :: (Bool -> Hide)
, pNode :: Node a
}
data Node a
= And [Predbox a]
| Or [Predbox a]
| Not (Predbox a)
| Predicate (a -> Bool)
rename :: (Text -> Text) -> Predbox a -> Predbox a
rename f p = p { pLabel = f (pLabel p) }
always :: Predbox a
always = Predbox "always True" (const False) (Predicate (const True))
never :: Predbox a
never = Predbox "always False" (const False) (Predicate (const False))
predicate :: Label -> (a -> Bool) -> Predbox a
predicate l = Predbox l (const False) . Predicate
and :: [Predbox a] -> Predbox a
and = Predbox "and" (const False) . And
or :: [Predbox a] -> Predbox a
or = Predbox "or" (const False) . Or
not :: Predbox a -> Predbox a
not = Predbox "not" (const False) . Not
hide :: Predbox a -> Predbox a
hide p = p { pHide = const True }
show :: Predbox a -> Predbox a
show p = p { pHide = const False }
hideTrue :: Predbox a -> Predbox a
hideTrue p = p { pHide = id }
hideFalse :: Predbox a -> Predbox a
hideFalse p = p { pHide = Prelude.not }
(&&&) :: Predbox a -> Predbox a -> Predbox a
(&&&) x y = Predbox "and" (const False) (And [x, y])
infixr 3 &&&
(|||) :: Predbox a -> Predbox a -> Predbox a
(|||) x y = Predbox "or" (const False) (Or [x, y])
infixr 2 |||
instance Contravariant Predbox where
contramap f (Predbox l d n) = Predbox l d $ contramap f n
instance Contravariant Node where
contramap f n = case n of
And ls -> And $ map (contramap f) ls
Or ls -> Or $ map (contramap f) ls
Not o -> Not $ contramap f o
Predicate g -> Predicate $ \b -> g (f b)
data Result = Result
{ rLabel :: Label
, rBool :: Bool
, rHide :: Hide
, rNode :: RNode
} deriving (Eq, Show)
data RNode
= RAnd [Result]
| ROr [Result]
| RNot Result
| RPredicate Bool
deriving (Eq, Show)
evaluate :: Predbox a -> a -> Result
evaluate (Predbox l d n) a = Result l r d' rn
where
rn = evaluateNode n a
r = case rn of
RAnd ls -> all rBool ls
ROr ls -> any rBool ls
RNot x -> Prelude.not . rBool $ x
RPredicate b -> b
d' = d r
evaluateNode :: Node a -> a -> RNode
evaluateNode n a = case n of
And ls -> RAnd (map (flip evaluate a) ls)
Or ls -> ROr (map (flip evaluate a) ls)
Not l -> RNot (flip evaluate a l)
Predicate f -> RPredicate (f a)
type IndentAmt = Int
type Level = Int
indent :: IndentAmt -> Level -> [R.Chunk] -> [R.Chunk]
indent amt lvl cs = idt : (cs ++ [nl])
where
idt = fromString (replicate (lvl * amt) ' ')
nl = fromString "\n"
plain :: Text -> R.Chunk
plain = R.Chunk mempty . (:[])
showPredbox :: IndentAmt -> Level -> Predbox a -> [R.Chunk]
showPredbox amt lvl (Predbox l _ pd) = case pd of
And ls -> indent amt lvl [plain ("and - " <> l)]
<> mconcat (map (showPredbox amt (lvl + 1)) ls)
Or ls -> indent amt lvl [plain ("or - " <> l)]
<> mconcat (map (showPredbox amt (lvl + 1)) ls)
Not t -> indent amt lvl [plain ("not - " <> l)]
<> showPredbox amt (lvl + 1) t
Predicate _ -> indent amt lvl [plain ("predicate - " <> l)]
instance Show (Predbox a) where
show = X.unpack
. X.concat
. concat
. map R.text
. showPredbox 2 0
filter :: Predbox a -> [a] -> [a]
filter pd as
= map fst
. Prelude.filter (rBool . snd)
. zip as
. map (evaluate pd)
$ as
labelBool :: Text -> Bool -> [R.Chunk]
labelBool t b = [open, trueFalse, close, blank, txt]
where
trueFalse =
if b then "TRUE" <> R.f_green else "FALSE" <> R.f_red
open = "["
close = "]"
blank = plain (X.replicate blankLen " ")
blankLen = X.length "discard"
(sum . map X.length . R.text $ trueFalse) + 1
txt = plain t
type ShowAll = Bool
showResult
:: IndentAmt
-> ShowAll
-> Level
-> Result
-> [R.Chunk]
showResult amt sa lvl (Result lbl rslt hd nd)
| hd && Prelude.not sa = []
| otherwise = firstLine ++ restLines
where
firstLine = indent amt lvl $ labelBool lbl rslt
restLines = case nd of
RAnd ls -> f False ls
ROr ls -> f True ls
RNot r -> showResult amt sa (lvl + 1) r
RPredicate _ -> []
f stopOn ls = concatMap sr ls' ++ end
where
ls' = takeThrough ((== stopOn) . rBool) ls
sr = showResult amt sa (lvl + 1)
end = if ls' `shorter` ls
then indent amt (lvl + 1) ["(short circuit)"]
else []
shorter :: [a] -> [a] -> Bool
shorter [] [] = False
shorter (_:_) [] = False
shorter [] (_:_) = True
shorter (_:xs) (_:ys) = shorter xs ys
takeThrough :: (a -> Bool) -> [a] -> [a]
takeThrough _ [] = []
takeThrough f (x:xs) = x : if f x then [] else takeThrough f xs
showTopResult
:: X.Text
-> IndentAmt
-> Level
-> ShowAll
-> Result
-> [R.Chunk]
showTopResult txt i lvl sd r = showResult i sd lvl r'
where
r' = r { rLabel = rLabel r <> " - " <> txt }
verboseFilter
:: (a -> X.Text)
-> IndentAmt
-> ShowAll
-> Predbox a
-> [a]
-> ([R.Chunk], [a])
verboseFilter desc amt sa pd as = (chks, as')
where
rs = map (evaluate pd) as
subjAndRslts = zip as rs
mkChks (subj, rslt) = showTopResult (desc subj) amt 0 sa rslt
chks = concatMap mkChks subjAndRslts
as' = map fst . Prelude.filter (rBool . snd) $ subjAndRslts
compareBy
:: Text
-> Text
-> (a -> Ordering)
-> Ordering
-> Predbox a
compareBy itemDesc typeDesc cmp ord = Predbox l (const False) (Predicate f)
where
l = typeDesc <> " is " <> cmpDesc <> " " <> itemDesc
cmpDesc = case ord of
LT -> "less than"
GT -> "greater than"
EQ -> "equal to"
f subj = cmp subj == ord
compare
:: (Show a, Ord a)
=> Text
-> a
-> Ordering
-> Predbox a
compare typeDesc a ord = compareBy itemDesc typeDesc cmp ord
where
itemDesc = X.pack . Prelude.show $ a
cmp item = Prelude.compare item a
compareByMaybe
:: Text
-> Text
-> (a -> Maybe Ordering)
-> Ordering
-> Predbox a
compareByMaybe itemDesc typeDesc cmp ord =
Predbox l (const False) (Predicate f)
where
l = typeDesc <> " is " <> cmpDesc <> " " <> itemDesc
cmpDesc = case ord of
LT -> "less than"
GT -> "greater than"
EQ -> "equal to"
f subj = case cmp subj of
Nothing -> False
Just ord' -> ord == ord'
greater
:: (Show a, Ord a)
=> Text
-> a
-> Predbox a
greater d a = compare d a GT
less
:: (Show a, Ord a)
=> Text
-> a
-> Predbox a
less d a = compare d a LT
equal
:: (Show a, Ord a)
=> Text
-> a
-> Predbox a
equal d a = compare d a EQ
greaterEq
:: (Show a, Ord a)
=> Text
-> a
-> Predbox a
greaterEq d a = greater d a ||| equal d a
lessEq
:: (Show a, Ord a)
=> Text
-> a
-> Predbox a
lessEq d a = less d a ||| equal d a
notEq
:: (Show a, Ord a)
=> Text
-> a
-> Predbox a
notEq d a = not $ equal d a
greaterBy
:: Text
-> Text
-> (a -> Ordering)
-> Predbox a
greaterBy iD tD cmp = compareBy iD tD cmp GT
lessBy
:: Text
-> Text
-> (a -> Ordering)
-> Predbox a
lessBy iD tD cmp = compareBy iD tD cmp LT
equalBy
:: Text
-> Text
-> (a -> Ordering)
-> Predbox a
equalBy iD tD cmp = compareBy iD tD cmp EQ
greaterEqBy
:: Text
-> Text
-> (a -> Ordering)
-> Predbox a
greaterEqBy iD tD cmp =
greaterBy iD tD cmp ||| equalBy iD tD cmp
lessEqBy
:: Text
-> Text
-> (a -> Ordering)
-> Predbox a
lessEqBy iD tD cmp =
lessBy iD tD cmp ||| equalBy iD tD cmp
notEqBy
:: Text
-> Text
-> (a -> Ordering)
-> Predbox a
notEqBy iD tD cmp =
not $ equalBy iD tD cmp
parseComparer
:: Text
-> (Ordering -> Predbox a)
-> Maybe (Predbox a)
parseComparer t f
| t == ">" = Just (f GT)
| t == "<" = Just (f LT)
| t == "=" = Just (f EQ)
| t == "==" = Just (f EQ)
| t == ">=" = Just (f GT ||| f EQ)
| t == "<=" = Just (f LT ||| f EQ)
| t == "/=" = Just (not $ f EQ)
| t == "!=" = Just (not $ f EQ)
| otherwise = Nothing