module Database.Mallard.Parser
( ParserException (..)
, Action (..)
, parseActions
, parseMigration
, parseTest
) where
import Control.Exception hiding (try)
import Control.Monad
import Crypto.Hash
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as Map
import qualified Data.List.NonEmpty as NonEmpty
import Data.String.Interpolation
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Void
import Database.Mallard.Types
import Path
import Text.Megaparsec hiding (parseTest)
import Text.Megaparsec.Char hiding (tab)
import qualified Text.Megaparsec.Char.Lexer as L
data Action
= ActionMigration Migration
| ActionTest Test
type Description = Text
type Requires = MigrationId
data FieldValue
= TextField Text
| ListField [Text]
type Parser = Parsec Void Text
spaceConsumer :: Parser ()
spaceConsumer = L.space space' (L.skipLineComment "@") (L.skipBlockComment "@@" "@@")
where
space' = void (try spaceChar <|> char '-')
symbol :: Text -> Parser Text
symbol = L.symbol spaceConsumer
symbol' :: Text -> Parser Text
symbol' = L.symbol' spaceConsumer
brackets :: Parser a -> Parser a
brackets = between (symbol "[") (symbol "]")
comma :: Parser Text
comma = symbol ","
colon :: Parser Text
colon = symbol ":"
semiColon :: Parser Text
semiColon = symbol ";"
migrationS :: Parser Text
migrationS = symbol' "migration"
testS :: Parser Text
testS = symbol' "test"
sbang :: Parser Text
sbang = symbol "#!"
sbangOrEof :: Parser ()
sbangOrEof = try (void sbang) <|> eof
atom :: Parser String
atom = do
val <- many alphaNumChar
spaceConsumer
return val
parseActions :: Parser [Action]
parseActions = spaceConsumer >> sbang >> manyTill parseAction eof
where
parseAction =
try (ActionMigration <$> parseMigration)
<|> (ActionTest <$> parseTest)
parseTest :: Parser Test
parseTest = do
(name, description) <- parseTestHeader
content <- T.pack <$> manyTill anyChar sbangOrEof
return $ Test
{ _testName = name
, _testDescription = description
, _testScript = content
}
parseTestHeader :: Parser (TestId, Description)
parseTestHeader = do
testS
fields <- parseHeaderFields
semiColon
case Map.lookup "name" fields of
Nothing -> fail "The name field was not provided in the header."
Just (ListField _) -> fail "The name field cannot be a list."
Just (TextField name) ->
case Map.lookup "description" fields of
Nothing -> fail "The description field was not provided in the header."
Just (ListField _) -> fail "The description field cannot be a list."
Just (TextField description) -> return (TestId name, description)
parseMigration :: Parser Migration
parseMigration = do
(name, description, requires) <- parseMigrationHeader
content <- T.pack <$> manyTill anyChar sbangOrEof
return $ Migration
{ _migrationName = name
, _migrationDescription = description
, _migrationRequires = requires
, _migrationChecksum = hash (T.encodeUtf8 content)
, _migrationScript = content
}
parseMigrationHeader :: Parser (MigrationId, Description, [Requires])
parseMigrationHeader = do
migrationS
fields <- parseHeaderFields
semiColon
case Map.lookup "name" fields of
Nothing -> fail "The name field was not provided in the header."
Just (ListField _) -> fail "The name field cannot be a list."
Just (TextField name) ->
case Map.lookup "description" fields of
Nothing -> fail "The description field was not provided in the header."
Just (ListField _) -> fail "The description field cannot be a list."
Just (TextField description) ->
case Map.lookup "requires" fields of
Nothing -> return (MigrationId name, description, [])
Just (TextField requires) -> return (MigrationId name, description, [MigrationId requires])
Just (ListField requires) -> return (MigrationId name, description, fmap MigrationId requires)
parseFieldValue :: Parser FieldValue
parseFieldValue = parseTextValue <|> parseListValue
where
parseTextValue = TextField <$> parseQuotedText
parseListValue = ListField <$> brackets (parseQuotedText `sepBy` comma)
parseHeaderFields :: Parser (HashMap Text FieldValue)
parseHeaderFields = Map.fromList <$> field `sepBy` comma
where
field :: Parser (Text, FieldValue)
field = do
name <- atom
colon
value <- parseFieldValue
return (T.pack name, value)
parseQuotedText :: Parser Text
parseQuotedText = T.pack <$> between (symbol "\"") (symbol "\"") (many (noneOf ("\""::String)))
data ParserException
= ParserException
{ _peFile :: (Path Abs File)
, _peError :: ParseError Char Void
}
deriving (Show)
instance Exception ParserException where
displayException e = [str|
Unable to parse file: $:toFilePath (_peFile e)$
$tab$Line: $:sourceLine (NonEmpty.head (errorPos (_peError e)))$
$tab$Column: $:sourceColumn (NonEmpty.head (errorPos (_peError e)))$
$tab$Item: $:_peError e$
|]