{-# LANGUAGE TupleSections #-}

module Bio.MAE.Parser
  ( maeP
  , versionP
  , blockP
  , tableP
  ) where

import           Bio.MAE.Type         (Block (..), Mae (..), MaeValue (..),
                                       Table (..))
import           Control.Applicative  ((<|>))
import           Control.Monad        (replicateM, when, zipWithM)
import           Data.Attoparsec.Text (Parser, anyChar, char, decimal,
                                       endOfInput, endOfLine, many', many1',
                                       peekChar, string, takeWhile, takeWhile1)
import           Data.Char            (isSpace)
import           Data.List            (transpose)
import           Data.Map.Strict      (Map)
import qualified Data.Map.Strict      as M (fromList)
import           Data.Text            (Text)
import qualified Data.Text            as T (cons, pack, uncons)
import qualified Data.Text.Read       as TR (decimal, rational, signed)
import           Prelude              hiding (takeWhile)

maeP :: Parser Mae
maeP :: Parser Mae
maeP = Text -> [Block] -> Mae
Mae forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
versionP
           forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser Block
blockP
           forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  forall t. Chunk t => Parser t ()
endOfInput

versionP :: Parser Text
versionP :: Parser Text
versionP = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser ()
tillEndOfLine forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Parser a -> Parser a
inBrackets (Parser Text
lineP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
delimiterP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
lineP)

blockP :: Parser Block
blockP :: Parser Block
blockP = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Map Text MaeValue -> [Table] -> Block
Block forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
anyStringP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser Char
oneSpaceP)
                 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Parser a -> Parser a
inBrackets ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Map Text MaeValue)
fieldsP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser Table
tableP)
  where
    fieldsP :: Parser (Map Text MaeValue)
    fieldsP :: Parser (Map Text MaeValue)
fieldsP = do
        [Text]
fieldNames  <- forall a. Parser a -> Parser [a]
upToDelimiterP Parser Text
lineP
        [Text]
fieldMaeValues <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
fieldNames) Parser Text
lineP

        forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Text
k Text
v -> (Text
k,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Parser MaeValue
textToMaeValue Text
k Text
v) [Text]
fieldNames [Text]
fieldMaeValues

textToMaeValue :: Text -> Text -> Parser MaeValue
textToMaeValue :: Text -> Text -> Parser MaeValue
textToMaeValue Text
k Text
v = if Text
v forall a. Eq a => a -> a -> Bool
== Text
absentMaeValue then forall (f :: * -> *) a. Applicative f => a -> f a
pure MaeValue
Absent else
    case Text -> Maybe (Char, Text)
T.uncons Text
k of
        Just (Char
c, Text
_) -> Char -> Text -> Parser MaeValue
getMaeValueReader Char
c Text
v
        Maybe (Char, Text)
_           -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Absent field name."
  where
    absentMaeValue :: Text
    absentMaeValue :: Text
absentMaeValue = Text
"<>"

    getMaeValueReader :: Char -> Text -> Parser MaeValue
    getMaeValueReader :: Char -> Text -> Parser MaeValue
getMaeValueReader Char
'i' = Text -> Parser MaeValue
textToIntMaeValueReader
    getMaeValueReader Char
'r' = Text -> Parser MaeValue
textToRealMaeValueReader
    getMaeValueReader Char
'b' = Text -> Parser MaeValue
textToBoolMaeValueReader
    getMaeValueReader Char
's' = Text -> Parser MaeValue
textToStringMaeValueReader
    getMaeValueReader Char
_   = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unknown value type."

    textToIntMaeValueReader :: Text -> Parser MaeValue
    textToIntMaeValueReader :: Text -> Parser MaeValue
textToIntMaeValueReader = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> MaeValue
IntMaeValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Reader a -> Reader a
TR.signed forall a. Integral a => Reader a
TR.decimal

    textToRealMaeValueReader :: Text -> Parser MaeValue
    textToRealMaeValueReader :: Text -> Parser MaeValue
textToRealMaeValueReader = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> MaeValue
RealMaeValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Reader a -> Reader a
TR.signed forall a. Fractional a => Reader a
TR.rational

    textToBoolMaeValueReader :: Text -> Parser MaeValue
    textToBoolMaeValueReader :: Text -> Parser MaeValue
textToBoolMaeValueReader Text
t =
        case Text
t of
            Text
"0" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool -> MaeValue
BoolMaeValue Bool
False
            Text
"1" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool -> MaeValue
BoolMaeValue Bool
True
            Text
_   -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can't parse bool value."

    textToStringMaeValueReader :: Text -> Parser MaeValue
    textToStringMaeValueReader :: Text -> Parser MaeValue
textToStringMaeValueReader = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MaeValue
StringMaeValue

tableP :: Parser Table
tableP :: Parser Table
tableP = do
    Text
name            <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser Char
oneSpaceP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Text
takeWhile1 (forall a. Eq a => a -> a -> Bool
/= Char
leftSquareBracket)
    Int
numberOfEntries <- Char -> Parser Char
char Char
leftSquareBracket forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Integral a => Parser a
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
rightSquareBracket

    String
_ <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser Char
oneSpaceP

    Map Text [MaeValue]
contents <- forall a. Parser a -> Parser a
inBrackets forall a b. (a -> b) -> a -> b
$ do
        [Text]
fieldNames  <- forall a. Parser a -> Parser [a]
upToDelimiterP Parser Text
lineP
        let readers :: [Text -> Parser MaeValue]
readers = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text -> Parser MaeValue
textToMaeValue [Text]
fieldNames
        [[MaeValue]]
entries     <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numberOfEntries forall a b. (a -> b) -> a -> b
$ [Text -> Parser MaeValue] -> Parser [MaeValue]
entryP [Text -> Parser MaeValue]
readers

        Parser ()
delimiterP

        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
fieldNames forall a b. (a -> b) -> a -> b
$ forall a. [[a]] -> [[a]]
transpose [[MaeValue]]
entries

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Map Text [MaeValue] -> Table
Table Text
name Map Text [MaeValue]
contents
  where
    leftSquareBracket :: Char
    leftSquareBracket :: Char
leftSquareBracket = Char
'['

    rightSquareBracket :: Char
    rightSquareBracket :: Char
rightSquareBracket = Char
']'

    entryP :: [Text -> Parser MaeValue] -> Parser [MaeValue]
    entryP :: [Text -> Parser MaeValue] -> Parser [MaeValue]
entryP [Text -> Parser MaeValue]
readers = do
        [Text]
valuesT <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many1' (forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser Char
oneSpaceP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
valueTP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser Char
oneSpaceP) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
tillEndOfLine
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text -> Parser MaeValue]
readers forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
valuesT forall a. Num a => a -> a -> a
- Int
1) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Wrong number of values in an entry."
        forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM forall a b. (a -> b) -> a -> b
($) [Text -> Parser MaeValue]
readers forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 [Text]
valuesT

--------------------------------------------------------------------------------
-- Utility functions.
--------------------------------------------------------------------------------

inBrackets :: Parser a -> Parser a
inBrackets :: forall a. Parser a -> Parser a
inBrackets Parser a
p =  Char -> Parser Char
char Char
leftBracket forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many1' Parser ()
tillEndOfLine
             forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p
             forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser Char
oneSpaceP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
rightBracket forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many1' Parser ()
tillEndOfLine
  where
    leftBracket :: Char
    leftBracket :: Char
leftBracket = Char
'{'

    rightBracket :: Char
    rightBracket :: Char
rightBracket = Char
'}'

delimiterP :: Parser ()
delimiterP :: Parser ()
delimiterP = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser Char
oneSpaceP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
string Text
delimiter forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
tillEndOfLine
  where
    delimiter :: Text
    delimiter :: Text
delimiter = Text
":::"

upToDelimiterP :: Parser a -> Parser [a]
upToDelimiterP :: forall a. Parser a -> Parser [a]
upToDelimiterP Parser a
p = ([] forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ()
delimiterP) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Parser a -> Parser [a]
upToDelimiterP Parser a
p)

oneSpaceP :: Parser Char
oneSpaceP :: Parser Char
oneSpaceP = Char -> Parser Char
char Char
' '

anyStringP :: Parser Text
anyStringP :: Parser Text
anyStringP = (Char -> Bool) -> Parser Text
takeWhile1 (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace)

valueTP :: Parser Text
valueTP :: Parser Text
valueTP  =  (forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Text
string Text
quoteT forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
notQuote forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Parser Text
string Text
quoteT))
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
anyStringP
  where
    quote :: Char
    quote :: Char
quote = Char
'\"'

    quoteT :: Text
    quoteT :: Text
quoteT = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
quote

    notQuote :: Parser Text
    notQuote :: Parser Text
notQuote = do
        Maybe Char
curCharPeek <- Parser (Maybe Char)
peekChar
        case Maybe Char
curCharPeek of
          Just Char
'\\' -> do
              Char
curChar <- Parser Char
anyChar
              Maybe Char
nextCharPeek <- Parser (Maybe Char)
peekChar
              case Maybe Char
nextCharPeek of
                Just Char
'\"' -> Parser Char
anyChar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Char
x -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char -> Text -> Text
T.cons Char
curChar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Text
T.cons Char
x) Parser Text
notQuote
                Maybe Char
_          -> Parser Text
notQuote forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Text
T.cons Char
curChar
          Just Char
'\"' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
          Just Char
_    -> Parser Char
anyChar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Char
x -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char -> Text -> Text
T.cons Char
x) Parser Text
notQuote
          Maybe Char
Nothing   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty

commentaryP :: Parser ()
commentaryP :: Parser ()
commentaryP = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser Char
oneSpaceP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Char
char Char
'#' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Text
takeWhile (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'\n', Char
'\r']) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
endOfLine)

lineP :: Parser Text
lineP :: Parser Text
lineP = Parser ()
commentaryP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser Char
oneSpaceP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
valueTP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
tillEndOfLine forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
commentaryP

tillEndOfLine :: Parser ()
tillEndOfLine :: Parser ()
tillEndOfLine = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser Char
oneSpaceP forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
endOfLine