Types.hs

module DarkPlaces.Text.Types where
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Data.Text as T
import DarkPlaces.Text.Classes
import DarkPlaces.Text.Colors
import System.Console.ANSI
import System.IO (Handle, hPutChar)
import Data.Monoid
import Text.Printf
import Data.String
import Numeric


data DPTextToken a = SimpleColor Int
                   | HexColor Int
                   | DPNewline
                   | DPString a
    deriving(Show, Eq)


newtype DPText a = DPText [DPTextToken a]
    deriving(Show, Eq)


type BinaryDPText = DPText BL.ByteString
type DecodedDPText = DPText T.Text


data DecodeType = Utf8Lenient
                | Utf8Ignore
                | Utf8Strict
                | NexuizDecode
    deriving(Show, Read, Eq, Ord, Enum, Bounded)


type DecodeFun a b = DPText a -> DPText b


data DPStreamState a = DPStreamState {
    streamLeft  :: a,
    streamColor :: DPTextToken a
} deriving (Show, Eq)


type BinStreamState = DPStreamState BL.ByteString


defaultStreamState :: BinStreamState
defaultStreamState = DPStreamState BL.empty (SimpleColor 0)


simpleColor :: BL.ByteString -> DPTextToken a
simpleColor = SimpleColor . fst . head . readDec . BLC.unpack . BL.drop 1


hexColor :: BL.ByteString -> DPTextToken a
hexColor = HexColor . fst . head . readHex . BLC.unpack . BL.drop 2


isString :: DPTextToken a -> Bool
isString (DPString _) = True
isString _ = False


isColor :: DPTextToken a -> Bool
isColor (SimpleColor _) = True
isColor (HexColor _) = True
isColor _ = False


isNewline :: DPTextToken a -> Bool
isNewline DPNewline = True
isNewline _ = False


isTextData :: DPTextToken a -> Bool
isTextData = not . isColor


mapToken :: (a -> b) -> DPTextToken a -> DPTextToken b
mapToken f (DPString s) = DPString $ f s
mapToken _ DPNewline = DPNewline
mapToken _ (SimpleColor c) = SimpleColor c
mapToken _ (HexColor c) = HexColor c


mapDPText :: (a -> b) -> DPText a -> DPText b
mapDPText f (DPText l) = DPText $ map (mapToken f) l


mapDPTextStream :: (a -> b) -> DPStreamState a -> DPStreamState b
mapDPTextStream f st = DPStreamState (f left) (mapToken f color)
  where
    (DPStreamState left color) = st


putDPText' :: (Printable a) => (Handle -> IO ()) -> Handle -> DPText a -> IO ()
putDPText' nf h (DPText t) = mapM_ print t
  where
    print (SimpleColor c) = hSetSGR h (getColor c)
    print (DPString s) = hPutPrintable h s
    print DPNewline = nf h
    print _ = return ()


putDPText'' :: (Printable a) => Handle -> DPText a -> IO ()
putDPText'' = putDPText' (\h -> hPutChar h '\n' >> hReset h)


putDPTextNoReset :: (Printable a) => Handle -> DPText a -> IO ()
putDPTextNoReset = putDPText' (flip hPutChar '\n')


instance Printable a => Printable (DPText a) where
    hPutPrintable = putDPText''


instance Monoid (DPText a) where
    mempty = DPText []
    mappend (DPText a) (DPText b) = DPText $ a ++ b


toText :: (Monoid a, IsString a) => DPText a -> a
toText (DPText tl) = mconcat $ map repr tl
  where
    repr DPNewline = fromString "\n"
    repr (DPString s) = s
    repr (SimpleColor c) = fromString $ "^" ++ show c
    repr (HexColor c) = fromString $ printf "^x%03X" c


optimizeDPText :: (Monoid a) => DPText a -> DPText a
optimizeDPText (DPText s) = DPText $ go s
  where
    go (DPString f : DPString s : xs) = DPString (f <> s) : go xs
    go (x:xs) = x : go xs
    go [] = []