Internal.hs

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

{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_HADDOCK not-home #-}

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

module Dialog.Internal where

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

import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.IO.Class (MonadIO (..))
import Data.String (IsString (..))
import Control.Monad (ap)
import Data.Word (Word8)

--------------------------------------------------------------------------------
-- 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 simple 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

--------------------------------------------------------------------------------
-- Displaying formatted messages
--------------------------------------------------------------------------------

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

--------------------------------------------------------------------------------
-- 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

-- | 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 <+>

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

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)

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