{-# LANGUAGE BangPatterns #-}
module Data.Zebra.Word.Debug
(
showsTree
, Validity (..)
, Reason (..)
, validate
) where
import Data.Zebra.Word.Internal
import Numeric.Long
import Radix.Word.Foundation
import Radix.Word.Debug
showsTree :: Zebra -> ShowS
showsTree :: Zebra -> ShowS
showsTree = Int -> Zebra -> ShowS
go Int
0
where
go :: Int -> Zebra -> ShowS
go Int
i Zebra
t =
[Char] -> ShowS
forall a. Monoid a => a -> a -> a
mappend (Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
i Char
' ') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
case Zebra
t of
Bin Prefix
p Zebra
l Zebra
r ->
[Char] -> ShowS
showString [Char]
"Bin " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prefix -> ShowS
forall a. (FiniteBits a, Integral a, Num a) => a -> ShowS
showPrefix Prefix
p ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'\n'
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Zebra -> ShowS
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Zebra
l ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'\n'
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Zebra -> ShowS
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Zebra
r
Bla Prefix
k -> Color -> Prefix -> ShowS
forall {a}. (FiniteBits a, Integral a) => Color -> a -> ShowS
goTip Color
Black Prefix
k
Whi Prefix
k -> Color -> Prefix -> ShowS
forall {a}. (FiniteBits a, Integral a) => Color -> a -> ShowS
goTip Color
White Prefix
k
Nil Color
c -> [Char] -> ShowS
showString [Char]
"Nil " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar (Color -> Char
color Color
c)
goTip :: Color -> a -> ShowS
goTip Color
c a
k =
[Char] -> ShowS
showString [Char]
"Tip " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. (FiniteBits a, Integral a, Num a) => a -> ShowS
showLongBin a
k ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" => " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar (Color -> Char
color Color
c)
color :: Color -> Char
color Color
Black = Char
'B'
color Color
White = Char
'W'
data Validity = Valid
| Invalid Reason
deriving Int -> Validity -> ShowS
[Validity] -> ShowS
Validity -> [Char]
(Int -> Validity -> ShowS)
-> (Validity -> [Char]) -> ([Validity] -> ShowS) -> Show Validity
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Validity -> ShowS
showsPrec :: Int -> Validity -> ShowS
$cshow :: Validity -> [Char]
show :: Validity -> [Char]
$cshowList :: [Validity] -> ShowS
showList :: [Validity] -> ShowS
Show
data Reason =
ZeroPrefix
| PrefixBelow Prefix Prefix
| KeyBelow Prefix Key
| FoundNil
| ZeroKey
| NoSwitch Color Key
deriving Int -> Reason -> ShowS
[Reason] -> ShowS
Reason -> [Char]
(Int -> Reason -> ShowS)
-> (Reason -> [Char]) -> ([Reason] -> ShowS) -> Show Reason
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Reason -> ShowS
showsPrec :: Int -> Reason -> ShowS
$cshow :: Reason -> [Char]
show :: Reason -> [Char]
$cshowList :: [Reason] -> ShowS
showList :: [Reason] -> ShowS
Show
data Carry = Carry Color
| Break Reason
validate :: Zebra -> Validity
validate :: Zebra -> Validity
validate Zebra
t0 =
case Zebra -> Carry
go0 Zebra
t0 of
Carry Color
_ -> Validity
Valid
Break Reason
r -> Reason -> Validity
Invalid Reason
r
where
go0 :: Zebra -> Carry
go0 Zebra
t =
case Zebra
t of
Bin Prefix
p Zebra
l Zebra
r
| Prefix
p Prefix -> Prefix -> Bool
forall a. Eq a => a -> a -> Bool
== Prefix
0 -> Reason -> Carry
Break Reason
ZeroPrefix
| Bool
otherwise ->
case S -> Prefix -> Zebra -> Maybe Color -> Carry
go S
L Prefix
p Zebra
l Maybe Color
forall a. Maybe a
Nothing of
Carry Color
cR -> S -> Prefix -> Zebra -> Maybe Color -> Carry
go S
R Prefix
p Zebra
r (Color -> Maybe Color
forall a. a -> Maybe a
Just Color
cR)
Carry
err -> Carry
err
Bla Prefix
_ -> Color -> Carry
Carry Color
Black
Whi Prefix
_ -> Color -> Carry
Carry Color
White
Nil Color
_ -> Reason -> Carry
Break Reason
FoundNil
go :: S -> Prefix -> Zebra -> Maybe Color -> Carry
go S
s Prefix
q Zebra
x Maybe Color
cL =
case Zebra
x of
Bin Prefix
p Zebra
l Zebra
r
| Prefix
p Prefix -> Prefix -> Bool
forall a. Eq a => a -> a -> Bool
== Prefix
0 -> Reason -> Carry
Break Reason
ZeroPrefix
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Prefix -> S -> Prefix -> Bool
validBelow Prefix
q S
s Prefix
p -> Reason -> Carry
Break (Reason -> Carry) -> Reason -> Carry
forall a b. (a -> b) -> a -> b
$ Prefix -> Prefix -> Reason
PrefixBelow Prefix
q Prefix
p
| Bool
otherwise ->
case S -> Prefix -> Zebra -> Maybe Color -> Carry
go S
L Prefix
p Zebra
l Maybe Color
cL of
Carry Color
cR -> S -> Prefix -> Zebra -> Maybe Color -> Carry
go S
R Prefix
p Zebra
r (Color -> Maybe Color
forall a. a -> Maybe a
Just Color
cR)
Carry
err -> Carry
err
Bla Prefix
k -> S -> Prefix -> Prefix -> Maybe Color -> Color -> Carry
goTip S
s Prefix
q Prefix
k Maybe Color
cL Color
Black
Whi Prefix
k -> S -> Prefix -> Prefix -> Maybe Color -> Color -> Carry
goTip S
s Prefix
q Prefix
k Maybe Color
cL Color
White
Nil Color
_ -> Reason -> Carry
Break Reason
FoundNil
goTip :: S -> Prefix -> Prefix -> Maybe Color -> Color -> Carry
goTip S
s Prefix
q Prefix
k Maybe Color
cL Color
c
| Prefix
k Prefix -> Prefix -> Bool
forall a. Eq a => a -> a -> Bool
== Prefix
0 = Reason -> Carry
Break Reason
ZeroKey
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Prefix -> S -> Prefix -> Bool
validBelow Prefix
q S
s Prefix
k = Reason -> Carry
Break (Reason -> Carry) -> Reason -> Carry
forall a b. (a -> b) -> a -> b
$ Prefix -> Prefix -> Reason
KeyBelow Prefix
q Prefix
k
| Just Color
x <- Maybe Color
cL, Color
x Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
c = Reason -> Carry
Break (Reason -> Carry) -> Reason -> Carry
forall a b. (a -> b) -> a -> b
$ Color -> Prefix -> Reason
NoSwitch Color
c Prefix
k
| Bool
otherwise = Color -> Carry
Carry Color
c