{-# OPTIONS_GHC -XTypeSynonymInstances -XExistentialQuantification #-}
-----------------------------------------------------------------------------
--
-- Module      :  Base.ConfigFile
-- Copyright   :  Juergen Nicklisch-Franken
-- License     :  LGPL
--
-- Maintainer  :  maintainer@leksah.org
-- Stability   :  provisional
-- Portability :  portabel
--
-- | Module for saving and restoring preferences and settings
-- in way similiar to what you would find in Microsoft Windows INI files.
--
-- The configuration file may consists of sections,
-- led by a [section] header and followed by name: value entries
-- or it only contains name: value entries.

-- Lines beginning with '#' or '--' (after optional whitespace)
-- are ignored and may be used to provide comments.

-- Newlines may be added between a value, but the next line must begin with a whitespace
-- (names have to start at column 0, without preceeding whitespace).

module Base.ConfigFile (

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

,   applyFieldParsers
,   boolParser
,   intParser
,   pairParser
,   identifier
,   emptyParser
,   whiteSpace
,   stringParser
,   readParser
,   versionParser
,   parsePluginList
,   showPluginList
,   boundParser

,   emptyPrinter
,   stringPrinter
,   maybePP

,   symbol
,   colon

,   showFields
,   readFields
,   parseFields

,   readFieldsSimple
,   parseFieldsSimple
,   showFieldsSimple
) 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 Data.Maybe (catMaybes, listToMaybe)
import Data.List (intersperse, foldl')
import Data.Version (showVersion, Version(..))
import Base.PluginTypes (VersionBounds, PluginName, Prerequisite)
import Control.Monad (liftM)
import Base.MyMissing (maybeRead, myCast, trim)
import Data.Typeable (Typeable)

--import Debug.Trace
trace a b = b

-- ------------------------------------------------------------
-- * Description of fields
-- ------------------------------------------------------------


-- | A type for printing something
type Printer beta       =   beta -> PP.Doc

-- | A type for parsing something
type Parser beta        =   CharParser () beta

-- |  A type for getting a field of a record
type Getter alpha beta = alpha -> beta

-- |  A type for setting the field of a record
type Setter alpha beta = beta -> alpha -> alpha

-- | A description of a printable and parsable entity
data FieldDescriptionS alpha =  FieldS {
        fieldName       ::  String,
        fieldPrinter    ::  alpha -> PP.Doc,
        fieldParser     ::  alpha -> CharParser () alpha,
        fieldSynopsis   ::  Maybe String
    }

data GenFieldDescriptionS = forall alpha . Typeable alpha => GenFS [FieldDescriptionS alpha] alpha


-- | A type for categories in ini files
type Category = String

-- | Make a field description

mkFieldS :: String ->
    Maybe String ->
    (Printer beta) ->
    (Parser beta) ->
    (Getter alpha beta) ->
    (Setter alpha beta) ->
    FieldDescriptionS alpha
mkFieldS name synopsis printer parser getter setter =
    FieldS name
        (\ dat -> (PP.text name PP.<> PP.colon)
                PP.$$ (PP.nest 15 (printer (getter dat)))
                PP.$$ (PP.nest 5 (case synopsis of
                                    Nothing -> PP.empty
                                    Just str -> PP.text $"--" ++ str)))
        (\ dat -> (do
            try (symbol name)
            colon
            value <- parser
            return (setter value dat)))
        synopsis

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

type PrefDescr = Either [(String,GenFieldDescriptionS)]
    GenFieldDescriptionS

showFields :: PrefDescr -> String
showFields (Right (GenFS dateDesc date))  = PP.render $
    foldl' (\ doc FieldS{fieldPrinter = printer} ->  doc PP.$+$ printer date)
        PP.empty dateDesc
showFields (Left catList)  = PP.render $ PP.vcat (map showField' catList)
  where
    showField' (catString, (GenFS dateDesc date)) =
        foldl' (\ doc FieldS{fieldPrinter = printer} ->  doc PP.$+$ printer date)
            (PP.text ("[" ++ catString ++ "]")) dateDesc

readFields :: FilePath -> PrefDescr -> IO PrefDescr
readFields fn descrs = catch (do
    res <- parseFromFile (parseFields' descrs) fn
    case res of
                Left pe -> error $ "Error reading file " ++ show pe
                Right r -> return r)
    (\ e -> error $ "Error reading file " ++ show e)

parseFields :: String -> PrefDescr -> PrefDescr
parseFields str fieldDescrs =
    case parse (parseFields' fieldDescrs) "" str of
                Left pe -> error $ "Parse error " ++ show pe
                Right r -> r

parseFields' ::   PrefDescr -> CharParser () PrefDescr
parseFields' (Right (GenFS fds defaultValue)) =
    let parsersF = map fieldParser fds in do
        res <-  applyFieldParsers defaultValue parsersF
        return (Right (GenFS fds res))
        <?> "parseFields' parser1"
parseFields' (Left descrList) = do
    newDescrList <- parseCategory [] descrList
    return (Left newDescrList)
        <?> "parseFields' parser2"

parseCategory :: [(String,GenFieldDescriptionS)] -> [(String,GenFieldDescriptionS)]
    -> CharParser () [(String,GenFieldDescriptionS)]
parseCategory accu descrList = trace "parseCategory1" (
    do
        eof
        return accu
    <|> do
        name <- parseCatName
        trace ("parseCategory2 " ++ name) (
            case [genFs | (n,genFs) <- descrList, n == name] of
                [(GenFS fieldList defaultValue)] -> do
                    res <-  applyFieldParsers defaultValue (map fieldParser fieldList)
                    parseCategory ((name,GenFS fieldList res) : accu) descrList
                otherwise -> do
                    skipToNextCategory
                    parseCategory accu descrList) -- no error message, unknown categories are just skipped
    <?> "parseCategory")

parseCatName ::  CharParser () String
parseCatName = do
    symbol "["
    str <- many (noneOf "]\n")
    symbol "]"
    return str
        <?> "parseCatName"

skipToNextCategory  ::  CharParser () ()
skipToNextCategory = do
    eof
    <|> do
        many (noneOf "\n")
        do
            optional (char '\n')
            c <- lookAhead anyChar
            if c == '['
                then return ()
                else skipToNextCategory
    <?> "skipToNextCategory"

applyFieldParsers ::  a ->  [a ->  CharParser () a] ->  CharParser () a
applyFieldParsers prefs parseF = trace "afp1" (do
        eof
        return (prefs))
    <|> trace "afp2" (do
        lookAhead (char '[')
        return (prefs))
    <|> trace "afp3" (do
        let parsers = map (\a -> trace "xx" (a prefs)) parseF
        newprefs <-  choice parsers
        whiteSpace
        applyFieldParsers newprefs parseF)
    <?> trace "afp4" "applyFieldParsers"

-- ------------------------------------------------------------
-- * Convenience methods with simpler interfaces for files without category
-- ------------------------------------------------------------

readFieldsSimple :: Typeable alpha => FilePath -> [FieldDescriptionS alpha] -> alpha -> IO alpha
readFieldsSimple fn descriptions defaultValue = catch (do
    putStrLn ("readFieldsSimple " ++ fn)
    res <- parseFromFile (parseFields' (Right $ GenFS descriptions defaultValue)) fn
    case res of
                Left pe -> error $ "Error reading file " ++ show pe
                Right (Right (GenFS _ r)) ->
                    return $ myCast "ConfigFile>>readFieldsSimple:" r
                Right (Left _) -> error "ConfigFile>>readFieldsSimple: impossible")
    (\ e -> error $ "Error reading file " ++ show e)

parseFieldsSimple :: Typeable alpha => String -> [FieldDescriptionS alpha] -> alpha -> alpha
parseFieldsSimple str descriptions defaultValue  =
    let res = parseFields str (Right $ GenFS descriptions defaultValue)
    in case res of
        (Right (GenFS _ r)) -> myCast "ConfigFile>>parseFieldsSimple:" r
        otherwise -> error "ConfigFile>>parseFieldsSimple: impossible"

showFieldsSimple :: Typeable alpha =>  alpha -> [FieldDescriptionS alpha] -> String
showFieldsSimple date dateDesc = showFields (Right $ GenFS dateDesc date)

-- ------------------------------------------------------------
-- * Parsers and printers
-- ------------------------------------------------------------

-- A String parser parses some string, which may span multiple lines
-- Carriage returns are not significant
stringParser :: CharParser () String
stringParser = trace "str1" (do
    firstLine <- many (noneOf ['\n'])
    optional (char '\n')
    lines <- many $ parseStringLine
    let res = trim (unwords (firstLine : lines))
    trace ("stringParser \"" ++ res ++ "\"") $ return res)
    <?> "stringParser"

parseStringLine :: CharParser () String
parseStringLine =  trace "parseValueLine" (do
    many1 (oneOf " \t") -- fails for lines which starts with a non blank
    (do
            char '-' -- skip comments
            char '-'
            many (noneOf ['\n'])
            optional (char '\n')
            return []) --skip comment
        <|> (do
                line <- many (noneOf ['\n'])
                optional (char '\n')
                return line)
    <?> trace "vl3" "parseValueLine")

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

readParser ::  Read a =>  CharParser () a
readParser = trace "rp1" (do
    str <- stringParser
    trace ("readParser on:" ++ str) $ if null str
        then unexpected "read parser on empty string"
        else do
            case maybeRead str of
                Nothing -> unexpected $ "read parser no parse " ++ str
                Just r -> return r)
    <?> "read parser"

pairParser ::  CharParser () alpha ->  CharParser () (alpha,alpha)
pairParser p2 = trace "pp1" (do
    parens $ do
        v1 <-  p2
        comma
        v2 <-  p2
        return (v1,v2))
    <?> "pair parser"

versionParser :: CharParser () Version
versionParser = trace "vp1" (do
    branch <-  sepBy1 intParser dot
    return Version{versionBranch=branch, versionTags=[]})
    <?> "version parser"


intParser ::  CharParser () Int
intParser = trace "ip1" (do
    i <-  integer
    return (fromIntegral i))
    <?> "int parser"

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 :: String -> CharParser st String
symbol = P.symbol lexer

identifier, colon :: CharParser st String
identifier = P.identifier lexer
colon      = P.colon lexer
comma      = P.comma lexer
parens     = P.parens lexer
dot        = P.dot lexer
integer    = P.integer lexer
brackets   = P.brackets lexer

skipToCategory str = do
            symbol ("[" ++ str ++ "]")
            return ()
    <|> do
            many (noneOf ['\n'])
            char '\n'
            skipToCategory str
    <?>
            "skipToCategory"

-- ------------------------------------------------------------
-- * Printing
-- ------------------------------------------------------------

stringPrinter :: String -> PP.Doc
stringPrinter str = PP.fsep $ map PP.text (words str)

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

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



-- ------------------------------------------------------------
-- * Special for plugins
------------------------------------------------------------

showPluginList :: [Prerequisite] -> String
showPluginList [] = "[]"
showPluginList l = "[" ++ concat (intersperse ", " (map showPlugin l)) ++ "]"
  where
    showPlugin (name,versionBounds) = "(" ++ name ++ "," ++ showVersionBounds versionBounds ++ ")"
    showVersionBounds (a,b) = showBound a ++ "," ++ showBound b
    showBound Nothing = "any"
    showBound (Just v) = showVersion v

parsePluginList :: CharParser () [Prerequisite]
parsePluginList = brackets (sepBy pluginParser comma)

pluginParser :: CharParser () (PluginName, VersionBounds)
pluginParser = trace "pp1" (
    parens $ do
        pluginName <- liftM trim (many (noneOf ","))
        comma
        lowerBound <- boundParser
        comma
        upperBound <- boundParser
        return (pluginName,(lowerBound,upperBound)))
    <?> "pluginParser"

boundParser :: CharParser () (Maybe Version)
boundParser =
    trace "bp1" (try $ do
            v <- versionParser
            return (Just v))
    <|> trace "bp2" (do
            symbol "any"
            return Nothing)
    <?> "boundParser"