{-|
Module      : Data.Configfile.Class
Description : Higher-kinded configuration data
Copyright   : (c) Lackmann Phymetric
License     : GPL-3
Maintainer  : olaf.klinke@phymetric.de
Stability   : experimental

This module provides parser combinators for handling program configuration, 
both given on the command line and in a configuration file. 
The configuration may be spread over multiple files. 
This allows for both configuration and input data to be parsed into a single data structure, 
which can subsequently be passed around in the control flow of the program. 

To use this module, you must 

(1) parametrize your configuration data by a functor, so that it has the kind @(* -> *) -> *@
2. Provide instances for the 'CPointed', 'CZipWith' and 'CZipWithM' classes (typically using Template Haskell)
3. provide an instance for the 'Config' type class (boilerplate, mostly choosing names)
4. write a parser for each of the data structure's fields
5. assemble these parsers into a 'ParsableConfig' type class instance (boilerplate)

The package abstracts the concrete parser type into the 'MonadParse' and 'MonadParseIO' classes, 
facilitating working with any parser combinator library. 

The choice of functor parameter influences the behavior: 
Its 'Alternative' instance determines how to combine multiply-defined options. 
For example, with 'Maybe' earlier options override later ones 
(because @'Just' a '<|>' 'Just' b = 'Just' a@)  
whereas with 'Latest' later options override earlier ones, while @[]@ collects all given options. 

Suppose

@
runParser :: p a -> String -> String -> Either ParseError a
@

is the function parsing a named input stream. Then parsing a configuration file 
and command line options with the latter overriding the former 
is done as follows. 

@
parseResult <- 'parseConfigurationFile' runParser 'defaultConfigParsing' "config.txt"
case parseResult of
  Left someParseErr -> ... 
  Right a -> do
    args <- getArgs
    case 'parseCmdLineArgs' (runParser "command line") args of
        Left someParseErr -> ...
        Right b -> return ('cTraverse' 'getLatest' (a <> b))
@

The configuaration may reference other files as follows. Suppose a valid piece of configuration file is

@
[Input CSV]
foo,1
bar,2
@

Then we can have a file named "input.csv" with the content

@
foo,1
bar,2
@

and the configuration file instead has content 

@
[Input CSV]
#include input.csv
@

Then parse this file with

@
'parseConfigurationFile' runParser ('setConf' 'followIncludes' 'True' 'defaultConfigParsing')
@

-}
{-# LANGUAGE Rank2Types
            ,FlexibleInstances
            ,FlexibleContexts
            ,MultiParamTypeClasses
            ,IncoherentInstances
            ,DeriveDataTypeable
            ,KindSignatures
            ,TemplateHaskell
            ,TypeFamilies
#-}
module Data.Configfile.Class (
    -- * Class of Configurations
    Config(..),
    FieldLens(..),
    FieldFlag(..),
    listConst,
    emptyConfigFile,
    -- ** partial configuration
    -- $partial
    HasEmpty(..),
    Latest(..),
    MissingFieldException,
    checkPresence,
    -- ** interdependent configuration
    -- $interdependent
    resolveInterdependencies,
    -- * Class of parsable configurations
    ParsableConfig(..),
    -- ** parser combinators
    -- $combinators
    makeParser,
    anyOrder,
    -- *** command line arguments
    cmdLineParser,
    -- *** config files
    configFileParser,
    iniStyle,
    equationStyle,
    allowIncludes,
    -- ** Controlling the parsing behaviour
    ConfigParsingOpts,
    ConfigParsing(..),
    defaultConfigParsing,
    HeaderStyle(..),
    -- * Convenience functions
    setConf,
    parseCmdLineArgs,
    parseConfigurationFile
    ) where
import Control.Applicative
import Control.Arrow (first)
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State.Lazy
import Control.Monad.Except
import Control.Monad.Parse.Class
import Control.Exception hiding (try)
import Control.Lens hiding (anyOf)
import Control.Lens.TH 
import Data.Typeable (Typeable)
import Data.Monoid hiding (Last(..))
import Data.Char (isSpace)
import Data.List (intercalate)
import Data.List.NonEmpty
import Data.Functor
import Data.Functor.Identity
import Data.List (stripPrefix)
import Data.CZipWith
import System.Environment (getArgs)

instance (Alternative t, CZipWith f) => Semigroup (f t) where
    (<>) = cZipWith (<|>)
-- | Needs IncoherentInstances because of 
--
-- @
-- instance forall a k (b :: k). Monoid a => Monoid (Const a b)
-- Defined in Data.Functor.Const
-- @
-- 
instance (Alternative t, CPointed f, CZipWith f) => Monoid (f t) where
    mempty = cPoint empty
    mappend = cZipWith (<|>)

-- * Class of Configurations 

-- | Class of configuaration data types of kind @(* -> *) -> *@. 
-- Record fields are named ('fieldNames'), 
-- can be specified on the command line by 'fieldFlags' 
-- and have a 'Lens' for each field. 
class (CPointed f, CZipWithM f) => Config (f :: (* -> *) -> *) where
    fieldNames  :: f (Const String) -- ^ names of the fields, also the headers inside configuration files.
    -- TODO: Can the fieldNames be generated using Generics or TH?
    fieldFlags  :: f (Const FieldFlag) -- ^ specifies syntax for command line parsing
    fieldLenses :: forall t. f (FieldLens f t) -- ^ lenses for each record field
    -- TODO: Can makeLenses be adopted to generate the above too?

-- | 'FieldLens'es can be automatically generated using 'makeLenses':
-- 
-- @
-- data 'ConfigParsing' f = 'ConfigParsing' {
--    _headerStyle    :: f 'HeaderStyle', 
--    _followIncludes :: f 'Bool'
-- }
--
-- 'makeLenses' ''ConfigParsing
--
-- instance 'Config' 'ConfigParsing' where
--    'fieldLenses' = 'ConfigParsing' {
--      _headerStyle    = 'FieldLens' headerStyle,
--      _followIncludes = 'FieldLens' followIncludes} 
-- @
newtype FieldLens f t a = FieldLens {runLens :: Lens' (f t) (t a)}

-- | Determines how a record is parsed on the command line. 
-- 
-- @
-- 'Prefix' \'o\' "opt"
-- @
-- 
-- has the effect that @-o value@ or @--opt value@ can be given on the command line, whereas
-- 
-- @
-- 'Flag'
-- @
--
-- has the effect that @--value@ can be given on the command line. 
-- The latter is useful for binary flags like @--debug@ whith a default value. 
-- For example, the 'ConfigParsing' type has 
--
-- @ 
-- fieldFlags = ConfigParsing {
--     _headerStyle    = Const (Prefix \'h\' "header"),
--     _followIncludes = Const Flag}
-- @
-- 
-- and correspondingly possible command line arguments include
-- 
-- @
-- -h 'EquationStyle'
-- --header 'IniStyle'
-- --follow-includes
-- --ignore-includes
-- @
-- 
-- where the 'fieldParsers' parse the string "follow-includes" as 'True' and 
-- the string "ignore-includes" as 'False'.  
data FieldFlag = Prefix Char String | Flag

-- | Use this e.g. for listing the field names for usage messages: @listConst fieldNames@
listConst :: (CZipWithM f, Applicative t, Monoid (t a)) => f (Const a) -> t a
listConst = fst . cTraverse gather where
    gather field@(Const a) = (pure a,field)

-- | Generate a string from the 'fieldNames' that passes as empty configuration file. 
-- The second component of the return type is just a dummy to tell Haskell which 'Config' instance to pick. 
-- 
-- >>> writeFile "empty.cfg" (fst (emptyConfigFile IniStyle))
emptyConfigFile :: Config f => HeaderStyle -> (String,f (Const ()))
emptyConfigFile style = first (intercalate "\n") $ cTraverse (\(Const name) -> (h name,Const ())) fieldNames where
    h name = case style of
        IniStyle -> ['[':name++"]"]
        EquationStyle -> [name++" = "]

-- ** Partial configuration
-- $partial
-- Typically one allows configuration to be pieced together from partial configurations, 
-- e.g. some specified in a configuration file, some on the command line. 
-- For this, an 'Alternative' functor can be used. 
-- We combine the partial configurations using the orphan 'Monoid' instance defined in this module 
-- and check the combined configuration for presence of all fields. 

-- | 'Alternative's where we can pattern match on the 'empty'.
-- Instances should satisfy 
-- 
-- @
-- 'isEmpty' 'empty' = 'True'
-- @
--
-- and more generally 
--  
-- @
-- 'sansEmpty' x
-- @
-- 
-- results in a run-time error if and only if 
-- 
-- @
-- 'isEmpty' x = 'True'
-- @
class Alternative f => HasEmpty f where
    type SansEmpty f :: * -> *
    -- ^ the same type as f but without the 'empty'
    isEmpty :: f a -> Bool
    sansEmpty :: f a -> SansEmpty f a
instance HasEmpty Maybe where
    type SansEmpty Maybe = Identity
    isEmpty Nothing = True
    isEmpty _ = False
    sansEmpty (Just x) = Identity x
    sansEmpty Nothing = error "sansEmpty Nothing"
instance HasEmpty [] where
    type SansEmpty [] = NonEmpty
    isEmpty = null
    sansEmpty (x:xs) = x :| xs
    sansEmpty [] = error "sansEmpty []"
instance HasEmpty Latest where
    type SansEmpty Latest = Identity
    isEmpty = isEmpty . getLatest
    sansEmpty = sansEmpty . getLatest

-- | 'Maybe' where '<|>' yields the second non-Nothing argument, not the first. 
newtype Latest a = Latest {getLatest :: Maybe a}
instance Functor Latest where
    fmap f (Latest a) = Latest (fmap f a)
instance Applicative Latest where
    pure = Latest . Just
    (Latest f) <*> (Latest x) = Latest (f <*> x)
instance Alternative Latest where
    empty = Latest Nothing
    a <|> (Latest Nothing) = a
    _ <|> b@(Latest (Just _)) = b
instance Show a => Show (Latest a) where
    show (Latest (Just a)) = "Just "++show a
    show (Latest Nothing) = "Nothing"

-- | When parsing incomplete configuration, some fields may be missing.
data MissingFieldException = MissingFields [String] deriving (Typeable)
instance Show MissingFieldException where
    show (MissingFields []) = "Missing Fields: none"
    show (MissingFields xs) = "Missing Fields: "++(intercalate ", " xs)
instance Exception MissingFieldException where
instance Semigroup MissingFieldException where
    (MissingFields xs) <> (MissingFields ys) = MissingFields (xs++ys)
instance Monoid MissingFieldException where
    mempty = MissingFields []
    mappend (MissingFields xs) (MissingFields ys) = MissingFields (xs++ys)

-- | returns a 'Right' if and only if no field 'isEmpty'.
checkPresence :: (Config f,HasEmpty t) => f t -> Either MissingFieldException (f (SansEmpty t))
checkPresence = allPresent . cZipWithM present fieldNames where
    present (Const name) x = if isEmpty x 
        then (MissingFields [name],undefined)
        else (mempty,sansEmpty x)
    allPresent (MissingFields [],complete) = Right complete
    allPresent (someMissing,_) = Left someMissing

-- | count the number of fields where 'isEmpty' is 'False'.
countDefined :: (CZipWithM f, HasEmpty t) => f t -> Int
countDefined = getSum . fst . cTraverse countJust where
    countJust x = (if isEmpty x then Sum 0 else Sum 1,x)

-- ** Interdependent configuration
-- $interdependent
-- Parts of a configuration may depend on other parts. For example,
-- 
-- @
-- data MyConfig t = MyConfig {
--    stem :: t FilePath,
--    ext1 :: t String,
--    ext2 :: t String
-- }
-- @
-- 
-- For convenience we declare only the following data. 
-- 
-- @
-- conf = MyConfig {
--    stem = Identity "\/path\/to\/foo",
--    ext1 = Identity ".hs",
--    ext2 = Identity ".o"
-- }
-- @
-- 
-- But we want the full file names automatically. 
-- We can achieve this by specifying the following record.
-- 
-- @ 
-- addStem :: MyConfig (Reader (MyConfig Identity))
-- addStem = MyConfig {
--    stem = ReaderT stem,
--    ext1 = ReaderT (\\conf -> liftA2 (++) (stem conf) (ext1 conf)),
--    ext2 = ReaderT (\\conf -> liftA2 (++) (stem conf) (ext2 conf))
-- }
-- @

-- | Complete fields that depend on other fields. 
-- Note that this is a single-pass function. 
-- The target field must occur later than the source 
-- in the order defined by the 'CZipWithM' instance. 
-- To resolve more complicated dependencies, apply this function several times. 
resolveInterdependencies :: Config f => f (ReaderT (f t) t) -> f t -> f t
resolveInterdependencies readF = execState (cZipWithM threadReader readF fieldLenses) where
    threadReader (ReaderT rta) (FieldLens a) = state (\ft -> let ta = rta ft in (ta,set a ta ft))

-- * Class of parsable configurations

-- | Parsers for the configuration 
class (Config f, Monad p, Alternative p) => ParsableConfig p f where
    fieldParsers :: f p -- ^ a parser for each field in the configuration

-- ** Parser combinators
-- $combinators
-- Functions in this section are intended to transform the 'fieldParsers' of a 'Config' 
-- into a single parser, e.g. for parsing command line arguments or a configuration file. 
-- Typically one starts with 'fieldParsers' and applies several of the combinators 
-- 'cmdLineParser', 'configFileParser' or 'allowIncludes', 
-- then transforms the record of parsers into a parser of records by applying 'makeParser' 
-- and finally 'anyOrder' so that options need not be given in the order specified 
-- by the 'CZipWith' instance. 
--
-- Beware that this does not free the user from handling empty lines and comments. 
-- Blank lines and comments must be handled by the field parsers. 

-- | Given a record of parsers, generate a parser for the record. 
-- Basically concatenates all parsers in the order specified in the 'CZipWithM' instance.
-- Any field can be left out, and will be parsed as 'empty'. 
-- Beware that this means that the empty string is successfully parsed, 
-- whence the combination with 'some' will result in an infinite loop. 
makeParser :: (CZipWithM f, MonadParse p, Alternative p, Alternative t) => f p -> p (f t)
makeParser = cTraverse f where
    f pa = try (fmap pure pa) <|> return empty

-- | parse the fields in any order, in any number, 
-- combines using the 'Monoid' instance of @f t@. 
anyOrder :: (Monad p, Alternative p, CPointed f, CZipWithM f, HasEmpty t, Alternative t) => p (f t) -> p (f t)
anyOrder = fmap mconcat . manyDefined where
    manyDefined p = do
        x <- p
        if countDefined x > 0
            then fmap (x:) $ manyDefined p
            else return []

cmdLineArgsSeparatorChar = '\0' -- maybe '\n' is a better choice? 
-- | Prepend the command line flags defined in 'fieldFlags' to the 'fieldParsers'. 
-- Every command line option expects zero ('Flag') or exactly one ('Prefix') 
-- following arguments. If the flag itself or the argument contains whitespace, 
-- this must be escaped on the command line.
--
-- Use as follows.
-- 
-- >>> 'anyOrder' ('makeParser' 'cmdLineParser')
cmdLineParser :: (MonadParse p, ParsableConfig p f) => f p
cmdLineParser = cZipWith flag fieldFlags fieldParsers where
    flag (Const (Prefix short long)) p = do
        many (char cmdLineArgsSeparatorChar)
        char '-'
        string [short] <|> do
            char '-'
            string long
        char cmdLineArgsSeparatorChar
        p
    flag (Const Flag) p = do
        many (char cmdLineArgsSeparatorChar)
        string "--"
        p
-- The command line arguments come as a @[String]@ but parsers are written to 
-- accept @String@. Therefore we assume that the command line arguments 
-- are re-assembled into a single string with @\\0@ Chars as separators 
-- before feeding to the parser. 

-- | Prepend section headers derived from the 'fieldNames' to the 'fieldParsers'. 
-- How a field name is parsed is determined by the argument. Examples are 
-- 
-- @
-- 'configFileParser' 'equationStyle' 
-- 'configFileParser' 'iniStyle'
-- @
--
-- The two lines generate parsers for
--
-- @
-- fieldname = data
-- @
-- 
-- and 
-- 
-- @
-- [fieldname]
-- data
-- @
--
-- respectively. 
configFileParser :: (MonadParse p, ParsableConfig p f) => (String -> p String) -> f p -> f p
configFileParser sectionHeader fp = cZipWith (\(Const h) p -> sectionHeader h >> p) fieldNames fp

-- | In each field, instead of the data itself 
-- allow statements of the form 
-- 
-- @
-- #include \/path\/to\/data
-- @
--  
-- indicating that the file @\/path\/to\/data@ should be parsed instead (using 'fromFile').  
-- Within the file path, whitespace must be escaped. (Uses 'escapedWhitespace'.) 
-- The field parser is amended with a parser for trailing whitespace and 'eof'. 
allowIncludes :: (CZipWithM f, MonadParseIO p) => f p -> f p
allowIncludes = runIdentity . cTraverse (Identity . f) where -- avoid using cMap
    f p = include p <|> p
    include p = do
        string "#include"
        some (char ' ')
        filename <- escapedWhitespace
        (p <* many (anyOf isSpace) <* eof) `fromFile` filename

-- ** Controlling the parsing behaviour

-- | pick one of 'iniStyle' or 'equationStyle'
data HeaderStyle = IniStyle | EquationStyle deriving (Eq,Show)

type ConfigParsingOpts = ConfigParsing Identity
-- | Options that control how configuration files are parsed. 
-- This is an example of a higher-type configuration. 
-- The necessary lenses and 'CZipWith' instances are generated using Template Haskell. 
data ConfigParsing f = ConfigParsing {
    _headerStyle :: f HeaderStyle, 
    _followIncludes :: f Bool
}
instance Show (ConfigParsing Identity) where
    show x = "ConfigParsing {headerStyle = "++(show.runIdentity._headerStyle $ x)++", followIncludes = "++(show.runIdentity._followIncludes $ x)++"}"
instance Show (ConfigParsing Maybe) where
    show x = "ConfigParsing {headerStyle = "++(show (_headerStyle x))++", followIncludes = "++(show (_followIncludes x))++"}"

makeLenses ''ConfigParsing -- generate lenses headerStyle and followIncludes
-- generate the necessary type class instances
deriveCPointed ''ConfigParsing
deriveCZipWith ''ConfigParsing
deriveCZipWithM ''ConfigParsing

instance Config ConfigParsing where
    fieldNames = ConfigParsing {
        _headerStyle = Const "Header Style",
        _followIncludes = Const "Follow Includes"}
    fieldFlags = ConfigParsing {
        _headerStyle = Const (Prefix 'h' "header"),
        _followIncludes = Const Flag}
    fieldLenses = ConfigParsing {
        _headerStyle = FieldLens headerStyle,
        _followIncludes = FieldLens followIncludes}

-- | parser for the '_headerStyle' field
parseHeaderStyle :: MonadParse p => p HeaderStyle
parseHeaderStyle = (try (string "IniStyle" $> IniStyle)) <|> (string "EquationStyle" $> EquationStyle)

-- | parser for the '_followIncludes' field. 
parseFollowIncludes :: MonadParse p => p Bool
parseFollowIncludes = (try (string "follow-includes" $> True)) <|> (string "ignore-includes" $> False)

instance MonadParse p => ParsableConfig p ConfigParsing where
    fieldParsers = ConfigParsing {
        _headerStyle = parseHeaderStyle,
        _followIncludes = parseFollowIncludes}

-- | The default behaviour is 'IniStyle' and no include statements
defaultConfigParsing :: Applicative f => ConfigParsing f
defaultConfigParsing = ConfigParsing {_headerStyle = pure IniStyle, _followIncludes = pure False}

-- | Sections of config files in the Windows INI file style, e.g.
-- 
-- @
-- [section name]
-- parsable content
-- @
--
-- This is the default. 
iniStyle :: MonadParse p => String -> p String
iniStyle name = many (char '\n') *> char '[' *> string name <* char ']' <* many (char ' ') <* char '\n'

-- | Config files in equation style, e.g.
--
-- @
-- config1 = parsable content
-- config2 = parsable content
-- @
-- 
-- Consumes all spaces and tabs after the equality sign. 
equationStyle :: MonadParse p => String -> p String
equationStyle = let white = many (anyOf (\c -> c == ' ' || c == '\t')) in \name -> 
    white *> string name <* white <* char '=' <* white

-- ** Convenience functions

-- | Override a value using one of the 'FieldLens'es generated by 'makeLenses'.
setConf :: Applicative t => Lens' (f t) (t a) -> a -> f t -> f t
setConf field = set field . pure

infixl 8 ^:
-- | convenient '(^.)' wrapper for complete configurations
(^:) :: f Identity -> Lens' (f Identity) (Identity a) -> a
conf ^: field = runIdentity (conf ^. field)

-- | parse command line arguments using your favourite parser library's @runParser@ function. Example:
-- 
-- @
-- import System.Environment
-- import Text.Megaparsec (runParser)
-- args <- getArgs
-- parseCmdLineArgs (runParser "command line") args
-- @
parseCmdLineArgs :: (ParsableConfig p f, MonadParse p, Alternative t, HasEmpty t) =>
    (forall a. p a -> String -> parseResult a) -> [String] -> parseResult (f t)
parseCmdLineArgs parse args = parse (anyOrder (makeParser cmdLineParser)) (intercalate [cmdLineArgsSeparatorChar] args)

-- | parse a configuration file using your favourite parser library's @runParser@ function. Example:
-- 
-- @
-- import Text.Megaparsec (runParserT)
-- import Control.Monad.Except
-- parseConfigurationFile parse opts "myConfig.ini" where
--   opts = setConf followIncludes True defaultConfigParsing
--   parse p name content = ExceptT (runParserT p name content)
-- @
parseConfigurationFile :: (MonadIO parseResult, ParsableConfig p f, MonadParseIO p, Alternative t, HasEmpty t) => 
    (forall a. p a -> String -> String -> parseResult a) ->
    ConfigParsingOpts -> 
    FilePath -> parseResult (f t)
parseConfigurationFile parse opts cfgfile = let
    header = case _headerStyle opts of
        Identity      IniStyle -> iniStyle
        Identity EquationStyle -> equationStyle
    incl = case _followIncludes opts of
        Identity True  -> allowIncludes
        Identity False -> id
    in do
        content <- liftIO (readFile cfgfile)
        parse (anyOrder (makeParser (configFileParser header (incl fieldParsers))) <* many (anyOf isSpace) <* eof) cfgfile content