module Database.Schema.Migrations.Filesystem.Parse
    ( migrationParser
    , parseDepsList
    , FieldName
    , Field
    , FieldSet
    )
where

import Data.Time.Clock ()
import Data.Maybe ( catMaybes )

import Text.ParserCombinators.Parsec

type FieldName = String
type Field = (FieldName, String)
type FieldSet = [Field]

-- |Parse a migration document and return a list of parsed fields and
-- a list of claimed dependencies.
migrationParser :: Parser [Field]
migrationParser = do
  result <- many (parseField <|> parseComment <|> parseEmptyLine)
  return $ catMaybes result

parseDepsList :: Parser [String]
parseDepsList =
    depsList <|> (many whitespace >> eol >> return [])
    where
      parseMID = many1 (alphaNum <|> oneOf "-._")
      separator = discard $ spaces >> many (newline >> spaces)
      depsList = do
        many whitespace
        first <- parseMID
        rest <- many $ try $ do
                   separator
                   parseMID
        eol
        return (first : rest)

discard :: Parser a -> Parser ()
discard = (>> return ())

eol :: Parser ()
eol = (discard newline) <|> (discard eof)

whitespace :: Parser Char
whitespace = oneOf " \t"

requiredWhitespace :: Parser String
requiredWhitespace = many1 whitespace

parseFieldName :: Parser FieldName
parseFieldName = many1 (alphaNum <|> char '-')

parseComment :: Parser (Maybe Field)
parseComment = do
  discard $ do
    many whitespace
    char '#'
    manyTill anyChar eol
  return Nothing

parseEmptyLine :: Parser (Maybe Field)
parseEmptyLine = newline >> return Nothing

parseField :: Parser (Maybe Field)
parseField = do
  name <- parseFieldName
  char ':'
  many whitespace
  rest <- manyTill anyChar eol
  otherLines <- otherContentLines
  let value = rest ++ (concat otherLines)
  return $ Just (name, value)

otherContentLines :: Parser [String]
otherContentLines =
    many $ try $ (discard newline >> return "") <|> do
      ws <- requiredWhitespace
      rest <- manyTill anyChar eol
      -- Retain leading whitespace and trailing newline
      return $ ws ++ rest ++ "\n"