List.hs

{-# Language FlexibleInstances, FunctionalDependencies, OverlappingInstances,
             OverloadedStrings, TupleSections, UndecidableInstances #-}

{- |
Module      : Data.Ini.List
Description : Ini config file parser using Lists, not Maps.
Copyright   : &#xa9; Mike Meyer, 2015
License     : BSD3
Maintainer  : mwm@mired.org
Stability   : experimental

Most ini config files turn into 1-1 maps quite nicely. However,
some encode lists of objects, which require having more than one
section of a given name, or more than one value in a section with a
given name - and order matters.

This package parsers Ini files, but instead of creating maps, it
creates a list of sections, each section of which is a list of
values. As a result, the 'get' function can now return a list of
values for options that can occur multiple times, and there are plural
versions of the Option and Section fetchers.

-}

module Data.Ini.List
    (
     -- * Types
     Section,
     Config,
     OptionName,
     SectionName,
     Option,
     SectionItem,
     ConfigItem,
     UpdateValue,
     UpdateOption,
     Value(value, getValue),
     -- * Build
     config,
     setDefault,
     (<+), (+>),
     -- * Convert
     toList,
     fromList,
     -- * Query
     get,
     getDefault,
     getSection,
     getSections,
     getSectionsBy,
     -- * Update
     updateValues,
     updateDefaultValues,
     updateSectionValues,
     updateOptions,
     updateDefaultOptions,
     updateSectionOptions,
     -- * Format
     formatConfig,
     writeConfig,
     writeConfigFile,
     hWriteConfig,
     -- * Parse
     parseConfig,
     parseFile,
     parseFileEx
    ) where


import Control.Applicative ((<$>), (<|>), (<*>), (<*), (*>), Applicative, 
                            many, optional, pure, some)
import qualified Data.AList as AL
import Data.Bifunctor (second)
import Data.Char (isPrint, isSpace, toLower)
import Data.Maybe (fromMaybe)
import Data.List (isPrefixOf, intercalate)
import Data.Monoid (Monoid, mempty, mappend, (<>))
import Safe (readMay, headMay)
import System.IO
import Text.Trifecta ((<?>), char, CharParsing, eof, manyTill, newline, oneOf,
                      option, parseFromFile, parseFromFileEx, parseString,
                      Result, runUnlined, satisfy, sepEndBy, sepEndBy1,
                      TokenParsing, try, whiteSpace)


-- My types
-- | A config is an unmaned 'Section' and an 'AList' of 'SectionItem's.
data Config = Config Section (AL.AList SectionName Section) deriving (Show)

type OptionName = String
-- | Names are all 'String's.
type SectionName = String

-- | As are values.
type Option = String

-- | A 'Section' is just an 'AList'.
type Section = AL.AList OptionName Option

type SectionItem = (OptionName, Option)
-- | Convient names for items from a 'Section' or 'Config'
type ConfigItem = (SectionName, Section)

-- | An 'UpdateValue' is a function that takes a 'SectionName',
-- 'OptionName' and 'Option' and returns a Nothing if it doesn't want
-- to change the given 'SectionItem', or 'Just' 'Option' if it does.
type UpdateValue = SectionName -> OptionName -> Option -> Maybe Option

-- | An 'UpdateOption' is like an 'UpdateValue', except it returns a
-- 'Maybe' 'SectionItem', allowing it to change the key as well as the
-- value of the 'SectionItem' in question.
type UpdateOption = SectionName -> OptionName -> Option -> Maybe SectionItem

-- | The 'Value' class is one that the /get/ functions can
-- return.  Most notably, names that occur multiple times in a section
-- can become a 'List', returning a singleton or empty 'List' for
-- single or missing names in a context where a 'List' is needed.
--
-- @0/1@, @yes/no@, @on/off@, @true/false@ and @enabled/disabled@ values
-- will be returned as 'Bool' in the appropriate contexts.
--
-- Finally, any value that has a 'Read' instance will be converted
-- if possible, so that integer and floating point values can be
-- used immediately.
class Value a where
    -- | @'getValue' 'Section' 'OptionName'@ gets the value for the
    -- named 'Option' from the 'Section'. 
    getValue :: Section -> OptionName -> Maybe a
                
    -- The default is to just convert the current string.
    getValue s o = value <$> getOption s o

    -- | 'value' converts a single 'Option' 'String' into a value of
    -- the type of the instance.
    value :: Option -> a

instance Value String where
    value v = v

instance Value Bool where
    value v = value' $ map toLower v
      where value' v' | elem v' ["1", "yes", "on", "enabled", "true"] = True
                      | elem v' ["0", "no", "off", "disabled", "false"] = False
            value' v' = error $ "couldn't parse '" ++ v' ++ "' as Bool"

instance Value t => Value [t] where
    getValue s o = Just . map value $ getOptions s o 
    value o = [value o]

instance Read t => Value t where
    value v = fromMaybe (error $ "couldn't parse '" ++ v ++ "'") $ readMay v


-- Constructors
-- We'd like Config & Section tweaking ops to be polymorphic.
-- Laws? Pragmatism strikes again!
class Cons container item | container -> item where
    -- | 'fromList' creates a 'Config' or 'Section' from a list of items.
    -- A Config gets an empty default section.
    fromList :: [item] -> container
    -- | 'toList' returns the 'AList' in the 'Config' or 'Section' as a list
    -- of items.
    toList :: container -> [item]
    cons :: item -> container -> container
    -- | (+>) and (<+) operators add items to a 'Config' or 'Section'
    (+>) :: item -> container -> container
    (+>) = cons
    (<+) :: container -> item -> container
    (<+) = flip (+>)

infixl 7 <+
infixr 7 +>

instance Cons Section SectionItem where
    fromList = AL.fromList
    toList = AL.toList
    cons i os = os <> AL.fromList [i]

instance Cons Config ConfigItem where
    fromList l = Config (AL.fromList []) (AL.fromList l)
    toList (Config _ sl) = AL.toList sl
    cons i (Config d sl)= Config d $ sl <> AL.fromList [i]


-- | 'Config' as a Monoid is a bit off. The default sections are
-- append to each other. This is required for it to obey the Monoid
-- laws.
instance Monoid Config where
    mempty  = Config (AL.fromList []) $ AL.fromList []
    mappend (Config ad al) (Config bd bl) = Config (ad <> bd) $ al <> bl


-- | 'config' creates a 'Config' from the given default 'Section'
-- and list of 'ConfigItem''s.
config :: Section -> [ConfigItem] -> Config
config s l = Config s $ AL.fromList l

-- | 'setDefault' sets the default 'Section' for the 'Config'.
setDefault :: Config -> Section -> Config
setDefault (Config _ sl) s = Config s sl

-- | 'getDefault' returns the default section from a 'Config'.
getDefault :: Config -> Section
getDefault (Config d _) = d

-- | 'getSections' returns the 'List' of 'Section's with /name/ in the 'Config'.
getSections :: Config -> SectionName -> [Section]
getSections (Config _ sl) n = AL.lookupAll n sl

-- | 'getSection' returns the first 'Section' /name/ from 'Config' if one
-- exists.
getSection :: Config -> SectionName -> Maybe Section
getSection c n = headMay $ getSections c n

-- | 'getSectionsBy' returns a list of 'ConfigItem''s from a 'Config'
-- chosen by the provided function.
getSectionsBy :: Config -> (SectionName -> Bool) -> [ConfigItem]
getSectionsBy (Config _ sl) sel = filter (\(n, _) -> sel n) $ AL.toList sl

-- | 'get' a value from a 'Config' selected by 'Maybe' 'SectionName'
-- and 'OptionName'.  'Nothing' as the 'SectionName' gets 'Option' values
-- from the default 'Section'.
get :: Value a => Config -> Maybe SectionName -> OptionName -> Maybe a
get c s o = get' s >>= (flip getValue) o where
    get' (Just n) = getSection c n
    get' Nothing  = Just $ getDefault c


-- And finally, the things to update a Config

-- So it turns out both types of updaters are also Monoids. Who knew?
emptyUpdate :: SectionName -> OptionName -> Option -> Maybe a
emptyUpdate _ _ _ = Nothing

mappendUpdate :: (SectionName -> OptionName -> Option -> Maybe a)
              -> (SectionName -> OptionName -> Option -> Maybe a)
              -> (SectionName -> OptionName -> Option -> Maybe a)
(a `mappendUpdate` b) s o v  =  maybe (b s o v) Just $ a s o v

instance Monoid (SectionName -> OptionName -> Option -> Maybe a) where
    mempty = emptyUpdate
    mappend = mappendUpdate

-- | 'updateOptions' uses an 'UpdateOption' to update all the options
-- in the 'Config'.
updateOptions :: UpdateOption -> Config -> Config
updateOptions f (Config d sl) =
    Config d . AL.fromList . map (\(n, s) -> (n, updateSectionOptions (f n) s))
           $ AL.toList sl

-- | 'updateOptions' uses an 'UpdateValue' to update all the values in
-- the 'Config'.
updateValues :: UpdateValue -> Config -> Config
updateValues f (Config d sl) =
    Config d . AL.fromList . map (\(n, s) -> (n, updateSectionValues (f n) s))
               $ AL.toList sl

-- | 'updateDefaultOptions' updates the options in the default
-- 'Section' of the 'Config' with the given function, which is similar
-- to an 'UpdateOption' without the 'SectionName' argument.
updateDefaultOptions :: (OptionName -> Option -> Maybe SectionItem)
                     -> Config
                     -> Config
updateDefaultOptions f (Config d sl) = Config (updateSectionOptions f d) sl

-- | 'updateDefaultOptions' updates the values in the default
-- 'Section' of the 'Config' with the given function, which is similar
-- to an 'UpdateValue' without the 'SectionName' argument.
updateDefaultValues :: (OptionName -> Option -> Maybe Option) -> Config -> Config
updateDefaultValues f (Config d sl) = Config (updateSectionValues f d) sl

updateSectionOptions :: (OptionName -> Option -> Maybe SectionItem)
                     -> Section
                     -> Section
-- | 'updateSectionOptions' updates the options in the named 'Section'
-- 'Section' of the 'Config' with the given function, which is similar
-- to an 'UpdateOption' without the 'SectionName' argument.
updateSectionOptions f os = AL.fromList . map (updateOption f) $ AL.toList os where
    updateOption f o@(n, v) = fromMaybe o $ f n v

-- | 'updateSectionValues' updates the values in the named 'Section'
-- of the 'Config' with the given function, which is similar to an
-- 'UpdateValue' without the 'SectionName' argument.
updateSectionValues :: (OptionName -> Option -> Maybe Option) -> Section -> Section
updateSectionValues f s = updateSectionOptions (updateValue f) s where
    updateValue f n o = (n ,) <$> f n o


-- Internal routines for getting options. Users should use
-- getValue
getOptions :: Section -> OptionName -> [Option]
getOptions os k =  map snd . filter (\(n, _) -> n == k) $ AL.toList os

getOption :: Section -> OptionName -> Maybe Option
getOption os n = AL.lookupFirst n os


-- And output things
formatOption :: SectionItem -> String
formatOption (name, val) = name ++ "=" ++ val

formatSection :: ConfigItem -> String
formatSection (name, section) =
  unlines $ ("[" ++ name ++ "]") : (map formatOption $ AL.toList section)

-- | 'formatConfig' converts a 'Config' to a 'String' representation
-- for use in a @.ini@ file.
formatConfig :: Config -> String
formatConfig (Config options sections) =
  intercalate "\n" $
                  (unlines . map formatOption $ AL.toList options)
    :(map formatSection $ AL.toList sections)

-- | 'writeConfigFile' formats a 'Config' and writes it to 'FilePath'.
writeConfigFile :: FilePath -> Config -> IO ()
writeConfigFile f c = writeFile f $ formatConfig c

-- | 'hwriteConfigFile' formats a 'Config' and writes it to a 'Handle'.
hWriteConfig :: Handle -> Config -> IO ()
hWriteConfig h c = hPutStr h $ formatConfig c

-- | 'writeConfig' formats a 'Config' and writes it to 'stdout'.
writeConfig :: Config -> IO ()
writeConfig = hWriteConfig stdout


-- | 'parseConfig' parses a 'String' into a 'Config', returning the
-- 'Config' wrapped in a a 'Result'
parseConfig :: String -> Result Config
parseConfig = parseString parser mempty

-- | 'parseFile' parses the named @.ini@ file, sending diagnostic messages to
-- the console.
parseFile :: FilePath -> IO (Maybe Config)
parseFile = parseFromFile parser

-- | 'parseFileEx' parses the named @.ini@ file, returning either the
-- 'Config' or diagnostic messages in the 'Result'.
parseFileEx :: FilePath -> IO (Result Config)
parseFileEx = parseFromFileEx parser

parser :: (Monad m, TokenParsing m) => m Config
parser = runUnlined
         $ optional lineSep *>
         (Config <$> (AL.fromList <$> sepEndBy (try optionLine) lineSep)
                 <*> (AL.fromList <$> many sectionLine))
         <* many (char '\0') -- Deal with file system oddness
         <* eof
         <?> "config"

sectionLine :: (Monad m, TokenParsing m) => m ConfigItem
sectionLine = (,) <$> sectionName <* lineSep
                  <*> (AL.fromList <$> sepEndBy1 (try optionLine) lineSep)
              <?> "section"

sectionName :: (Monad m, TokenParsing m) => m String
sectionName = whiteSpace
              *> char '['
              *> ((:) <$> satisfy (\c -> c /= ']' && isPrint c)
                      <*> manyTill printing (char ']')
                      <?> "section name") 
              <* many anyChar
              <?> "section start line"

optionLine :: (Monad m, TokenParsing m) => m SectionItem
optionLine = (,) <$> (strip <$> optionName)
                 <*> (unComment <$> many printing <?> "option value")
             <?> "option line" 
  where -- Handle some context-sensitive bits of the syntax
    strip = reverse . dropWhile isSpace . reverse
    unComment = dropWhile isSpace . reverse . dropWhile isSpace . unComment' ""
    unComment' r v | null v            = r
                   | isPrefixOf " ;" v = r
                   | otherwise         = unComment' (head v:r) (tail v)

optionName :: (Monad m, TokenParsing m) => m OptionName
optionName = whiteSpace *> ((:) <$> satisfy (\c -> isPrint c && c /= '[')
                                <*> manyTill printing (oneOf ":="))
             <?> "option name"

-- Lines are separated by a newline and zero or more comment lines.
lineSep :: (Monad m, TokenParsing m) => m ()
lineSep = some (whiteSpace <* optional (oneOf ";#" <* many anyChar) <* newline)
          *> pure ()
          <?> "line separator"

-- Some basic character types
printing, anyChar :: CharParsing m => m Char
printing = satisfy isPrint
anyChar = satisfy (/= '\n')