{-# LANGUAGE OverloadedStrings, ViewPatterns #-}

module Language.R.Package.Description.Parser (
    parseDCF
  , writeDCF
  , parseDesc
  , parseVersion
  ) where

import Control.Monad ((>=>))
import Data.Char
import Data.Functor
import Data.List
import Data.Maybe
import Data.Monoid
import qualified Data.Map.Lazy as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Control.Applicative
import Data.Attoparsec.Text as A

import Language.R.Package.Description.Types

type DCF = [(T.Text, T.Text)]

parseAll :: Parser a -> T.Text -> Parser a
parseAll parser s = case parseOnly (parser <* endOfInput) s of
  Left err -> fail err
  Right v -> pure v

filterKeys :: (k -> Bool) -> Map.Map k v -> Map.Map k v
filterKeys p = Map.filterWithKey (const . p)

parseDCF :: T.Text -> Either String DCF
parseDCF = parseOnly (manyTill parseRecord endOfInput)

writeDCF :: DCF -> String
writeDCF = undefined

ishspace :: Char -> Bool
ishspace c = c == ' ' || c == '\t'

hspace :: Parser ()
hspace = skipWhile ishspace

hspace1 :: Parser ()
hspace1 = satisfy ishspace *> hspace

between :: Parser l -> Parser r -> Parser a -> Parser a
between l r a = l *> a <* r

multiline :: Parser a -> Parser [a]
multiline line = (:) <$> (line <* end) <*> many (between hspace1 end line)
  where end = (() <$ char '\n') <|> endOfInput

parseRecord :: Parser (T.Text, T.Text)
parseRecord = (,) <$> (parseTag <* char ':') <*> (hspace *> parseValue)
  where
    parseTag = A.takeWhile (\c -> isAscii c && c /= ':')
    parseValue = T.unwords <$> multiline line
    line = A.takeWhile $ \c -> isPrint c && c /= '\n'

integer :: Parser Int
integer = decimal

parseVersion :: Parser Version
parseVersion = Version <$> integer <*> (char '.' *> integer) <*> option 0 ((char '.' <|> char '-') *> integer)

csvList :: Parser [T.Text]
csvList = concat <$> multiline line
  where
    ident = takeWhile1 $ \c -> isAscii c && c /= ',' && c /= '\n'
    line = sepBy (between hspace hspace ident) (char ',') <* optional (char ',') <* hspace

dcfToDesc :: DCF -> Parser RDesc
dcfToDesc dcf = RDesc <$>
      lookup "Package"
  <*> (lookup "Version" >>= parseAll parseVersion)
  <*> lookup "License"
  <*> lookup "Description"
  <*> lookup "Title"
  <*> pure ("Author" `Map.lookup` records)
  <*> pure ("Maintainer" `Map.lookup` records)
  <*> pure ("Authors@R" `Map.lookup` records)
  <*> (lookupDflt "" "Depends" >>= parseAll csvList)
  <*> (lookupDflt "" "Imports" >>= parseAll csvList)
  <*> traverse (parseAll csvList) ("Suggests" `Map.lookup` records)
  <*> (pure . Map.toList $ filterKeys (\tag -> not (tag `Set.member` rtags) && isUpper (T.head tag)) records)
  <*> (pure . Map.toList $ filterKeys (isLower . T.head) records)
  where
    rtags = Set.fromList ["Package", "Version", "License", "Description", "Title"
      , "Author" , "Maintainer", "Authors@R"] <> csv
    csv = Set.fromList ["Depends", "Imports", "Suggests"]
    mergeValue ((`Set.member` csv) -> True) l r = T.intercalate ", " [l, r]
    mergeValue _ l r = T.unwords [l, r]
    records = Map.fromListWithKey mergeValue dcf
    lookup field = maybe (fail $ "no field " ++ T.unpack field) pure $ Map.lookup field records
    lookupDflt dflt = maybe (pure dflt) pure . (`Map.lookup` records)

parseDesc :: T.Text -> Either String RDesc
parseDesc = parseDCF >=>  (`parseOnly` "") . dcfToDesc
