PrinterParser.hs

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables, OverloadedStrings #-}
--
-- | Module for saving and restoring preferences and settings
--

module Text.PrinterParser (

    Printer
,   Parser
,   FieldDescriptionS(..)
,   MkFieldDescriptionS
,   mkFieldS

,   applyFieldParsers
,   boolParser
,   intParser
,   lineParser
,   pairParser
,   identifier
,   emptyParser
,   whiteSpace
,   stringParser
,   readParser
,   colorParser

,   emptyPrinter
,   Pretty(..)
,   prettyPrint
,   maybePP

,   symbol
,   colon

,   writeFields
,   showFields
,   readFields
,   parseFields
,   Color(..)
,   toGdkColor
,   fromGdkColor
,   toGdkRGBA
,   fromGdkRGBA
) where

import Text.ParserCombinators.Parsec.Language
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec hiding(Parser)
import qualified Text.PrettyPrint as PP

import Graphics.UI.Editor.Parameters
import Graphics.UI.Editor.Basics
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Monoid ((<>))
import Data.List (foldl')
import qualified Text.ParserCombinators.Parsec as  P
    ((<?>), CharParser(..), parseFromFile)
import Control.Exception as E (catch, IOException)
import qualified Data.Text as T (pack, unpack)
import Data.Text (Text)
import Control.Applicative ((<$>))
import Numeric (showHex)
import System.IO.Unsafe (unsafePerformIO)
import Data.Word (Word16)
import Control.Monad.IO.Class (MonadIO)
import qualified GI.Gdk.Structs.Color as Gdk (Color(..))
import Data.GI.Base.Constructible (Constructible(..))
import GI.Gdk.Structs.Color
       (getColorBlue, getColorGreen, getColorRed, setColorBlue,
        setColorGreen, setColorRed)
import GI.Gdk
       (setRGBAAlpha, getRGBABlue, getRGBAGreen, getRGBARed, setRGBABlue,
        setRGBAGreen, setRGBARed, newZeroRGBA, RGBA)

type Printer beta       =   beta -> PP.Doc
type Parser beta        =   CharParser () beta

-- ------------------------------------------------------------
-- * Parsing with Parsec
-- ------------------------------------------------------------

data FieldDescriptionS alpha =  FDS {
        parameters      ::  Parameters
    ,   fieldPrinter    ::  alpha -> PP.Doc
    ,   fieldParser     ::  alpha -> CharParser () alpha
    }

type MkFieldDescriptionS alpha beta =
    Parameters ->
    Printer beta ->
    Parser beta ->
    Getter alpha beta ->
    Setter alpha beta ->
    FieldDescriptionS alpha

mkFieldS :: {--Eq beta =>--} MkFieldDescriptionS alpha beta
mkFieldS parameter printer parser getter setter =
    FDS parameter
        (\ dat -> (PP.text (case getParameterPrim paraName parameter of
                                Nothing -> ""
                                Just str -> T.unpack str) PP.<> PP.colon)
                PP.$$ PP.nest 15 (printer (getter dat))
                PP.$$ PP.nest 5 (case getParameterPrim paraSynopsis parameter of
                                    Nothing -> PP.empty
                                    Just str -> PP.text . T.unpack $ "--" <> str))
        (\ dat -> try (do
            symbol (fromMaybe "" (getParameterPrim paraName parameter))
            colon
            val <- parser
            return (setter val dat)))

applyFieldParsers ::  a ->  [a ->  CharParser () a] ->  CharParser () a
applyFieldParsers prefs parseF = do
    eof
    return prefs
    <|> do
    let parsers = map (\a ->  a prefs) parseF
    newprefs <-  choice parsers
    whiteSpace
    applyFieldParsers newprefs parseF
    <?> "field parser"

boolParser ::  CharParser () Bool
boolParser = do
    symbol "True" <|> symbol "true"
    return True
    <|> do
    symbol "False" <|> symbol "false"
    return False
    <?> "bool parser"


readParser ::  Read a =>  CharParser () a
readParser = do
    str <- many (noneOf "\n")
    if null str
        then unexpected "read parser on empty string"
        else
            case maybeRead str of
                Nothing -> unexpected $ "read parser no parse " ++ str
                Just r -> return r
    <?> "read parser"
        where maybeRead = listToMaybe . map fst . filter (null . snd) . reads

pairParser ::  CharParser () alpha ->  CharParser () (alpha,alpha)
pairParser p2 = do
    char '('
    v1 <-  p2
    char ','
    v2 <-  p2
    char ')'
    return (v1,v2)
    <?> "pair parser"

stringParser ::  CharParser () Text
stringParser = do
    char '"'
    str <- many (noneOf "\"")
    char '"'
    return (T.pack str)
    <?> "string parser"

lineParser ::  CharParser () Text
lineParser = do
    str <- many (noneOf "\n")
    return (T.pack str)
    <?> "line parser"


intParser ::  CharParser () Int
intParser = do
    i <-  integer
    return (fromIntegral i)

data Color = Color Word16 Word16 Word16 deriving(Eq, Show)

colorParser :: CharParser () Color
colorParser = do
    string "Color"
    whiteSpace
    r <- integer
    whiteSpace
    g <- integer
    whiteSpace
    b <- integer
    return $ Color (fromIntegral r) (fromIntegral g) (fromIntegral b)

toGdkColor :: MonadIO m => Color -> m Gdk.Color
toGdkColor (Color r g b) = do
    c <- new Gdk.Color []
    setColorRed   c r
    setColorGreen c g
    setColorBlue  c b
    return c

fromGdkColor :: MonadIO m => Gdk.Color -> m Color
fromGdkColor c = do
    r <- getColorRed c
    g <- getColorGreen c
    b <- getColorBlue c
    return $ Color r g b

toGdkRGBA :: MonadIO m => Color -> m RGBA
toGdkRGBA (Color r g b) = do
    c <- newZeroRGBA
    setRGBARed   c (fromIntegral r / 65535)
    setRGBAGreen c (fromIntegral g / 65535)
    setRGBABlue  c (fromIntegral b / 65535)
    setRGBAAlpha c 65535
    return c

fromGdkRGBA :: MonadIO m => RGBA -> m Color
fromGdkRGBA c = do
    r <- getRGBARed c
    g <- getRGBAGreen c
    b <- getRGBABlue c
    return $ Color (round (r * 65535)) (round (g * 65535)) (round (b * 65535))

emptyParser ::  CharParser () ()
emptyParser = pzero

prefsStyle  ::  P.LanguageDef st
prefsStyle  = emptyDef  {
        P.commentStart   = "{-"
    ,   P.commentEnd     = "-}"
    ,   P.commentLine    = "--"
    }

lexer :: P.TokenParser st
lexer = P.makeTokenParser prefsStyle

whiteSpace :: CharParser st ()
whiteSpace = P.whiteSpace lexer

symbol :: Text -> CharParser st Text
symbol = (T.pack <$>) . P.symbol lexer . T.unpack

identifier, colon :: CharParser st Text
identifier = T.pack <$> P.identifier lexer
colon = T.pack <$> P.colon lexer

integer = P.integer lexer

-- ------------------------------------------------------------
-- * Printing
-- ------------------------------------------------------------
-- | pretty-print with the default style and 'defaultMode'.
prettyPrint :: Pretty a => a -> Text
prettyPrint a = T.pack $ PP.renderStyle  PP.style (pretty a)

-- | Things that can be pretty-printed
class Pretty a where
    -- | Pretty-print something in isolation.
    pretty :: a -> PP.Doc
    -- | Pretty-print something in a precedence context.
    prettyPrec :: Int -> a -> PP.Doc
    pretty = prettyPrec 0
    prettyPrec _ = pretty

emptyPrinter ::  () ->  PP.Doc
emptyPrinter _ = PP.empty

maybePP :: (a -> PP.Doc) -> Maybe a -> PP.Doc
maybePP _ Nothing = PP.empty
maybePP pp (Just a) = pp a

instance Pretty Text where
    pretty str = PP.text $ T.unpack str

-- ------------------------------------------------------------
-- * Read and write
-- ------------------------------------------------------------

writeFields :: FilePath -> alpha -> [FieldDescriptionS alpha] -> IO ()
writeFields fpath date dateDesc = writeFile fpath (T.unpack $ showFields date dateDesc)

showFields ::  alpha  -> [FieldDescriptionS alpha] ->  Text
showFields date dateDesc = T.pack . PP.render $
    foldl' (\ doc (FDS _ printer _) ->  doc PP.$+$ printer date) PP.empty dateDesc

readFields :: FilePath -> [FieldDescriptionS alpha] -> alpha -> IO alpha
readFields fn fieldDescrs defaultValue = E.catch (do
    res <- P.parseFromFile (parseFields defaultValue fieldDescrs) fn
    case res of
                Left pe -> error $ "Error reading file " ++ show fn ++ " " ++ show pe
                Right r -> return r)
    (\ (e::IOException) -> error $ "Error reading file " ++ show fn ++ " " ++ show e)

parseFields ::  alpha ->  [FieldDescriptionS alpha] ->  P.CharParser () alpha
parseFields defaultValue descriptions =
    let parsersF = map fieldParser descriptions in
        applyFieldParsers defaultValue parsersF
        P.<?> "prefs parser"