{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Axel.Parse
( module Axel.Parse
, module Axel.Parse.AST
) where
import Axel.Error (Error(ParseError), fatal)
import Axel.Haskell.Language (haskellOperatorSymbols, haskellSyntaxSymbols)
import Axel.Parse.AST
( Expression(LiteralChar, LiteralInt, LiteralString, SExpression,
Symbol)
)
import Axel.Utils.List (takeUntil)
import Axel.Utils.Recursion
( Recursive(bottomUpFmap, bottomUpTraverse, topDownFmap)
)
import Control.Monad.Freer (Eff, Member)
import Control.Monad.Freer.Error (throwError)
import qualified Control.Monad.Freer.Error as Effs (Error)
import Data.Functor.Identity (Identity)
import Data.List ((\\))
import Text.Parsec (ParsecT, Stream, (<|>), eof, parse, try)
import Text.Parsec.Char (alphaNum, char, digit, noneOf, oneOf, space, string)
import Text.Parsec.Combinator (many1, optional)
import Text.Parsec.Language (haskellDef)
import Text.Parsec.Prim (many)
import Text.Parsec.Token (makeTokenParser, stringLiteral)
instance Recursive Expression where
bottomUpFmap :: (Expression -> Expression) -> Expression -> Expression
bottomUpFmap f x =
f $
case x of
LiteralChar _ -> x
LiteralInt _ -> x
LiteralString _ -> x
SExpression xs -> SExpression (map (bottomUpFmap f) xs)
Symbol _ -> x
bottomUpTraverse ::
(Monad m) => (Expression -> m Expression) -> Expression -> m Expression
bottomUpTraverse f x =
f =<<
case x of
LiteralChar _ -> pure x
LiteralInt _ -> pure x
LiteralString _ -> pure x
SExpression xs -> SExpression <$> traverse (bottomUpTraverse f) xs
Symbol _ -> pure x
topDownFmap :: (Expression -> Expression) -> Expression -> Expression
topDownFmap f x =
case f x of
LiteralChar _ -> x
LiteralInt _ -> x
LiteralString _ -> x
SExpression xs -> SExpression (map (topDownFmap f) xs)
Symbol _ -> x
parseReadMacro :: String -> String -> ParsecT String u Identity Expression
parseReadMacro prefix wrapper = applyWrapper <$> (string prefix *> expression)
where
applyWrapper x = SExpression [Symbol wrapper, x]
any' :: (Stream s m Char) => ParsecT s u m Char
any' = noneOf ""
whitespace :: (Stream s m Char) => ParsecT s u m String
whitespace = many space
literalChar :: (Stream s m Char) => ParsecT s u m Expression
literalChar = LiteralChar <$> (string "#\\" *> any')
literalInt :: (Stream s m Char) => ParsecT s u m Expression
literalInt = LiteralInt . read <$> many1 digit
literalList :: ParsecT String u Identity Expression
literalList =
SExpression . (Symbol "list" :) <$> (char '[' *> many item <* char ']')
where
item = try (whitespace *> expression) <|> expression
literalString :: ParsecT String u Identity Expression
literalString = LiteralString <$> stringLiteral (makeTokenParser haskellDef)
quasiquotedExpression :: ParsecT String u Identity Expression
quasiquotedExpression = parseReadMacro "`" "quasiquote"
quotedExpression :: ParsecT String u Identity Expression
quotedExpression = parseReadMacro "'" "quote"
sExpressionItem :: ParsecT String u Identity Expression
sExpressionItem = try (whitespace *> expression) <|> expression
sExpression :: ParsecT String u Identity Expression
sExpression = SExpression <$> (char '(' *> many sExpressionItem <* char ')')
infixSExpression :: ParsecT String u Identity Expression
infixSExpression =
SExpression . (Symbol "applyInfix" :) <$>
(char '{' *> many sExpressionItem <* char '}')
spliceUnquotedExpression :: ParsecT String u Identity Expression
spliceUnquotedExpression = parseReadMacro "~@" "unquoteSplicing"
symbol :: (Stream s Identity Char) => ParsecT s u Identity Expression
symbol =
Symbol <$>
many1
(alphaNum <|> oneOf "'_" <|>
oneOf (map fst haskellSyntaxSymbols \\ syntaxSymbols) <|>
oneOf (map fst haskellOperatorSymbols))
unquotedExpression :: ParsecT String u Identity Expression
unquotedExpression = parseReadMacro "~" "unquote"
expression :: ParsecT String u Identity Expression
expression =
literalChar <|> literalInt <|> literalList <|> literalString <|>
quotedExpression <|>
quasiquotedExpression <|>
try spliceUnquotedExpression <|>
unquotedExpression <|>
sExpression <|>
infixSExpression <|>
symbol
quoteParseExpression :: Expression -> Expression
quoteParseExpression (LiteralChar x) =
SExpression [Symbol "AST.LiteralChar", LiteralChar x]
quoteParseExpression (LiteralInt x) =
SExpression [Symbol "AST.LiteralInt", LiteralInt x]
quoteParseExpression (LiteralString x) =
SExpression [Symbol "AST.LiteralString", LiteralString x]
quoteParseExpression (SExpression xs) =
SExpression
[ Symbol "AST.SExpression"
, SExpression (Symbol "list" : map quoteParseExpression xs)
]
quoteParseExpression (Symbol x) =
SExpression [Symbol "AST.Symbol", LiteralString (handleEscapes x)]
where
handleEscapes =
concatMap $ \case
'\\' -> "\\\\"
c -> [c]
parseMultiple ::
(Member (Effs.Error Error) effs) => String -> Eff effs [Expression]
parseMultiple =
either (throwError . ParseError . show) (pure . map expandQuotes) .
parse
(many1 (optional whitespace *> expression <* optional whitespace) <* eof)
""
where
expandQuotes =
topDownFmap
(\case
SExpression [Symbol "quote", x] -> quoteParseExpression x
x -> x)
parseSingle :: (Member (Effs.Error Error) effs) => String -> Eff effs Expression
parseSingle input =
parseMultiple input >>= \case
[x] -> pure x
_ -> throwError $ ParseError "Only one expression was expected"
stripComments :: String -> String
stripComments = unlines . map cleanLine . lines
where
cleanLine = takeUntil "--"
parseSource :: (Member (Effs.Error Error) effs) => String -> Eff effs Expression
parseSource input = do
statements <- parseMultiple $ stripComments input
pure $ SExpression (Symbol "begin" : statements)
programToTopLevelExpressions :: Expression -> [Expression]
programToTopLevelExpressions (SExpression (Symbol "begin":stmts)) = stmts
programToTopLevelExpressions _ = fatal "programToTopLevelExpressions" "0001"
topLevelExpressionsToProgram :: [Expression] -> Expression
topLevelExpressionsToProgram stmts = SExpression (Symbol "begin" : stmts)
syntaxSymbols :: String
syntaxSymbols = "()[]{}"