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
) 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 Graphics.UI.Gtk (Color(..))
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 ((<$>))
type Printer beta = beta -> PP.Doc
type Parser beta = CharParser () beta
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 :: 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)
colorParser :: CharParser () Color
colorParser = do
string "Color"
whiteSpace
r <- integer
whiteSpace
g <- integer
whiteSpace
b <- integer
return $ Color (fromIntegral r) (fromIntegral g) (fromIntegral b)
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
prettyPrint :: Pretty a => a -> Text
prettyPrint a = T.pack $ PP.renderStyle PP.style (pretty a)
class Pretty a where
pretty :: a -> PP.Doc
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
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"