{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE Trustworthy #-}

-- | The value reader can handle a delightful mix of binary and
-- textual input.  It is the most general way of reading values, but
-- it is less efficient than using the 'Get' instance if you know that
-- the data will be in the binary format.
module Futhark.Data.Reader
  ( readValues,
  )
where

import Control.Monad
import Data.Binary
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Char (isPrint, isSpace)
import qualified Data.Text as T
import Futhark.Data
import Futhark.Data.Parser
import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MP

dropRestOfLine, dropSpaces :: LBS.ByteString -> LBS.ByteString
dropRestOfLine :: ByteString -> ByteString
dropRestOfLine = Int64 -> ByteString -> ByteString
LBS.drop Int64
1 (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
LBS.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')
dropSpaces :: ByteString -> ByteString
dropSpaces ByteString
t = case (Char -> Bool) -> ByteString -> ByteString
LBS.dropWhile Char -> Bool
isSpace ByteString
t of
  ByteString
t'
    | ByteString
"--" ByteString -> ByteString -> Bool
`LBS.isPrefixOf` ByteString
t' -> ByteString -> ByteString
dropSpaces (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
dropRestOfLine ByteString
t'
    | Bool
otherwise -> ByteString
t'

readValue :: LBS.ByteString -> Maybe (Value, LBS.ByteString)
readValue :: ByteString -> Maybe (Value, ByteString)
readValue ByteString
full_t
  | Right (ByteString
t', Int64
_, Value
v) <- ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, Value)
forall a.
Binary a =>
ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
decodeOrFail ByteString
full_t =
    (Value, ByteString) -> Maybe (Value, ByteString)
forall a. a -> Maybe a
Just (Value
v, ByteString -> ByteString
dropSpaces ByteString
t')
  -- Some nasty hackery where we take the ASCII prefix of the
  -- bytestring, turn it into a Text, run the value parser, and
  -- prepend the remnant back.
  | Bool
otherwise = do
    let (ByteString
a, ByteString
b) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
LBS.span (\Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char -> Bool
isPrint Char
c) ByteString
full_t
    case Parsec Void Text (Value, Text)
-> String
-> Text
-> Either (ParseErrorBundle Text Void) (Value, Text)
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
MP.parse
      ((,) (Value -> Text -> (Value, Text))
-> ParsecT Void Text Identity Value
-> ParsecT Void Text Identity (Text -> (Value, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text () -> ParsecT Void Text Identity Value
parseValue Parsec Void Text ()
space ParsecT Void Text Identity (Text -> (Value, Text))
-> ParsecT Void Text Identity Text
-> Parsec Void Text (Value, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (State Text Void -> Text
forall s e. State s e -> s
MP.stateInput (State Text Void -> Text)
-> ParsecT Void Text Identity (State Text Void)
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity (State Text Void)
forall e s (m :: * -> *). MonadParsec e s m => m (State s e)
MP.getParserState))
      String
""
      (String -> Text
T.pack (ByteString -> String
LBS.unpack ByteString
a)) of
      Right (Value
v, Text
a') -> (Value, ByteString) -> Maybe (Value, ByteString)
forall a. a -> Maybe a
Just (Value
v, String -> ByteString
LBS.pack (Text -> String
T.unpack Text
a') ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
b)
      Either (ParseErrorBundle Text Void) (Value, Text)
_ -> Maybe (Value, ByteString)
forall a. Maybe a
Nothing
  where
    space :: Parsec Void Text ()
space = Parsec Void Text ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
MP.space Parsec Void Text () -> Parsec Void Text () -> Parsec Void Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Parsec Void Text ()] -> Parsec Void Text ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
MP.choice [ParsecT Void Text Identity Text
"--" ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity (Tokens Text)
restOfLine ParsecT Void Text Identity (Tokens Text)
-> Parsec Void Text () -> Parsec Void Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text ()
space, () -> Parsec Void Text ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()]
    restOfLine :: ParsecT Void Text Identity (Tokens Text)
restOfLine = Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
MP.takeWhileP Maybe String
forall a. Maybe a
Nothing (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') ParsecT Void Text Identity (Tokens Text)
-> Parsec Void Text () -> ParsecT Void Text Identity (Tokens Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* [Parsec Void Text ()] -> Parsec Void Text ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
MP.choice [ParsecT Void Text Identity (Tokens Text) -> Parsec Void Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
MP.eol, Parsec Void Text ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
MP.eof]

-- | Parse Futhark values from the given bytestring.
readValues :: LBS.ByteString -> Maybe [Value]
readValues :: ByteString -> Maybe [Value]
readValues = ByteString -> Maybe [Value]
readValues' (ByteString -> Maybe [Value])
-> (ByteString -> ByteString) -> ByteString -> Maybe [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
dropSpaces
  where
    readValues' :: ByteString -> Maybe [Value]
readValues' ByteString
t
      | ByteString -> Bool
LBS.null ByteString
t = [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just []
      | Bool
otherwise = do
        (Value
a, ByteString
t') <- ByteString -> Maybe (Value, ByteString)
readValue ByteString
t
        (Value
a Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:) ([Value] -> [Value]) -> Maybe [Value] -> Maybe [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe [Value]
readValues' ByteString
t'