path: root/Parser.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
module Parser where

import Control.Applicative
import Data.Char
import Control.Monad.Chronicle
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Foldable (asum)
import Data.These

import AST


-- Positions are zero-based in both dimensions
data PS = PS
    { psRefCol :: Int
    , psLine :: Int
    , psCol :: Int
    , psRest :: String }
  deriving (Show)

data Context = Context { ctxFile :: FilePath }
  deriving (Show)

type Parser = ReaderT Context (ChronicleT [ErrMsg] (State PS))

-- Positions are zero-based in both dimensions
data ErrMsg = ErrMsg { errFile :: FilePath
                     , errLine :: Int
                     , errCol :: Int
                     , errMsg :: String }
  deriving (Show)

printErrMsg :: ErrMsg -> String
printErrMsg (ErrMsg fp y x s) = fp ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) ++ ": " ++ s

parse :: FilePath -> String -> These [ErrMsg] (Program ())
parse = runParser pProgram

runParser :: Parser a -> FilePath -> String -> These [ErrMsg] a
runParser p fp source = 
    flip evalState (PS 0 0 0 source)
    . runChronicleT
    . flip runReaderT (Context fp)
    $ p
                            
pProgram :: Parser (Program ())
pProgram = do
    prog <- Program <$> many pFunDef
    skipWhiteComment
    assertEOF Error
    return prog

pFunDef :: Parser (FunDef ())
pFunDef = do
    skipWhiteComment
    mtypesig <- optional pStandaloneTypesig0
    _

pStandaloneTypesig0 :: Parser (Name, Type)
pStandaloneTypesig0 = do
    assertAtCol 0 Fatal "Expected top-level definition, found indented stuff"
    withRefCol 0 $ do
        name <- pIdentifier0 Lowercase
        inlineWhite
        string "::"
        ty <- pType
        return (name, ty)

pType :: Parser Type
pType = do
    ty1 <- pTypeApp
    asum [do inlineWhite
             string "->"
             ty2 <- pType
             return (TFun ty1 ty2)
         ,return ty1]

pTypeApp :: Parser Type
pTypeApp = many pTypeAtom >>= \case
    [] -> raise Error "Expected type" >> return (TTup [])
    [t] -> return t
    t:ts -> return (TApp t ts)

pTypeAtom :: Parser Type
pTypeAtom = pTypeParens <|> pTypeList <|> pTypeCon <|> pTypeVar
  where
    pTypeParens = do
        inlineWhite
        string "("
        asum [do inlineWhite
                 string ")"
                 return (TTup [])
             ,do ty1 <- pType
                 ty2s <- many $ do
                     inlineWhite
                     string ","
                     pType
                 inlineWhite
                 string ")"
                 case ty2s of
                   [] -> return ty1
                   _ -> return (TTup (ty1 : ty2s))]

    pTypeList = do
        inlineWhite
        string "["
        ty <- pType
        string "]"
        return (TList ty)

    pTypeCon = inlineWhite >> TCon <$> pIdentifier0 Uppercase
    pTypeVar = inlineWhite >> TVar <$> pIdentifier0 Lowercase

data Case = Uppercase | Lowercase
  deriving (Show)

-- | Consumes an identifier (word or parenthesised operator) at the current
-- position. The `var` production in Haskell2010.
-- var -> varid | "(" varsym ")"
pIdentifier0 :: Case -> Parser Name
pIdentifier0 cs = pAlphaName0 cs <|> pParens0 (pSymbol0 cs)

-- | Consumes a word-like name at the current position with the given case. The
-- `varid` production in Haskell2010 for 'Lowercase', `conid' for 'Uppercase'.
--
-- > varid -> (small {small | large | digit | "'"}) without reservedid
pAlphaName0 :: Case -> Parser Name
pAlphaName0 cs = do
    (_, s) <- readInline (\case True -> \case Just c | isInitNameChar c -> Just (Right False)
                                              _ -> Nothing
                                False -> \case Just c | isNameContChar c -> Just (Right False)
                                               _ -> Just (Left ()))
                         True
    name <- case cs of
      Uppercase | isLower (head s) -> do
          raise Error "Unexpected uppercase word at this position, assuming typo"
          return (toUpper (head s) : tail s)
      Lowercase | isUpper (head s) -> do
          raise Error "Unexpected lowercase word at this position, assuming typo"
          return (toLower (head s) : tail s)
      _ -> return s
    guard (name `notElem` ["case", "class", "data", "default", "deriving", "do", "else"
                          ,"foreign", "if", "import", "in", "infix", "infixl"
                          ,"infixr", "instance", "let", "module", "newtype", "of"
                          ,"then", "type", "where", "_"])
    return (Name name)
  where
    isInitNameChar, isNameContChar :: Char -> Bool
    isInitNameChar c = isLetter c || c == '_'
    isNameContChar c = isInitNameChar c || isDigit c || c == '\''

-- | Consumes a symbol at the current position. The `varsym` production in
-- Haskell2010 for 'Lowercase', `consym` otherwise.
--
-- > varsym -> ((symbol without ":") {symbol}) without (reservedop | dashes)
-- > consym -> (":" {symbol}) without reservedop
-- > symbol -> ascSymbol | uniSymbol without (special | "_" | "\"" | "'")
-- > ascSymbol -> ```!#$%&⋆+./<=>?@^|-~:```
-- > uniSymbol -> unicode symbol or punctuation
-- > dashes -> "--" {"-"}
-- > special -> ```(),;[]`{}```
-- > reservedop -> ".." | ":" | "::" | "=" | "\" | "|" | "<-" | "->" | "@" | "~" | "=>"
pSymbol0 :: Case -> Parser Name
pSymbol0 cs = do
    let isSpecialExt c = c `elem` "(),;[]`{}_\"'"
        isAscSymbol c = c `elem` "!#$%&⋆+./<=>?@^|-~:"
        isUniSymbol c = isSymbol c || isPunctuation c
        isSymbolChar c = (isAscSymbol c || isUniSymbol c) && not (isSpecialExt c)
    name <- (:) <$> (case cs of Lowercase -> satisfy (\c -> isSymbolChar c && c /= ':')
                                Uppercase -> satisfy (== ':'))
                <*> many (satisfy isSymbolChar)
    guard (name `notElem` ["..", ":", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"])
    guard (take 2 name /= "--")
    return (Name name)

-- | Parser between parens, with the opening paren at the current position.
-- Enforces that all components are within the current indented block.
pParens0 :: Parser a -> Parser a
pParens0 p = do
    string "("
    skipWhiteComment
    assertWithinBlock Error "Unexpected dedent after opening parenthesis"
    res <- p
    assertWithinBlock Error "Unexpected dedent in parenthesised expression"
    skipWhiteComment
    assertWithinBlock Error "Unexpected dedent in parenthesised expression"
    string ")"
    return res


-- | Run a parser under a modified psRefCol. The current psRefCol is reinstated
-- after completion of this parser.
withRefCol :: Int -> Parser a -> Parser a
withRefCol refcol p = do
    old <- gets psRefCol
    modify (\ps -> ps { psRefCol = refcol })
    res <- p
    modify (\ps -> ps { psRefCol = old })
    return res

data Fatality = Error | Fatal
  deriving (Show)

-- | Raise an error with the given fatality and description.
raise :: Fatality -> String -> Parser ()
raise fat msg = do
    fp <- asks ctxFile
    ps <- get
    let fun = case fat of
                Error -> dictate . pure
                Fatal -> confess . pure
    fun (ErrMsg fp (psLine ps) (psCol ps) msg)

-- | Raises an error if we're not currently at the given column.
assertAtCol :: Int -> Fatality -> String -> Parser ()
assertAtCol col fat msg = gets psCol >>= \col' ->
    when (col' /= col) $ raise fat msg

-- | Raises an error if psCol is not greater than psRefCol.
assertWithinBlock :: Fatality -> String -> Parser ()
assertWithinBlock fat msg = get >>= \ps ->
    when (psCol ps <= psRefCol ps) $ raise fat msg

-- | Raises an error if we're not currently at EOF.
assertEOF :: Fatality -> Parser ()
assertEOF fat = gets psRest >>= \case
    [] -> return ()
    _ -> raise fat "Unexpected stuff"

-- | Consumes an inline token at the current position, asserting that psCol >
-- psRefCol at the start. The token is defined by a pure stateful parser.
-- If encountering a newline or EOF, the parser is run on this character
-- ('Nothing' for EOF); if this produces a result, the result is returned;
-- otherwise, the parser fails.
readInline :: (s -> Maybe Char -> Maybe (Either r s)) -> s -> Parser (r, String)
readInline f s0 = do
    ps0 <- get
    when (psCol ps0 <= psRefCol ps0) $
        raise Fatal "Expected stuff, but found end of indented expression"
    let loop :: (s -> Maybe Char -> Maybe (Either r s)) -> s -> Parser (r, String)
        loop f' st = do
            ps <- get
            case psRest ps of
              []       | Just (Left res) <- f' st Nothing     -> return (res, "")
                       | otherwise -> empty
              '\n' : _ | Just (Left res) <- f' st (Just '\n') -> return (res, "")
              c : cs -> case f' st (Just c) of
                          Nothing -> empty
                          Just (Left res) -> return (res, "")
                          Just (Right st') -> do
                              put (ps { psCol = psCol ps + 1, psRest = cs })
                              fmap (c :) <$> loop f' st'
    loop f s0

-- | Consumes all whitespace and comments (including newlines), but only if
-- this then leaves psCol > psRefCol. If not, this fails.
inlineWhite :: Parser ()
inlineWhite = do
    skipWhiteComment
    ps <- get
    when (psCol ps <= psRefCol ps) empty

-- | Consumes all whitespace and comments (including newlines). Note: this may
-- leave psCol <= psRefCol.
skipWhiteComment :: Parser ()
skipWhiteComment = do
    inlineSpaces
    _ <- many (inlineComment >> inlineSpaces)
    _ <- optional lineComment
    (consumeNewline >> skipWhiteComment) <|> return ()

-- | Consumes some inline whitespace.
inlineSpaces :: Parser ()
inlineSpaces = readWhileInline isSpace

-- | Consumes an inline comment including both end markers. Note: this may
-- leave psCol < psRefCol.
inlineComment :: Parser ()
inlineComment = do
    string "{-"
    let loop = do
            readWhileInline (`notElem` "{-")
            asum [string "-}"
                 ,inlineComment >> loop
                 ,consumeNewline >> loop]
    loop

-- | Consumes a line comment marker and the rest of the line, excluding
-- newline.
lineComment :: Parser ()
lineComment = string "--" >> readWhileInline (const True)

-- | Consumes characters while the predicate holds or until (and excluding)
-- a newline, whichever comes first.
readWhileInline :: (Char -> Bool) -> Parser ()
readWhileInline p = do
    (taken, rest) <- span (\c -> p c && c /= '\n') <$> gets psRest
    modify (\ps -> ps { psCol = psCol ps + length taken
                      , psRest = rest })

-- | Consumes exactly one newline at the current position.
consumeNewline :: Parser ()
consumeNewline = gets psRest >>= \case
    '\n' : rest -> modify (\ps -> ps { psLine = psLine ps + 1
                                     , psCol = 0
                                     , psRest = rest })
    _ -> empty

-- | Consumes exactly one character, unequal to newline, at the current position.
satisfy :: (Char -> Bool) -> Parser Char
satisfy p = gets psRest >>= \case
    c : rest | c /= '\n', p c -> do
        modify (\ps -> ps { psCol = psCol ps + 1
                          , psRest = rest })
        return c
    _ -> empty

-- | Consumes exactly this string at the current position. The string must not
-- contain a newline.
string :: String -> Parser ()
string s | any (== '\n') s = error "Newline in 'string' argument"
string s = do
    ps <- get
    if take (length s) (psRest ps) == s
        then put (ps { psCol = psCol ps + length s
                     , psRest = drop (length s) (psRest ps) })
        else empty