ExprSrcSpan.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
import           Control.Monad
import           Data.Text (Text)
import           Data.Void
import           Text.Megaparsec
import qualified Text.Megaparsec.Char.Lexer as Lexer
import           Text.Megaparsec.Expr

type Parser = Parsec Void Text

sc :: Parser ()
sc = Lexer.space (void (takeWhile1P Nothing f)) lineComment empty
  where f x = x `elem` [' ', '\t']

lineComment :: Parser ()
lineComment = Lexer.skipLineComment "#"

symbol :: Text -> Parser Text
symbol = Lexer.symbol sc

parens :: Parser a -> Parser a
parens = between (symbol "(") (symbol ")")

data Type a = TyInt a | TyFun a (Type a) (Type a)
  deriving Show

data SrcSpan = SrcSpan SourcePos SourcePos Text
  deriving (Eq, Ord, Show)

withSrcSpan :: (SrcSpan -> Parser a) -> Parser a
withSrcSpan f = mdo
  spanStart <- getPosition
  (text, a) <- match (f (SrcSpan spanStart spanEnd text))
  spanEnd <- getPosition
  pure a

parseType :: Parser (Type SrcSpan)
parseType =
  withSrcSpan $ \srcSpan ->
    let term = choice [parens parseType, tyInt]
        table = [ [InfixR tyFun] ]
        tyFun = do
          _ <- symbol "->"
          -- Problem: This will always use the full SrcSpan even for nested TyFuns.
          pure (TyFun srcSpan)
    in makeExprParser term table
  where tyInt = withSrcSpan (\srcSpan -> TyInt srcSpan <$ symbol "Int")

main :: IO ()
main = do
  parseTest parseType "Int -> Int -> Int"