{-# LANGUAGE FlexibleContexts #-}

{- |
Module    : Data.Ini.Reader.Internals
Copyright : 2011-2014 Magnus Therning
License   : BSD3

Internal functions used in 'Data.Ini.Reader'.
-}
module Data.Ini.Reader.Internals where

import Control.Monad.Except (MonadError (throwError))
import Control.Monad.State (evalState, get, put)
import Data.Functor (($>))
import Text.Parsec as P (
    anyChar,
    between,
    char,
    choice,
    many,
    many1,
    manyTill,
    newline,
    noneOf,
    oneOf,
 )
import Text.Parsec.String (Parser)

import Data.Char (isSpace)
import Data.Ini (emptyConfig, setOption)
import Data.Ini.Types (Config)
import Data.List (dropWhileEnd)

data IniReaderError
    = IniParserError String
    | IniSyntaxError String
    | IniOtherError String
    deriving (IniReaderError -> IniReaderError -> Bool
(IniReaderError -> IniReaderError -> Bool)
-> (IniReaderError -> IniReaderError -> Bool) -> Eq IniReaderError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IniReaderError -> IniReaderError -> Bool
== :: IniReaderError -> IniReaderError -> Bool
$c/= :: IniReaderError -> IniReaderError -> Bool
/= :: IniReaderError -> IniReaderError -> Bool
Eq, Int -> IniReaderError -> ShowS
[IniReaderError] -> ShowS
IniReaderError -> String
(Int -> IniReaderError -> ShowS)
-> (IniReaderError -> String)
-> ([IniReaderError] -> ShowS)
-> Show IniReaderError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IniReaderError -> ShowS
showsPrec :: Int -> IniReaderError -> ShowS
$cshow :: IniReaderError -> String
show :: IniReaderError -> String
$cshowList :: [IniReaderError] -> ShowS
showList :: [IniReaderError] -> ShowS
Show)

type IniParseResult = Either IniReaderError

-- | The type used to represent a line of a config file.
data IniFile
    = SectionL String
    | OptionL String String
    | OptionContL String
    | CommentL
    deriving (Int -> IniFile -> ShowS
[IniFile] -> ShowS
IniFile -> String
(Int -> IniFile -> ShowS)
-> (IniFile -> String) -> ([IniFile] -> ShowS) -> Show IniFile
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IniFile -> ShowS
showsPrec :: Int -> IniFile -> ShowS
$cshow :: IniFile -> String
show :: IniFile -> String
$cshowList :: [IniFile] -> ShowS
showList :: [IniFile] -> ShowS
Show, IniFile -> IniFile -> Bool
(IniFile -> IniFile -> Bool)
-> (IniFile -> IniFile -> Bool) -> Eq IniFile
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IniFile -> IniFile -> Bool
== :: IniFile -> IniFile -> Bool
$c/= :: IniFile -> IniFile -> Bool
/= :: IniFile -> IniFile -> Bool
Eq)

-- | Build a configuration from a list of 'IniFile' items.
buildConfig :: [IniFile] -> IniParseResult Config
buildConfig :: [IniFile] -> IniParseResult Config
buildConfig [IniFile]
ifs =
    let
        isComment :: IniFile -> Bool
isComment IniFile
CommentL = Bool
True
        isComment IniFile
_ = Bool
False

        fIfs :: [IniFile]
fIfs = (IniFile -> Bool) -> [IniFile] -> [IniFile]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (IniFile -> Bool) -> IniFile -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IniFile -> Bool
isComment) [IniFile]
ifs

        -- merge together OptionL and subsequent OptionContL items
        mergeOptions :: [IniFile] -> m [IniFile]
mergeOptions [] = [IniFile] -> m [IniFile]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        mergeOptions (s :: IniFile
s@(SectionL String
_) : [IniFile]
ifs') = (IniFile
s IniFile -> [IniFile] -> [IniFile]
forall a. a -> [a] -> [a]
:) ([IniFile] -> [IniFile]) -> m [IniFile] -> m [IniFile]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [IniFile] -> m [IniFile]
mergeOptions [IniFile]
ifs'
        mergeOptions (IniFile
CommentL : [IniFile]
ifs') = (IniFile
CommentL IniFile -> [IniFile] -> [IniFile]
forall a. a -> [a] -> [a]
:) ([IniFile] -> [IniFile]) -> m [IniFile] -> m [IniFile]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [IniFile] -> m [IniFile]
mergeOptions [IniFile]
ifs'
        mergeOptions (OptionL String
on String
ov : OptionContL String
ov2 : [IniFile]
ifs') = [IniFile] -> m [IniFile]
mergeOptions ([IniFile] -> m [IniFile]) -> [IniFile] -> m [IniFile]
forall a b. (a -> b) -> a -> b
$ String -> String -> IniFile
OptionL String
on (String
ov String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ov2) IniFile -> [IniFile] -> [IniFile]
forall a. a -> [a] -> [a]
: [IniFile]
ifs'
        mergeOptions (o :: IniFile
o@(OptionL String
_ String
_) : [IniFile]
ifs') = (IniFile
o IniFile -> [IniFile] -> [IniFile]
forall a. a -> [a] -> [a]
:) ([IniFile] -> [IniFile]) -> m [IniFile] -> m [IniFile]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [IniFile] -> m [IniFile]
mergeOptions [IniFile]
ifs'
        mergeOptions [IniFile]
_ = IniReaderError -> m [IniFile]
forall a. IniReaderError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (IniReaderError -> m [IniFile]) -> IniReaderError -> m [IniFile]
forall a b. (a -> b) -> a -> b
$ String -> IniReaderError
IniSyntaxError String
"Syntax error in INI file."

        -- build the configuration from a [IniFile]
        buildit :: Config -> [IniFile] -> m Config
buildit Config
a [] = Config -> m Config
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Config
a
        buildit Config
a (SectionL String
sn : [IniFile]
is) = String -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put String
sn m () -> m Config -> m Config
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Config -> [IniFile] -> m Config
buildit Config
a [IniFile]
is
        buildit Config
a (OptionL String
on String
ov : [IniFile]
is) = do
            String
sn <- m String
forall s (m :: * -> *). MonadState s m => m s
get
            let na :: Config
na = String -> String -> String -> Config -> Config
setOption String
sn String
on String
ov Config
a
            Config -> [IniFile] -> m Config
buildit Config
na [IniFile]
is
        buildit Config
_ [IniFile]
_ = m Config
forall a. HasCallStack => a
undefined
     in
        [IniFile] -> Either IniReaderError [IniFile]
forall {m :: * -> *}.
MonadError IniReaderError m =>
[IniFile] -> m [IniFile]
mergeOptions [IniFile]
fIfs Either IniReaderError [IniFile]
-> ([IniFile] -> IniParseResult Config) -> IniParseResult Config
forall a b.
Either IniReaderError a
-> (a -> Either IniReaderError b) -> Either IniReaderError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[IniFile]
is -> Config -> IniParseResult Config
forall a. a -> Either IniReaderError a
forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> IniParseResult Config)
-> Config -> IniParseResult Config
forall a b. (a -> b) -> a -> b
$ State String Config -> String -> Config
forall s a. State s a -> s -> a
evalState (Config -> [IniFile] -> State String Config
forall {m :: * -> *}.
MonadState String m =>
Config -> [IniFile] -> m Config
buildit Config
emptyConfig [IniFile]
is) String
"default"

-- | Consumer of whitespace \"@ \t@\".
eatWhiteSpace :: Parser String
eatWhiteSpace :: Parser String
eatWhiteSpace = ParsecT String () Identity Char -> Parser String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String () Identity Char -> Parser String)
-> ParsecT String () Identity Char -> Parser String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
" \t"

{- | Parser for the start-of-section line.  It expects the line to start with a
@[@ then find the section name, and finally a @]@.  The section name may be
surrounded by any number of white space characters (see 'eatWhiteSpace').
-}
secParser :: Parser IniFile
secParser :: Parser IniFile
secParser = String -> IniFile
SectionL (String -> IniFile) -> Parser String -> Parser IniFile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String -> Parser String -> Parser String -> Parser String
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between Parser String
sectionNameOpen Parser String
sectionNameClose Parser String
forall {u}. ParsecT String u Identity String
sectionName
  where
    sectionNameOpen :: Parser String
sectionNameOpen = Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'[' ParsecT String () Identity Char -> Parser String -> Parser String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser String
eatWhiteSpace
    sectionNameClose :: Parser String
sectionNameClose = Parser String
eatWhiteSpace Parser String
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
']' ParsecT String () Identity Char -> Parser String -> Parser String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity Char
-> ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline
    sectionName :: ParsecT String u Identity String
sectionName = ParsecT String u Identity Char -> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String u Identity Char
 -> ParsecT String u Identity String)
-> ParsecT String u Identity Char
-> ParsecT String u Identity String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
validSecNameChrs
    validSecNameChrs :: String
validSecNameChrs = [Char
'a' .. Char
'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'A' .. Char
'Z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'0' .. Char
'9'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"._-/@\" "

{- | Parser for a single line of an option.  The line must start with an option
name, then a @=@ must be found, and finally the rest of the line is taken as
the option value.  The equal sign may be surrounded by any number of white
space characters (see 'eatWhiteSpace').
-}
optLineParser :: Parser IniFile
optLineParser :: Parser IniFile
optLineParser = String -> String -> IniFile
OptionL (String -> String -> IniFile)
-> Parser String -> ParsecT String () Identity (String -> IniFile)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
optionName ParsecT String () Identity (String -> IniFile)
-> Parser String -> Parser IniFile
forall a b.
ParsecT String () Identity (a -> b)
-> ParsecT String () Identity a -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser String
optionEqual Parser String -> Parser String -> Parser String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser String
forall {u}. ParsecT String u Identity String
optionValue)
  where
    optionName :: Parser String
optionName = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace ShowS -> Parser String -> Parser String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser String
eatWhiteSpace Parser String -> Parser String -> Parser String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
validOptNameChrs))
    optionEqual :: Parser String
optionEqual = Parser String
eatWhiteSpace Parser String
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'=' ParsecT String () Identity Char -> Parser String -> Parser String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser String
eatWhiteSpace
    optionValue :: ParsecT String u Identity String
optionValue = ParsecT String u Identity Char
-> ParsecT String u Identity Char
-> ParsecT String u Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline
    validOptNameChrs :: String
validOptNameChrs = [Char
'a' .. Char
'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'A' .. Char
'Z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'0' .. Char
'9'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_-/@ "

{- | Parser for an option-value continuation line.  The line must start with
either a space or a tab character (\"@ \t@\").  Everything else on the line,
until the newline character, is taken as the continuation of an option
value.
-}
optContParser :: Parser IniFile
optContParser :: Parser IniFile
optContParser = String -> IniFile
OptionContL (String -> IniFile) -> Parser String -> Parser IniFile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
value
  where
    value :: Parser String
value = (:) (Char -> ShowS)
-> ParsecT String () Identity Char
-> ParsecT String () Identity ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
" \t" ParsecT String () Identity Char -> Parser String -> Parser String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser String
eatWhiteSpace Parser String
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
" \t") ParsecT String () Identity ShowS -> Parser String -> Parser String
forall a b.
ParsecT String () Identity (a -> b)
-> ParsecT String () Identity a -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT String () Identity Char
-> ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline

{- | Parser for "noise" in the configuration file, such as comments and empty
lines.  (Note that lines containing only space characters will be
successfully parsed by 'optContParser'.)
-}
noiseParser :: Parser IniFile
noiseParser :: Parser IniFile
noiseParser =
    let
        commentP :: ParsecT String u Identity String
commentP = String -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"#;" ParsecT String u Identity Char
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String u Identity Char
-> ParsecT String u Identity Char
-> ParsecT String u Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline
        emptyL :: ParsecT String u Identity String
emptyL = (ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline ParsecT String u Identity Char
-> String -> ParsecT String u Identity String
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> String
"")
     in
        [Parser String] -> Parser String
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [Parser String
forall {u}. ParsecT String u Identity String
commentP, Parser String
forall {u}. ParsecT String u Identity String
emptyL] Parser String -> IniFile -> Parser IniFile
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> IniFile
CommentL

iniParser :: Parser [IniFile]
iniParser :: Parser [IniFile]
iniParser =
    Parser IniFile -> Parser [IniFile]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (Parser IniFile -> Parser [IniFile])
-> Parser IniFile -> Parser [IniFile]
forall a b. (a -> b) -> a -> b
$ [Parser IniFile] -> Parser IniFile
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [Parser IniFile
secParser, Parser IniFile
optLineParser, Parser IniFile
optContParser, Parser IniFile
noiseParser]