{-# 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
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 ()
= () 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