Delta-Lambda-0.3.0.0: source/Parser.hs

module Parser where

import           Control.Applicative
import           Control.Monad.Except
import           Data.Text                   (Text)
import           Data.Text                   (pack, unpack)
import           Data.Word                   (Word64)

import           Language.Preprocessor.Cpphs
import           Text.Megaparsec             hiding (space)
import qualified Text.Megaparsec.Lexer       as Lexer
import           Text.Megaparsec.Text

import           AST

lineComment, blockComment, spaceToken :: Parser ()
lineComment = Lexer.skipLineComment "--" <|> Lexer.skipLineComment "#"

blockComment = Lexer.skipBlockComment "{-" "-}"

spaceToken = Lexer.space (void spaceChar) lineComment blockComment

lexeme :: Parser a -> Parser a
lexeme = Lexer.lexeme spaceToken

symbol :: String -> Parser String
symbol = Lexer.symbol spaceToken

variableToken :: Parser Text
variableToken = lexeme =<<
                return . pack <$> ((:) <$> (letterChar <|> Text.Megaparsec.char '$')
                                       <*> many alphaNumChar)

commaToken, colonToken, typeToken :: Parser ()
commaToken = void (symbol ",")

colonToken = void (symbol ":")

typeToken = void (symbol "type")

parensToken, bracketsToken :: Parser a -> Parser a
parensToken = between (symbol "(") (symbol ")")

bracketsToken = between (symbol "[") (symbol "]")

vector :: Parser [Term SourcePos Text Word64]
vector = sepBy1 term commaToken

telescope :: Parser [([(Text, SourcePos)], Term SourcePos Text Word64)]
telescope = sepBy1
              ((,) <$> sepBy ((,) <$> variableToken <*> getPosition) commaToken
                   <*> (colonToken >> term))
              commaToken

term :: Parser (Term SourcePos Text Word64)
term = (Type <$> (typeToken >> getPosition) <?> "type")
       <|> try (Variable <$> variableToken <*> return 0 <*> getPosition <?> "variable")
       <|> (apply <$> parensToken vector <*> term <?> "application")
       <|> (funct <$> bracketsToken telescope <*> term <?> "abstraction")

apply :: [Term SourcePos v i] -> Term SourcePos v i -> Term SourcePos v i
apply = flip $ foldl (\f a -> Application (getNodeMetadata (Term a)) a f)

funct :: [([(Text, SourcePos)], Term SourcePos Text Word64)] -> Term SourcePos Text Word64 -> Term SourcePos Text Word64
funct = flip $ foldr $ \(ns, typ) bod ->
  foldr (\(n, p) -> Abstraction n p typ . bindTerm n 1) bod ns

parseString :: String -> Text -> Either String (Term SourcePos Text Word64)
parseString filename' input =
  case parse term filename' input of
    Left err  -> Left $ show err
    Right val -> Right val

parseInput :: Text -> Either String (Term SourcePos Text Word64)
parseInput = parseString "stdin"

preprocessor :: [String] -> FilePath -> Text -> IO (Either String Text)
preprocessor options filename fileContents =
  case Language.Preprocessor.Cpphs.parseOptions options of
    Left err -> return $ Left err
    Right cpphsOpts -> do
      fileContents' <- runCpphs cpphsOpts filename (unpack fileContents)
      return $ Right $ pack fileContents'