{-# language CPP #-}
module SitePipe.Parse
( processSource
) where
import Control.Monad.Catch hiding (try)
import Text.Megaparsec
import Data.Aeson
import qualified Data.HashMap.Lazy as HM
import Data.Yaml hiding (Parser)
import SitePipe.Types
import Data.ByteString.Char8 (pack)
import Data.Maybe
#if MIN_VERSION_megaparsec(6,0,0)
import Text.Megaparsec.Char
import Data.Void
type Parser = Parsec Void String
#else
import Text.Megaparsec.String
#endif
resourceP :: Parser (String, String)
resourceP :: Parser (String, String)
resourceP = do
String
yaml <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String)
-> ParsecT Void String Identity (Maybe String)
-> ParsecT Void String Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity String
-> ParsecT Void String Identity (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void String Identity String
yamlParser
ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
String
rest <- ParsecT Void String Identity Char
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill ParsecT Void String Identity Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle ParsecT Void String Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
(String, String) -> Parser (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
yaml, String
rest)
splitMeta :: MonadThrow m => String -> String -> m (String, String)
splitMeta :: String -> String -> m (String, String)
splitMeta String
ident String
str =
case Parser (String, String)
-> String
-> String
-> Either (ParseErrorBundle String Void) (String, String)
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parser (String, String)
resourceP String
ident String
str of
Left ParseErrorBundle String Void
err -> SitePipeError -> m (String, String)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ParseErrorBundle String Void -> SitePipeError
MParseErr ParseErrorBundle String Void
err)
Right (String, String)
res -> (String, String) -> m (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String, String)
res
yamlParser :: Parser String
yamlParser :: ParsecT Void String Identity String
yamlParser = do
String
_ <- ParsecT Void String Identity String
yamlSep
ParsecT Void String Identity Char
-> ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill ParsecT Void String Identity Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle (ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void String Identity String
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol ParsecT Void String Identity String
-> ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Void String Identity String
yamlSep))
where
yamlSep :: ParsecT Void String Identity String
yamlSep = Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string String
Tokens String
"---" ParsecT Void String Identity String
-> ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Void String Identity String
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
decodeMeta :: MonadThrow m => String -> String -> m Value
decodeMeta :: String -> String -> m Value
decodeMeta String
ident String
metaBlock =
case ByteString -> Either ParseException Value
forall a. FromJSON a => ByteString -> Either ParseException a
decodeEither' (String -> ByteString
pack String
metaBlock) of
Left ParseException
err -> SitePipeError -> m Value
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (String -> String -> SitePipeError
YamlErr String
ident (ParseException -> String
forall a. Show a => a -> String
show ParseException
err))
Right (Object Object
metaObj) -> Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Value
Object Object
metaObj)
Right Value
Null -> Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Value
Object Object
forall k v. HashMap k v
HM.empty)
Right Value
_ -> SitePipeError -> m Value
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (String -> String -> SitePipeError
YamlErr String
ident String
"Top level yaml must be key-value pairs")
processSource :: MonadThrow m => String -> String -> m (Value, String)
processSource :: String -> String -> m (Value, String)
processSource String
ident String
source = do
(String
metaBlock, String
contents) <- String -> String -> m (String, String)
forall (m :: * -> *).
MonadThrow m =>
String -> String -> m (String, String)
splitMeta String
ident String
source
Value
metaObj <- String -> String -> m Value
forall (m :: * -> *). MonadThrow m => String -> String -> m Value
decodeMeta String
ident String
metaBlock
(Value, String) -> m (Value, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
metaObj, String
contents)