{-# LANGUAGE BangPatterns #-}

{-|
    Safe functions for datatype introspection.
 -}

module Data.Zebra.Word.Debug
  ( -- * Show
    showsTree

    -- * Validate
  , Validity (..)
  , Reason (..)
  , validate
  ) where

import           Data.Zebra.Word.Internal
import           Numeric.Long
import           Radix.Word.Foundation
import           Radix.Word.Debug



-- | \(\mathcal{O}(n)\).
--   Shows the internal structure of the tree.
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'



-- | Whether the tree is well-formed.
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

-- | Reason for why the tree is considered malformed.
data Reason = -- | Prefix is @0@.
              ZeroPrefix
              -- | Prefix below diverges from the prefix above
            | PrefixBelow Prefix Prefix
              -- | Key diverges the prefix above
            | KeyBelow Prefix Key
              -- | Nil is in the tree.
            | FoundNil
              -- | Tip has a value of zero despite not being the root.
            | ZeroKey
              -- | Key has the same color as the key to the left of it.
            | 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

-- | \(\mathcal{O}(n)\).
--   Checks whether the tree is well-formed.
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