path: root/src/Blessings.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Blessings
    ( module Export
    , module Blessings
    ) where

import qualified Prelude
import Blessings.Internal as Export (Blessable)
import qualified Blessings.Internal as Bless
import Prelude hiding (length,drop,take)
import Control.Applicative
import Data.String
import Data.Ix (inRange)

type Ps = Int
type Pm = [Ps]

data Blessings a
    = Plain a
    | SGR Pm (Blessings a)
    | Append (Blessings a) (Blessings a)
    | Empty
  deriving (Eq, Show)


instance Foldable Blessings where
    foldMap f = \case
        Append t1 t2 -> foldMap f t1 <> foldMap f t2
        Plain s -> f s
        SGR _ t -> foldMap f t
        Empty -> mempty


instance Functor Blessings where
    fmap f = \case
        Append t1 t2 -> Append (fmap f t1) (fmap f t2)
        Plain s -> Plain (f s)
        SGR pm t -> SGR pm (fmap f t)
        Empty -> Empty


instance Semigroup (Blessings a) where
    t <> Empty = t
    Empty <> t = t
    Append t1 t2 <> Append t3 t4 = t1 <> t2 <> t3 <> t4
    Append t1 t2 <> t3 = t1 <> t2 <> t3
    t1 <> t2 = Append t1 t2


instance Monoid (Blessings a) where
    mempty = Empty


instance IsString a => IsString (Blessings a) where
    fromString = Plain . fromString


class IsPm a where
    toPm :: a -> Pm
    fromPm :: Pm -> Maybe a


data FColor = ECMA48FColor Ps   -- ECMA-48 / ISO 6429 / ANSI X3.64
            | Xterm256FColor Ps
            | ISO8613_3FColor Ps Ps Ps
  deriving (Eq, Show)

instance IsPm FColor where
    toPm (ECMA48FColor i) = [i]
    toPm (Xterm256FColor i) = [38,5,i]
    toPm (ISO8613_3FColor r g b) = [38,2,r,g,b]
    fromPm = fromSGRPm SGRPm
               { def8Ps = 39
               , extPs = 38
               , lo8Ps = 30
               , hi8Ps = 37
               , makeECMA48Color = ECMA48FColor
               , makeXterm256Color = Xterm256FColor
               , makeISO8613_3Color = ISO8613_3FColor
               }
           . filterPm sgrBColor


data BColor = ECMA48BColor Ps
            | Xterm256BColor Ps
            | ISO8613_3BColor Ps Ps Ps
  deriving (Eq, Show)


instance IsPm BColor where
    toPm (ECMA48BColor i) = [i]
    toPm (Xterm256BColor i) = [48,5,i]
    toPm (ISO8613_3BColor r g b) = [48,2,r,g,b]
    fromPm = fromSGRPm SGRPm
                 { def8Ps = 49
                 , extPs = 48
                 , lo8Ps = 40
                 , hi8Ps = 47
                 , makeECMA48Color = ECMA48BColor
                 , makeXterm256Color = Xterm256BColor
                 , makeISO8613_3Color = ISO8613_3BColor
               }
           . filterPm sgrFColor


data Blink = Blink | NoBlink
  deriving (Eq, Show)

instance IsPm Blink where
    toPm Blink = [5]
    toPm NoBlink = [25]
    fromPm = rec . filterPm sgrColor
      where
        rec xs = case filter (`elem` ([5,25] :: [Int])) xs of
            [] -> Nothing
            xs' -> case last xs' of
                5 -> Just Blink
                25 -> Just NoBlink
                _ -> error "filter broken in fromPm :: Pm -> Maybe Blink"


data Bold = Bold | NoBold
  deriving (Eq, Show)

instance IsPm Bold where
    toPm Bold = [1]
    toPm NoBold = [22]
    fromPm = rec . filterPm sgrColor
      where
        rec xs = case filter (`elem` ([1,22] :: [Int])) xs of
            [] -> Nothing
            xs' -> case last xs' of
                1 -> Just Bold
                22 -> Just NoBold
                _ -> error "filter broken in fromPm :: Pm -> Maybe Bold"


data Underline = Underline | NoUnderline
  deriving (Eq, Show)

instance IsPm Underline where
    toPm Underline = [4]
    toPm NoUnderline = [24]
    fromPm = rec . filterPm sgrColor
      where
        rec xs = case filter (`elem` ([4,24] :: [Int])) xs of
            [] -> Nothing
            xs' -> case last xs' of
                1 -> Just Underline
                22 -> Just NoUnderline
                _ -> error "filter broken in fromPm :: Pm -> Maybe Underline"


data SGRPm c = SGRPm
    { def8Ps :: Ps
    , extPs :: Ps
    , lo8Ps :: Ps
    , hi8Ps :: Ps
    , makeECMA48Color :: Ps -> c
    , makeXterm256Color :: Ps -> c
    , makeISO8613_3Color :: Ps -> Ps -> Ps -> c
    }


fromSGRPm :: IsPm c => SGRPm c -> Pm -> Maybe c
fromSGRPm SGRPm{..} = rec Nothing
  where
    rec mb_c (x:xs)
        | x == extPs = case xs of
            (2:r:g:b:xs') -> rec (Just $ makeISO8613_3Color r g b) xs'
            (5:i:xs')     -> rec (Just $ makeXterm256Color i) xs'
            _             -> rec mb_c xs
        | x == def8Ps = rec (Just $ makeECMA48Color def8Ps) xs
        | inRange (lo8Ps, hi8Ps) x = rec (Just $ makeECMA48Color x) xs
        | otherwise = rec mb_c xs
    rec mb_c _ = mb_c


-- filterPm is used to preprocess Pm before searching with fromPm in
-- order to remove (longer) sequences that could contain subsequences
-- that look like the (shorter) sequences we're searching.
-- E.g. we could find [1] (bold) in any extended color sequence.
-- TODO Can we combine this whole from*Pm with Scanner?
filterPm :: (Pm -> Maybe Int) -> Pm -> Pm
filterPm f = rec []
  where
    rec ys xs@(xhead:xtail) = maybe (rec (ys ++ [xhead]) xtail)
                                    (rec ys . flip Prelude.drop xs)
                                    (f xs)
    rec ys _ = ys

sgrColor, sgrFColor, sgrBColor :: Pm -> Maybe Int

sgrColor xs = sgrFColor xs <|> sgrBColor xs

sgrFColor (38:5:_) = Just 3
sgrFColor (38:2:_) = Just 5
sgrFColor _ = Nothing

sgrBColor (48:5:_) = Just 3
sgrBColor (48:2:_) = Just 5
sgrBColor _ = Nothing


type RenderState = [(FColor, BColor, Blink, Bold, Underline)]


emptyRenderState :: RenderState
emptyRenderState = [(ECMA48FColor 39, ECMA48BColor 49, NoBlink, NoBold, NoUnderline)]


render :: (Blessable a) => RenderState -> Blessings a -> a -> a

render _ (Plain s) y = s <> y

-- TODO merge successive sequences: \ESC[32m\ESC[1m -> \ESC[31;1m
render rs@((fc, bc, bl, b, u):_) (SGR c t) y =
    renderSGR bra <> render rs' t (renderSGR ket <> y)
  where
    fc' = maybe fc id $ fromPm c
    bc' = maybe bc id $ fromPm c
    bl' = maybe bl id $ fromPm c
    b'  = maybe  b id $ fromPm c
    u'  = maybe  u id $ fromPm c
    rs' = (fc', bc', bl', b', u') : rs
    bra = braket >>= fst
    ket = braket >>= snd
    braket =
        (if fc' /= fc then (toPm fc', toPm fc) else ([],[])) :
        (if bc' /= bc then (toPm bc', toPm bc) else ([],[])) :
        (if bl' /= bl then (toPm bl', toPm bl) else ([],[])) :
        (if b'  /=  b then (toPm  b', toPm  b) else ([],[])) :
        (if u'  /=  u then (toPm  u', toPm  u) else ([],[])) : []

render _ (SGR _ _) _ =
    error "render called w/o proper initial state"
    -- where a proper initial state is s.th. like emptyRenderState

render r (Append t1 t2) y =
    render r t1 $ render r t2 y

render _ Empty y = y


renderSGR :: (Blessable a) => Pm -> a
renderSGR [] = mempty
renderSGR pm =
  ("\ESC["<>) . (<>"m") . Bless.intercalate ";" . map Bless.fromInt $ pm


stripSGR :: Blessings a -> Blessings a
stripSGR = \case
    Append t1 t2 -> Append (stripSGR t1) (stripSGR t2)
    SGR _ t -> stripSGR t
    Plain x -> Plain x
    Empty -> Empty


pp :: (Blessable a) => Blessings a -> a
pp t = render emptyRenderState t ""


instance Blessable a => Blessable (Blessings a) where
  length (Plain x) = Bless.length x
  length (SGR _ t) = Bless.length t
  length (Append t1 t2) = Bless.length t1 + Bless.length t2
  length Empty = 0

  drop n = \case
      Append t1 t2 ->
          case compare n (Bless.length t1) of
              LT -> Bless.drop n t1 <> t2
              EQ -> t2
              GT -> Bless.drop (n - Bless.length t1) t2
      Plain s ->
          Plain (Bless.drop n s)
      SGR pm t ->
          SGR pm (Bless.drop n t)
      Empty ->
          Empty

  take n = \case
      Append t1 t2 ->
          case compare n (Bless.length t1) of
              LT -> Bless.take n t1
              EQ -> t1
              GT -> t1 <> Bless.take (n - Bless.length t1) t2
      Plain s ->
          Plain (Bless.take n s)
      SGR pm t ->
          SGR pm (Bless.take n t)
      Empty ->
          Empty

  intercalate i = \case
      [] -> mempty
      [t] -> t
      (t:ts) -> t <> i <> Bless.intercalate i ts

  fromInt = Plain . Bless.fromInt