Internal.hs

--------------------------------------------------------------------------------
-- |
-- module:    Dialog.Internal
-- copyright: (c) 2015 Nikita Churaev
-- license:   BSD3
--------------------------------------------------------------------------------

{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK not-home #-}

--------------------------------------------------------------------------------

module Dialog.Internal where

--------------------------------------------------------------------------------

import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.IO.Class (MonadIO (..))
import Data.Monoid ((<>))
import Data.String (IsString (..))
import Control.Monad (ap)
import Data.Word (Word8)
import qualified Data.Text as T

--------------------------------------------------------------------------------
-- Dialog monad transformer
--------------------------------------------------------------------------------

-- | Dialog monad transformer.
data DialogT m a where
  Pure :: a -> DialogT m a
  Bind ::
    (forall r. (forall b . DialogT m b -> (b -> DialogT m a) -> r) -> r) ->
    DialogT m a
  Lift :: m a -> DialogT m a
  ChangeTitle :: String -> DialogT m ()
  ChangeEndMessage :: String -> DialogT m ()
  Display :: [Paragraph] -> DialogT m ()
  AskLine :: String -> DialogT m String

instance Functor (DialogT m) where
  fmap func (Pure val) = Pure (func val)
  fmap func action = action >>= (\val -> pure (func val))

instance Applicative (DialogT m) where
  pure = Pure
  (<*>) = ap

instance Monad (DialogT m) where
  actionA >>= makeActionB = Bind (\func -> func actionA makeActionB)

instance MonadTrans DialogT where
  lift = Lift 

instance MonadIO m => MonadIO (DialogT m) where
  liftIO action = Lift (liftIO action)

-- | Dialog with 'IO' as the base monad.
type DialogIO = DialogT IO

--------------------------------------------------------------------------------
-- Changing dialog title
--------------------------------------------------------------------------------

-- | Changes the title of the dialog window. Default: @\"Dialog\"@
changeTitle :: String -> DialogT m ()
changeTitle = ChangeTitle

-- | Changes the end message of the dialog. Default: @\"End of program.\"@
changeEndMessage :: String -> DialogT m ()
changeEndMessage = ChangeEndMessage

--------------------------------------------------------------------------------
-- Displaying messages
--------------------------------------------------------------------------------

-- | Displays a plain-text single-line message.
displayLine :: String -> DialogT m ()
displayLine string = display [TextParagraph (Plain string)]

--------------------------------------------------------------------------------
-- Asking for input
--------------------------------------------------------------------------------

-- | Asks the user for a line of text.
askLine :: String -> DialogT m String
askLine = AskLine

--------------------------------------------------------------------------------
-- Formatted messages
--------------------------------------------------------------------------------

-- | Displays a message.
display :: [Paragraph] -> DialogT m ()
display = Display

-- | Shorthand for 'TextParagraph'.
p :: FormattedText -> Paragraph
p = TextParagraph

-- | Makes an unlabeled link. Shorthand for @('Link' url ('Plain' url))@.
url :: String -> FormattedText
url url = Link url (Plain url)

-- | Makes a labeled link. Alias for 'Link'.
link :: String -> FormattedText -> FormattedText
link = Link

-- | Shorthand for @('Picture' ('PictureFromURL' url))@.
img :: String -> Paragraph
img url = Picture (PictureFromURL url)

-- | Makes a numbered list. Shorthand for @('List' 'NumberedList' items)@.
il :: [ListItem] -> Paragraph
il = List NumberedList

-- | Makes a bullet list. Shorthand for @('List' 'BulletList' items)@.
ul :: [ListItem] -> Paragraph
ul = List BulletList

-- | Makes a single-line list item. Shorthand for 
-- @('ListItem' ['TextParagraph' text])@.
li :: FormattedText -> ListItem
li richText = ListItem [TextParagraph richText]

-- | Makes a list item. Shorthand for 'ListItem'.
li' :: [Paragraph] -> ListItem
li' = ListItem

-- | Combines two formatted texts together.
(<+>) :: FormattedText -> FormattedText -> FormattedText
(<+>) (CompositeText a) (CompositeText b) =
  CompositeText (a ++ b)
(<+>) a (CompositeText b) =
  CompositeText (a:b)
(<+>) (CompositeText a) b =
  CompositeText (a ++ [b])
(<+>) a b =
  CompositeText [a, b]

infixr 6 <+>

-- | Converts a 'String' to a 'FormattedText'. Shorthand for 'Plain'.
str :: String -> FormattedText
str = Plain

-- | Makes a text bold. Shorthand for 'Bold'.
b :: FormattedText -> FormattedText
b = Bold

-- | Makes a text italic. Shorthand for 'Italic'.
i :: FormattedText -> FormattedText
i = Italic

-- | Makes a text underlined. Shorthand for 'Underline'.
u :: FormattedText -> FormattedText
u = Underline

-- | Changes the color of a text. Alias of 'Colored'.
color :: Color -> FormattedText -> FormattedText
color = Colored

-- | Changes the size of a text. Alias of 'Size'.
size :: FontSize -> FormattedText -> FormattedText
size = Size

-- | Makes a table. Alias for 'Table'.
table :: [TableRow] -> Paragraph
table = Table

-- | Makes a table row. Shorthand for 'TableRow'.
tr :: [TableCell] -> TableRow
tr = TableRow

-- | Makes a normal table cell with a single line of text in it. Shorthand for
-- @('TableCell' 'NormalCell' ['TextParagraph' text])@.
td :: FormattedText -> TableCell
td richText = TableCell NormalCell [TextParagraph richText]

-- | Makes a table header cell with a single line of text in it. Shorthand for
-- @('TableCell' 'HeaderCell' ['TextParagraph' text])@.
th :: FormattedText -> TableCell
th richText = TableCell HeaderCell [TextParagraph richText]

-- | Makes a normal table cell. Shorthand for
-- @('TableCell' 'NormalCell' paragraphs)@.
td' :: [Paragraph] -> TableCell
td' = TableCell NormalCell

-- | Makes a header table cell. Shorthand for
-- @('TableCell' 'HeaderCell' paragraphs)@.
th' :: [Paragraph] -> TableCell
th' = TableCell HeaderCell

--------------------------------------------------------------------------------
-- Formatted text
--------------------------------------------------------------------------------

data Paragraph =
  TextParagraph FormattedText |
  Picture PictureSource |
  List ListStyle [ListItem] |
  Table [TableRow]
  deriving (Eq, Ord, Show)

--------------------------------------------------------------------------------

data FormattedText =
  Plain String |
  Colored Color FormattedText |
  Bold FormattedText |
  Italic FormattedText |
  Underline FormattedText |
  Size FontSize FormattedText |
  Link String FormattedText |
  CompositeText [FormattedText]
  deriving (Eq, Ord, Show)

instance IsString FormattedText where
  fromString string = Plain string

--------------------------------------------------------------------------------

data PictureSource
  = PictureFromURL String
  deriving (Eq, Ord, Show)

--------------------------------------------------------------------------------

data ListStyle =
  NumberedList |
  BulletList
  deriving (Eq, Ord, Show)

newtype ListItem =
  ListItem [Paragraph]
  deriving (Eq, Ord, Show)

--------------------------------------------------------------------------------

newtype TableRow =
  TableRow [TableCell]
  deriving (Eq, Ord, Show)

data TableCell =
  TableCell CellStyle [Paragraph]
  deriving (Eq, Ord, Show)

data CellStyle =
  NormalCell |
  HeaderCell
  deriving (Eq, Ord, Show)

--------------------------------------------------------------------------------

-- | Font size (in percent of the base font size).
data FontSize = FontSize Int
  deriving (Eq, Ord)

instance Num FontSize where
  (FontSize a) + (FontSize b) = mkFontSize (a + b)
  (FontSize a) - (FontSize b) = mkFontSize (a - b)
  (FontSize a) * (FontSize b) = mkFontSize (a * b)
  negate = undefined "Can not negate a FontSize"
  signum _ = FontSize 1
  abs size = size
  fromInteger integer = mkFontSize (fromInteger integer)

instance Show FontSize where
  showsPrec prec (FontSize int) = showsPrec prec int

mkFontSize :: Int -> FontSize
mkFontSize int
  | int < 0 = 
      error ("FontSize " ++ show int ++ " is negative")
  | int == 0 = 
      error ("FontSize can not be zero")
  | int < 25 = 
      error ("FontSize " ++ show int ++ " is too small (maximum is 25)")
  | int > 1000 =
      error ("FontSize " ++ show int ++ " is too large (maximum is 1000)")
  | otherwise =
      FontSize int

--------------------------------------------------------------------------------

-- | Color.
data Color = Color Word8 Word8 Word8
  deriving (Eq, Ord, Show)

-- | Pure white (red: 255, green: 255, blue: 255).
white :: Color
white = Color 255 255 255

-- | Pure black (red: 0, green: 0, blue: 0).
black :: Color
black = Color 0 0 0

-- | Pure red (red: 255, green: 0, blue: 0).
red :: Color
red = Color 255 0 0

-- | Pure green (red: 0, green: 255, blue: 0).
green :: Color
green = Color 0 255 0

-- | Pure blue (red: 0, green: 0, blue: 255).
blue :: Color
blue = Color 0 0 255

-- | Makes a color from red, green and blue components.
rgb :: Word8 -> Word8 -> Word8 -> Color
rgb = Color

-- | Unpacks a color into red, green and blue components.
toRGB :: Color -> (Word8, Word8, Word8)
toRGB (Color r g b) = (r, g, b)

--------------------------------------------------------------------------------