module Data.Prednote.Pdct
(
Label
, Pdct(..)
, Node(..)
, rename
, always
, never
, operand
, and
, or
, not
, neverFalse
, neverTrue
, (&&&)
, (|||)
, boxPdct
, boxNode
, Level
, IndentAmt
, ShowDiscards
, showPdct
, eval
, evaluate
, filter
, compareBy
, compareByMaybe
, greaterBy
, lessBy
, equalBy
, greaterEqBy
, lessEqBy
, notEqBy
, compare
, greater
, less
, equal
, greaterEq
, lessEq
, notEq
, parseComparer
) where
import Control.Applicative ((<*>))
import Data.Maybe (fromMaybe, isJust, catMaybes)
import Data.Text (Text)
import qualified Data.Text as X
import Data.Monoid ((<>), mconcat, mempty)
import qualified System.Console.Rainbow as R
import System.Console.Rainbow ((+.+))
import Prelude hiding (not, and, or, compare, filter)
import qualified Prelude
type Label = Text
data Pdct a = Pdct Label (Node a)
instance Show (Pdct a) where
show = X.unpack
. X.concat
. map R.chunkText
. showPdct 2 0
rename :: (Text -> Text) -> Pdct a -> Pdct a
rename f (Pdct l n) = Pdct (f l) n
data Node a
= And [Pdct a]
| Or [Pdct a]
| Not (Pdct a)
| NeverFalse (Pdct a)
| NeverTrue (Pdct a)
| Operand (a -> Maybe Bool)
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
NeverFalse o -> NeverFalse $ boxPdct f o
NeverTrue o -> NeverTrue $ boxPdct f o
Operand g -> Operand $ \b -> g (f b)
boxPdct
:: (b -> a)
-> Pdct a
-> Pdct b
boxPdct f (Pdct l n) = Pdct l $ boxNode f n
and :: [Pdct a] -> Pdct a
and = Pdct "and" . And
or :: [Pdct a] -> Pdct a
or = Pdct "or" . Or
not :: Pdct a -> Pdct a
not = Pdct "not" . Not
operand :: Text -> (a -> Bool) -> Pdct a
operand t = Pdct t . Operand . fmap Just
neverFalse :: Pdct a -> Pdct a
neverFalse = Pdct "never False" . NeverFalse
neverTrue :: Pdct a -> Pdct a
neverTrue = Pdct "never True" . NeverTrue
always :: Pdct a
always = Pdct "always True" (Operand (const (Just True)))
never :: Pdct a
never = Pdct "always False" (Operand (const (Just False)))
(&&&) :: Pdct a -> Pdct a -> Pdct a
(&&&) x y = Pdct "and" (And [x, y])
infixr 3 &&&
(|||) :: Pdct a -> Pdct a -> Pdct a
(|||) x y = Pdct "or" (Or [x, y])
infixr 2 |||
type Level = Int
type IndentAmt = Int
indent :: IndentAmt -> Level -> [R.Chunk] -> [R.Chunk]
indent amt lvl cs = idt : (cs ++ [nl])
where
idt = R.plain (X.replicate (lvl * amt) " ")
nl = R.plain (X.singleton '\n')
showPdct :: IndentAmt -> Level -> Pdct a -> [R.Chunk]
showPdct amt lvl (Pdct l pd) = case pd of
And ls -> indent amt lvl [R.plain l]
<> mconcat (map (showPdct amt (lvl + 1)) ls)
Or ls -> indent amt lvl [R.plain l]
<> mconcat (map (showPdct amt (lvl + 1)) ls)
Not t -> indent amt lvl [R.plain l]
<> showPdct amt (lvl + 1) t
NeverFalse t -> indent amt lvl [R.plain l]
<> showPdct amt (lvl + 1) t
NeverTrue t -> indent amt lvl [R.plain l]
<> showPdct amt (lvl + 1) t
Operand _ -> indent amt lvl [R.plain l]
labelBool :: Text -> Maybe Bool -> [R.Chunk]
labelBool t b = [open, trueFalse, close, blank, txt]
where
trueFalse = case b of
Nothing -> R.plain "discard" +.+ R.f_yellow
Just bl -> if bl
then R.plain "TRUE" +.+ R.f_green
else R.plain "FALSE" +.+ R.f_red
open = R.plain "["
close = R.plain "]"
blank = R.plain (X.replicate blankLen " ")
blankLen = X.length "discard"
X.length (R.chunkText trueFalse) + 1
txt = R.plain t
type ShowDiscards = Bool
eval :: Pdct a -> a -> Maybe Bool
eval (Pdct _ n) a = case n of
And ps -> Just . Prelude.and . catMaybes $ [flip eval a] <*> ps
Or ps -> Just . Prelude.or . catMaybes $ [flip eval a] <*> ps
Not p -> fmap Prelude.not $ eval p a
NeverFalse p -> case eval p a of
Nothing -> Nothing
Just b -> if Prelude.not b then Nothing else Just b
NeverTrue p -> case eval p a of
Nothing -> Nothing
Just b -> if b then Nothing else Just b
Operand f -> f a
evaluate
:: IndentAmt
-> ShowDiscards
-> a
-> Level
-> Pdct a
-> (Maybe Bool, [R.Chunk])
evaluate i sd a lvl (Pdct l pd) = case pd of
And ps -> let (resBool, resTxt) = evalAnd i sd a (lvl + 1) ps
txt = indent i lvl (labelBool l (Just resBool))
<> resTxt
in (Just resBool, txt)
Or ps -> let (resBool, resTxt) = evalOr i sd a (lvl + 1) ps
txt = indent i lvl (labelBool l (Just resBool))
<> resTxt
in (Just resBool, txt)
Not p -> let (childMayBool, childTxt) = evaluate i sd a (lvl + 1) p
thisMayBool = fmap Prelude.not childMayBool
thisTxt = indent i lvl (labelBool l thisMayBool)
txt = if sd || isJust thisMayBool
then thisTxt <> childTxt else mempty
in (thisMayBool, txt)
NeverFalse p ->
let (childMayBool, childTxt) = evaluate i sd a (lvl + 1) p
thisMayBool = case childMayBool of
Nothing -> Nothing
Just b -> if Prelude.not b then Nothing else Just b
thisTxt = indent i lvl (labelBool l thisMayBool)
txt = if sd || isJust thisMayBool
then thisTxt <> childTxt else mempty
in (thisMayBool, txt)
NeverTrue p ->
let (childMayBool, childTxt) = evaluate i sd a (lvl + 1) p
thisMayBool = case childMayBool of
Nothing -> Nothing
Just b -> if b then Nothing else Just b
thisTxt = indent i lvl (labelBool l thisMayBool)
txt = if sd || isJust thisMayBool
then thisTxt <> childTxt else mempty
in (thisMayBool, txt)
Operand p -> let res = p a
txt = indent i lvl (labelBool l res)
in (res, if sd || isJust res then txt else mempty)
evalAnd :: IndentAmt -> ShowDiscards -> a
-> Level -> [Pdct a] -> (Bool, [R.Chunk])
evalAnd i sd a l ts = (Prelude.not foundFalse, txt)
where
(foundFalse, txt) = go ts (False, mempty)
go [] p = p
go (x:xs) (fndFalse, acc) =
if fndFalse
then (fndFalse, acc <> indent i l
[R.plain "(short circuit)"])
else let (res, cTxt) = evaluate i sd a l x
fndFalse' = maybe False Prelude.not res
in go xs (fndFalse', acc <> cTxt)
evalOr :: IndentAmt -> ShowDiscards -> a
-> Level -> [Pdct a] -> (Bool, [R.Chunk])
evalOr i sd a l ts = (foundTrue, txt)
where
(foundTrue, txt) = go ts (False, mempty)
go [] p = p
go (x:xs) (fnd, acc) =
if fnd
then (fnd, acc <> indent i l
[R.plain "(short circuit)"])
else let (res, cTxt) = evaluate i sd a l x
fnd' = fromMaybe False res
in go xs (fnd', acc <> cTxt)
filter
:: IndentAmt
-> ShowDiscards
-> Level
-> (a -> Text)
-> Pdct a
-> [a]
-> ([a], [R.Chunk])
filter ident sd lvl swr pdct items =
let pds = map mkPd items
mkPd a = rename (\x -> mconcat [x, " - ", swr a]) pdct
results = zipWith mkResult pds items
mkResult p i = (evaluate ident sd i lvl p, i)
folder ((maybeBool, cks), i) (as, cksOld) = (as', cks ++ cksOld)
where
as' = if fromMaybe False maybeBool
then i:as
else as
in foldr folder ([], []) results
compareBy
:: Text
-> Text
-> (a -> Ordering)
-> Ordering
-> Pdct a
compareBy itemDesc typeDesc cmp ord = Pdct l (Operand f)
where
l = typeDesc <> " is " <> cmpDesc <> " " <> itemDesc
cmpDesc = case ord of
LT -> "less than"
GT -> "greater than"
EQ -> "equal to"
f subj = Just $ cmp subj == ord
compareByMaybe
:: Text
-> Text
-> (a -> Maybe Ordering)
-> Ordering
-> Pdct a
compareByMaybe itemDesc typeDesc cmp ord = Pdct l (Operand f)
where
l = typeDesc <> " is " <> cmpDesc <> " " <> itemDesc
cmpDesc = case ord of
LT -> "less than"
GT -> "greater than"
EQ -> "equal to"
f subj = maybe Nothing (Just . (== ord)) $ cmp subj
compare
:: (Show a, Ord a)
=> Text
-> a
-> Ordering
-> Pdct a
compare typeDesc a ord = compareBy itemDesc typeDesc cmp ord
where
itemDesc = X.pack . show $ a
cmp item = Prelude.compare item a
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