{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Sindre.Formatting
-- License     :  MIT-style (see LICENSE)
--
-- Stability   :  provisional
-- Portability :  portable
--
-- Parser and definition of the dzen2-inspired formatting language
-- used by Sindre.  A format string is a sequence of commands changing
-- drawing option parameters, and things to draw.
--
-----------------------------------------------------------------------------
module Sindre.Formatting( Format(..)
                        , FormatString
                        , textContents
                        , startBg
                        , parseFormatString
                        , unparseFormatString
                        )
    where

import Sindre.Sindre hiding (string)
import Sindre.Runtime (Mold(..))

import Data.Attoparsec.Text

import Control.Applicative
import Control.Monad
import Data.Maybe
import qualified Data.Text as T

import Prelude hiding (takeWhile)

-- | A formatting command is either a change to the drawing state, or
-- a string to be printed at the current location.
data Format = Fg String -- ^ Draw text in the given colour.
            | DefFg -- ^ Draw text in the default colour.
            | Bg String -- ^ Draw the background in the given colour.
            | DefBg -- ^ Draw the background in the default colour.
            | Text T.Text -- ^ Draw the given string.
              deriving (Int -> Format -> ShowS
[Format] -> ShowS
Format -> String
(Int -> Format -> ShowS)
-> (Format -> String) -> ([Format] -> ShowS) -> Show Format
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Format] -> ShowS
$cshowList :: [Format] -> ShowS
show :: Format -> String
$cshow :: Format -> String
showsPrec :: Int -> Format -> ShowS
$cshowsPrec :: Int -> Format -> ShowS
Show, Format -> Format -> Bool
(Format -> Format -> Bool)
-> (Format -> Format -> Bool) -> Eq Format
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Format -> Format -> Bool
$c/= :: Format -> Format -> Bool
== :: Format -> Format -> Bool
$c== :: Format -> Format -> Bool
Eq, Eq Format
Eq Format
-> (Format -> Format -> Ordering)
-> (Format -> Format -> Bool)
-> (Format -> Format -> Bool)
-> (Format -> Format -> Bool)
-> (Format -> Format -> Bool)
-> (Format -> Format -> Format)
-> (Format -> Format -> Format)
-> Ord Format
Format -> Format -> Bool
Format -> Format -> Ordering
Format -> Format -> Format
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Format -> Format -> Format
$cmin :: Format -> Format -> Format
max :: Format -> Format -> Format
$cmax :: Format -> Format -> Format
>= :: Format -> Format -> Bool
$c>= :: Format -> Format -> Bool
> :: Format -> Format -> Bool
$c> :: Format -> Format -> Bool
<= :: Format -> Format -> Bool
$c<= :: Format -> Format -> Bool
< :: Format -> Format -> Bool
$c< :: Format -> Format -> Bool
compare :: Format -> Format -> Ordering
$ccompare :: Format -> Format -> Ordering
$cp1Ord :: Eq Format
Ord)

-- | A list of formatting commands, interpreted left-to-right.
type FormatString = [Format]

instance Mold FormatString where
  mold :: Value -> Maybe [Format]
mold Value
v = (String -> Maybe [Format])
-> ([Format] -> Maybe [Format])
-> Either String [Format]
-> Maybe [Format]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe [Format] -> String -> Maybe [Format]
forall a b. a -> b -> a
const Maybe [Format]
forall a. Maybe a
Nothing) [Format] -> Maybe [Format]
forall a. a -> Maybe a
Just (Either String [Format] -> Maybe [Format])
-> (Text -> Either String [Format]) -> Text -> Maybe [Format]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String [Format]
parseFormatString (Text -> Maybe [Format]) -> Maybe Text -> Maybe [Format]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value -> Maybe Text
forall a. Mold a => Value -> Maybe a
mold Value
v
  unmold :: [Format] -> Value
unmold = Text -> Value
StringV (Text -> Value) -> ([Format] -> Text) -> [Format] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Format] -> Text
unparseFormatString

-- | The human-readable part of a format string, with formatting
-- directives stripped.
textContents :: FormatString -> T.Text
textContents :: [Format] -> Text
textContents = [Text] -> Text
T.concat ([Text] -> Text) -> ([Format] -> [Text]) -> [Format] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Format -> Text) -> [Format] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Format -> Text
txt
  where txt :: Format -> Text
txt (Text Text
s) = Text
s
        txt Format
_        = Text
T.empty

-- | The first background colour preceding any default background
-- colour or text entry specified in the format string, if any.
startBg :: FormatString -> Maybe String
startBg :: [Format] -> Maybe String
startBg = Format -> Maybe String
getBg (Format -> Maybe String)
-> ([Format] -> Maybe Format) -> [Format] -> Maybe String
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [Format] -> Maybe Format
forall a. [a] -> Maybe a
listToMaybe ([Format] -> Maybe Format)
-> ([Format] -> [Format]) -> [Format] -> Maybe Format
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Format -> Bool) -> [Format] -> [Format]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Format -> Bool
ign
  where ign :: Format -> Bool
ign (Text Text
_) = Bool
False
        ign Format
DefBg    = Bool
False
        ign (Bg String
_)   = Bool
False
        ign Format
_        = Bool
True
        getBg :: Format -> Maybe String
getBg (Bg String
bg) = String -> Maybe String
forall a. a -> Maybe a
Just String
bg
        getBg Format
_       = Maybe String
forall a. Maybe a
Nothing

-- | Prettyprint a 'FormatString' to a string that, when parsed by
-- 'parseFormatString', results in the original 'FormatString'
unparseFormatString :: FormatString -> T.Text
unparseFormatString :: [Format] -> Text
unparseFormatString = [Text] -> Text
T.concat ([Text] -> Text) -> ([Format] -> [Text]) -> [Format] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Format -> Text) -> [Format] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Format -> Text
f
  where f :: Format -> Text
f (Fg String
s)   = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"fg(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
        f Format
DefFg    = String -> Text
T.pack String
"fg()"
        f (Bg String
s)   = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"bg(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
        f Format
DefBg    = String -> Text
T.pack String
"bg()"
        f (Text Text
s) = Text -> Text -> Text -> Text
T.replace (String -> Text
T.pack String
"^") (String -> Text
T.pack String
"^^") Text
s

-- | Parse a format string, returning either an error message or the
-- result of the parse.
parseFormatString :: T.Text -> Either String FormatString
parseFormatString :: Text -> Either String [Format]
parseFormatString Text
s =
  Result [Format] -> Either String [Format]
forall r. Result r -> Either String r
eitherResult (Result [Format] -> Either String [Format])
-> Result [Format] -> Either String [Format]
forall a b. (a -> b) -> a -> b
$ Parser [Format] -> Text -> Result [Format]
forall a. Parser a -> Text -> Result a
parse (Parser Text Format -> Parser [Format]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Text Format
format Parser [Format] -> Parser Text () -> Parser [Format]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
endOfInput) Text
s Result [Format] -> Text -> Result [Format]
forall i r. Monoid i => IResult i r -> i -> IResult i r
`feed` Text
T.empty

format :: Parser Format
format :: Parser Text Format
format = Char -> Parser Char
char Char
'^' Parser Char -> Parser Text Format -> Parser Text Format
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Format
command Parser Text Format -> Parser Text Format -> Parser Text Format
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Format
text

text :: Parser Format
text :: Parser Text Format
text = Text -> Format
Text (Text -> Format) -> Parser Text Text -> Parser Text Format
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'^')

command :: Parser Format
command :: Parser Text Format
command =     Text -> Format
Text (Text -> Format) -> Parser Text Text -> Parser Text Format
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Text Text
string (String -> Text
T.pack String
"^")
          Parser Text Format -> Parser Text Format -> Parser Text Format
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Text Text
string (String -> Text
T.pack String
"fg(")
                Parser Text Text -> Parser Text Format -> Parser Text Format
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> Format
Fg (String -> Format) -> (Text -> String) -> Text -> Format
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> String
T.unpack (Text -> Format) -> Parser Text Text -> Parser Text Format
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
')') Parser Text Format -> Parser Text Format -> Parser Text Format
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Format -> Parser Text Format
forall (f :: * -> *) a. Applicative f => a -> f a
pure Format
DefFg)
                Parser Text Format -> Parser Text Text -> Parser Text Format
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text Text
string (String -> Text
T.pack String
")")
          Parser Text Format -> Parser Text Format -> Parser Text Format
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Text Text
string (String -> Text
T.pack String
"bg(")
                Parser Text Text -> Parser Text Format -> Parser Text Format
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> Format
Bg (String -> Format) -> (Text -> String) -> Text -> Format
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> String
T.unpack (Text -> Format) -> Parser Text Text -> Parser Text Format
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
')') Parser Text Format -> Parser Text Format -> Parser Text Format
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Format -> Parser Text Format
forall (f :: * -> *) a. Applicative f => a -> f a
pure Format
DefBg)
                Parser Text Format -> Parser Text Text -> Parser Text Format
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text Text
string (String -> Text
T.pack String
")")