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 Database.Mallard.Types
import Path
import Text.Megaparsec hiding (parseTest, tab)
import Text.Megaparsec.ByteString
import qualified Text.Megaparsec.Lexer as L
data Action
= ActionMigration Migration
| ActionTest Test
type Description = Text
type Requires = MigrationId
data FieldValue
= TextField Text
| ListField [Text]
spaceConsumer :: Parser ()
spaceConsumer = L.space space' (L.skipLineComment "@") (L.skipBlockComment "@@" "@@")
where
space' = void (try spaceChar <|> char '-')
symbol :: String -> Parser String
symbol = L.symbol spaceConsumer
symbol' :: String -> Parser String
symbol' = L.symbol' spaceConsumer
brackets :: Parser a -> Parser a
brackets = between (symbol "[") (symbol "]")
comma :: Parser String
comma = symbol ","
colon :: Parser String
colon = symbol ":"
semiColon :: Parser String
semiColon = symbol ";"
migrationS :: Parser String
migrationS = symbol' "migration"
testS :: Parser String
testS = symbol' "test"
sbang :: Parser String
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 Dec
}
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$Expected: $:errorExpected (_peError e)$
$tab$Occurred: $:errorUnexpected (_peError e)$
|]