{-# LANGUAGE GADTs #-}
{-# LANGUAGE Safe  #-}
{-# OPTIONS_HADDOCK not-home #-}
module Kleene.Internal.Pretty (
    Pretty (..),
    putPretty,
    ) where

import Data.Monoid          (Endo (..))
import Data.RangeSet.Map    (RSet)
import Kleene.Internal.Sets (dotRSet)

import qualified Data.RangeSet.Map as RSet

-------------------------------------------------------------------------------
-- Pretty
-------------------------------------------------------------------------------

-- | Pretty class.
--
-- For @'pretty' :: 'Kleene.RE.RE' -> 'String'@ gives a
-- representation accepted by many regex engines.
--
class Pretty a where
    pretty :: a -> String
    pretty a
x = a -> ShowS
forall a. Pretty a => a -> ShowS
prettyS a
x String
""

    prettyS :: a -> ShowS
    prettyS = String -> ShowS
showString (String -> ShowS) -> (a -> String) -> a -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Pretty a => a -> String
pretty

    {-# MINIMAL pretty | prettyS #-}

-- | @'putStrLn' . 'pretty'@
putPretty :: Pretty a => a -> IO ()
putPretty :: forall a. Pretty a => a -> IO ()
putPretty = String -> IO ()
putStrLn (String -> IO ()) -> (a -> String) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Pretty a => a -> String
pretty

instance c ~ Char => Pretty (RSet c) where
    prettyS :: RSet c -> ShowS
prettyS RSet c
cs
        | RSet c -> Int
forall a. Enum a => RSet a -> Int
RSet.size RSet c
cs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = c -> ShowS
forall a. Pretty a => a -> ShowS
prettyS ([c] -> c
forall a. HasCallStack => [a] -> a
head (RSet c -> [c]
forall a. Enum a => RSet a -> [a]
RSet.elems RSet c
cs))
        | RSet c
cs RSet c -> RSet c -> Bool
forall a. Eq a => a -> a -> Bool
== RSet c
RSet Char
dotRSet  = Char -> ShowS
showChar Char
'.'
        | RSet c
ics RSet c -> RSet c -> Bool
forall a. Eq a => a -> a -> Bool
== RSet c
RSet Char
dotRSet = String -> ShowS
showString String
"[^.]"
        | RSet c -> Int
forall a. Enum a => RSet a -> Int
RSet.size RSet c
cs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< RSet c -> Int
forall a. Enum a => RSet a -> Int
RSet.size RSet c
ics = Bool -> RSet Char -> ShowS
prettyRSet Bool
True RSet c
RSet Char
cs
        | Bool
otherwise                    = Bool -> RSet Char -> ShowS
prettyRSet Bool
False RSet c
RSet Char
ics
      where
        ics :: RSet c
ics = RSet c -> RSet c
forall a. (Ord a, Enum a, Bounded a) => RSet a -> RSet a
RSet.complement RSet c
cs

prettyRSet :: Bool -> RSet Char -> ShowS
prettyRSet :: Bool -> RSet Char -> ShowS
prettyRSet Bool
c RSet Char
cs
    = Char -> ShowS
showChar Char
'['
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
c then ShowS
forall a. a -> a
id else Char -> ShowS
showChar Char
'^')
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Endo String -> ShowS
forall a. Endo a -> a -> a
appEndo (((Char, Char) -> Endo String) -> [(Char, Char)] -> Endo String
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ShowS -> Endo String
forall a. (a -> a) -> Endo a
Endo (ShowS -> Endo String)
-> ((Char, Char) -> ShowS) -> (Char, Char) -> Endo String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, Char) -> ShowS
forall {a}. (Eq a, Pretty a) => (a, a) -> ShowS
f) (RSet Char -> [(Char, Char)]
forall a. RSet a -> [(a, a)]
RSet.toRangeList RSet Char
cs))
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
']'
  where
    f :: (a, a) -> ShowS
f (a
a, a
b)
      | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b = a -> ShowS
forall a. Pretty a => a -> ShowS
prettyS a
a
      | Bool
otherwise = a -> ShowS
forall a. Pretty a => a -> ShowS
prettyS a
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'-' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Pretty a => a -> ShowS
prettyS a
b

-- | Escapes special regexp characters
instance Pretty Char where
    prettyS :: Char -> ShowS
prettyS Char
'.' = String -> ShowS
showString String
"\\."
    prettyS Char
'-' = String -> ShowS
showString String
"\\-"
    prettyS Char
'^' = String -> ShowS
showString String
"\\^"
    prettyS Char
'*' = String -> ShowS
showString String
"\\*"
    prettyS Char
'+' = String -> ShowS
showString String
"\\+"
    prettyS Char
'?' = String -> ShowS
showString String
"\\?"
    prettyS Char
'(' = String -> ShowS
showString String
"\\("
    prettyS Char
')' = String -> ShowS
showString String
"\\)"
    prettyS Char
'[' = String -> ShowS
showString String
"\\["
    prettyS Char
']' = String -> ShowS
showString String
"\\]"
    prettyS Char
'\r' = String -> ShowS
showString String
"\\r"
    prettyS Char
'\n' = String -> ShowS
showString String
"\\n"
    prettyS Char
'\t' = String -> ShowS
showString String
"\\t"
    prettyS Char
c   = Char -> ShowS
showChar Char
c

instance Pretty Bool where
    prettyS :: Bool -> ShowS
prettyS Bool
True  = Char -> ShowS
showChar Char
'1'
    prettyS Bool
False = Char -> ShowS
showChar Char
'0'

instance Pretty () where
    prettyS :: () -> ShowS
prettyS ()
_ = Char -> ShowS
showChar Char
'.'

instance Pretty a => Pretty (Maybe a) where
    prettyS :: Maybe a -> ShowS
prettyS Maybe a
Nothing  = String -> ShowS
showString String
"Nothing"
    prettyS (Just a
x) = a -> ShowS
forall a. Pretty a => a -> ShowS
prettyS a
x

instance (Pretty a, Pretty b) => Pretty (Either a b) where
    prettyS :: Either a b -> ShowS
prettyS (Left a
x)  = String -> ShowS
showString String
"Left " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Pretty a => a -> ShowS
prettyS a
x
    prettyS (Right b
x) = String -> ShowS
showString String
"Right " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> ShowS
forall a. Pretty a => a -> ShowS
prettyS b
x

instance (Pretty a, Pretty b) => Pretty (a, b) where
    prettyS :: (a, b) -> ShowS
prettyS (a
x, b
y) = a -> ShowS
forall a. Pretty a => a -> ShowS
prettyS a
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" , " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> ShowS
forall a. Pretty a => a -> ShowS
prettyS b
y

instance Show a => Pretty [a] where
    prettyS :: [a] -> ShowS
prettyS = [a] -> ShowS
forall a. Show a => [a] -> ShowS
showList