module Data.Prednote.Pdct
(
Label
, Hide
, Pdct(..)
, Node(..)
, operand
, and
, or
, not
, (&&&)
, (|||)
, always
, never
, boxPdct
, boxNode
, hide
, show
, hideTrue
, hideFalse
, rename
, Result(..)
, RNode(..)
, evaluate
, evaluateNode
, IndentAmt
, Level
, ShowAll
, showResult
, showTopResult
, showPdct
, filter
, verboseFilter
, compareBy
, compareByMaybe
, greaterBy
, lessBy
, equalBy
, greaterEqBy
, lessEqBy
, notEqBy
, compare
, greater
, less
, equal
, greaterEq
, lessEq
, notEq
, parseComparer
) where
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 Pdct a = Pdct
{ pLabel :: Label
, pHide :: (Bool -> Hide)
, pNode :: Node a
}
data Node a
= And [Pdct a]
| Or [Pdct a]
| Not (Pdct a)
| Operand (a -> Bool)
rename :: (Text -> Text) -> Pdct a -> Pdct a
rename f p = p { pLabel = f (pLabel p) }
always :: Pdct a
always = Pdct "always True" (const False) (Operand (const True))
never :: Pdct a
never = Pdct "always False" (const False) (Operand (const False))
operand :: Label -> (a -> Bool) -> Pdct a
operand l = Pdct l (const False) . Operand
and :: [Pdct a] -> Pdct a
and = Pdct "and" (const False) . And
or :: [Pdct a] -> Pdct a
or = Pdct "or" (const False) . Or
not :: Pdct a -> Pdct a
not = Pdct "not" (const False) . Not
hide :: Pdct a -> Pdct a
hide p = p { pHide = const True }
show :: Pdct a -> Pdct a
show p = p { pHide = const False }
hideTrue :: Pdct a -> Pdct a
hideTrue p = p { pHide = id }
hideFalse :: Pdct a -> Pdct a
hideFalse p = p { pHide = Prelude.not }
(&&&) :: Pdct a -> Pdct a -> Pdct a
(&&&) x y = Pdct "and" (const False) (And [x, y])
infixr 3 &&&
(|||) :: Pdct a -> Pdct a -> Pdct a
(|||) x y = Pdct "or" (const False) (Or [x, y])
infixr 2 |||
boxPdct
:: (b -> a)
-> Pdct a
-> Pdct b
boxPdct f (Pdct l d n) = Pdct l d $ boxNode f n
boxNode
:: (b -> a)
-> Node a
-> Node b
boxNode f n = case n of
And ls -> And $ map (boxPdct f) ls
Or ls -> Or $ map (boxPdct f) ls
Not o -> Not $ boxPdct f o
Operand g -> Operand $ \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
| ROperand Bool
deriving (Eq, Show)
evaluate :: a -> Pdct a -> Result
evaluate a (Pdct l d n) = Result l r d' rn
where
rn = evaluateNode a n
r = case rn of
RAnd ls -> all rBool ls
ROr ls -> any rBool ls
RNot x -> Prelude.not . rBool $ x
ROperand b -> b
d' = d r
evaluateNode :: a -> Node a -> RNode
evaluateNode a n = case n of
And ls -> RAnd (map (evaluate a) ls)
Or ls -> ROr (map (evaluate a) ls)
Not l -> RNot (evaluate a l)
Operand f -> ROperand (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
showPdct :: IndentAmt -> Level -> Pdct a -> [R.Chunk]
showPdct amt lvl (Pdct l _ pd) = case pd of
And ls -> indent amt lvl [plain ("and - " <> l)]
<> mconcat (map (showPdct amt (lvl + 1)) ls)
Or ls -> indent amt lvl [plain ("or - " <> l)]
<> mconcat (map (showPdct amt (lvl + 1)) ls)
Not t -> indent amt lvl [plain ("not - " <> l)]
<> showPdct amt (lvl + 1) t
Operand _ -> indent amt lvl [plain ("operand - " <> l)]
instance Show (Pdct a) where
show = X.unpack
. X.concat
. map R.text
. showPdct 2 0
filter :: Pdct a -> [a] -> [a]
filter pd as
= map fst
. Prelude.filter (rBool . snd)
. zip as
. map (flip 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"
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
ROperand _ -> []
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
-> Pdct a
-> [a]
-> ([R.Chunk], [a])
verboseFilter desc amt sa pd as = (chks, as')
where
rs = map (flip 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
-> Pdct a
compareBy itemDesc typeDesc cmp ord = Pdct l (const False) (Operand 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
-> Pdct 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
-> Pdct a
compareByMaybe itemDesc typeDesc cmp ord =
Pdct l (const False) (Operand 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
-> Pdct a
greater d a = compare d a GT
less
:: (Show a, Ord a)
=> Text
-> a
-> Pdct a
less d a = compare d a LT
equal
:: (Show a, Ord a)
=> Text
-> a
-> Pdct a
equal d a = compare d a EQ
greaterEq
:: (Show a, Ord a)
=> Text
-> a
-> Pdct a
greaterEq d a = greater d a ||| equal d a
lessEq
:: (Show a, Ord a)
=> Text
-> a
-> Pdct a
lessEq d a = less d a ||| equal d a
notEq
:: (Show a, Ord a)
=> Text
-> a
-> Pdct a
notEq d a = not $ equal d a
greaterBy
:: Text
-> Text
-> (a -> Ordering)
-> Pdct a
greaterBy iD tD cmp = compareBy iD tD cmp GT
lessBy
:: Text
-> Text
-> (a -> Ordering)
-> Pdct a
lessBy iD tD cmp = compareBy iD tD cmp LT
equalBy
:: Text
-> Text
-> (a -> Ordering)
-> Pdct a
equalBy iD tD cmp = compareBy iD tD cmp EQ
greaterEqBy
:: Text
-> Text
-> (a -> Ordering)
-> Pdct a
greaterEqBy iD tD cmp =
greaterBy iD tD cmp ||| equalBy iD tD cmp
lessEqBy
:: Text
-> Text
-> (a -> Ordering)
-> Pdct a
lessEqBy iD tD cmp =
lessBy iD tD cmp ||| equalBy iD tD cmp
notEqBy
:: Text
-> Text
-> (a -> Ordering)
-> Pdct a
notEqBy iD tD cmp =
not $ equalBy iD tD cmp
parseComparer
:: Text
-> (Ordering -> Pdct a)
-> Maybe (Pdct 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