path: root/src/Language/SimpleShell/Parser/Expr.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}

module Language.SimpleShell.Parser.Expr
  ( ExprParser
  , ExprContext(..)
  , exprP
  , strongTermP
  , strongTermP0_
  )
where


import Language.SimpleShell.AST.Expr (Expr(..), TypedExpr)
import Language.SimpleShell.AST.Name (FunName, VarName)
import Language.SimpleShell.AST.SimpleType (SimpleType(..), FunSig)
import Language.SimpleShell.Parser.Common.Lexeme
  ( lexeme
  , symbol
  , commentFirstChars
  )
import Language.SimpleShell.Parser.Common.Root (RootParser)
import Language.SimpleShell.Parser.Name (nameP, keyword)
import Language.SimpleShell.Parser.SimpleType (forceType)
import Control.Monad.Combinators.FailExpr
  ( Associativity(..)
  , makeExprParser
  , Operator(..)
  )

import Control.Applicative ((<|>))
import Control.Monad (void)
import Control.Monad.Reader (ask, ReaderT)
import Control.Monad.Combinators (manyTill)
import Data.Foldable (asum)
import Data.Map (Map)
import qualified Data.Map as Map (lookup)
import Data.Text (Text, unpack)
import Text.Megaparsec (MonadParsec, takeWhile1P, oneOf, many)
import Text.Megaparsec.Char (char)
import qualified Text.Megaparsec.Char.Lexer as L (charLiteral, decimal)


type ExprParser0 = RootParser
type ExprParser = ReaderT ExprContext RootParser


data ExprContext = ExprContext
  { ctxFuns :: Map FunName FunSig
  , ctxVars :: Map VarName SimpleType
  }


lookupVar :: VarName -> ExprParser SimpleType
lookupVar varname = do
  mt <- Map.lookup varname . ctxVars <$> ask
  case mt of
    Just t  -> return t
    Nothing -> fail $ "Undeclared variable $" ++ unpack varname

lookupFun :: FunName -> ExprParser FunSig
lookupFun fname = do
  msig <- Map.lookup fname . ctxFuns <$> ask
  case msig of
    Just sig -> return sig
    Nothing  -> fail $ "Undefined function " ++ unpack fname


exprP :: ExprParser TypedExpr
exprP
   =  makeExprParser weakTermP binaryOperatorTable

weakTermP :: ExprParser TypedExpr
weakTermP
   =  strongTermP
  <|> unaryOpP
  <|> builtinUnaryFunP
  <|> funP

strongTermP :: ExprParser TypedExpr
strongTermP
   =  literalP
  <|> varP
  <|> symbol "(" *> exprP <* symbol ")"

-- | Parse a strong term--assuming its correctness--without yielding a result.
--   This basically only checks for matching parentheses.
strongTermP0_ :: ExprParser0 ()
strongTermP0_
   =  void literalP
  <|> varP0_
  <|> symbol "(" *> void (many tok) <* symbol ")"
  where
    -- Notes:
    --  * We need to make sure to correctly handle:
    --    * parentheses
    --    * string literals
    --    * comments

    tok :: ExprParser0 ()
    tok
       =  void strLitP
      <|> symbol "(" *> void (many tok) <* symbol ")"
      <|> void (lexeme $ takeWhile1P Nothing isBoring)
      <|> void (lexeme $ oneOf commentFirstChars)
      where
        isBoring :: Char -> Bool
        isBoring = not . (`elem` "()\"" ++ commentFirstChars)


-- | Parse strong term with fixed type.
strongTermP' :: String -> SimpleType -> ExprParser Expr
strongTermP' errMsg t = forceType t strongTermP <|> fail errMsg


literalP :: (MonadParsec e Text m) => m TypedExpr
literalP
   =  (IntType,)  . IntLiteral  <$> lexeme L.decimal
  <|> (StrType,)  . StrLiteral  <$> strLitP
  <|> (BoolType,) . BoolLiteral <$> boolLitP
  where
    boolLitP
       =  True  <$ keyword "true"
      <|> False <$ keyword "false"

strLitP :: (MonadParsec e Text m) => m String
strLitP = lexeme $ char '"' *> manyTill L.charLiteral (char '"')

varP :: ExprParser TypedExpr
varP = do
  _ <- char '$'
  x <- nameP
  t <- lookupVar x
  return (t, Var x)

varP0_ :: ExprParser0 ()
varP0_ = void (char '$') <* nameP

funP :: ExprParser TypedExpr
funP = do
  fname <- nameP
  (t', ts) <- lookupFun fname
  args <- mapM (strongTermP' "Type mismatch with function signature.") ts
  return (t', FunCall fname args)


-- Binary operators.

type BinaryFun = Expr -> Expr -> Expr
type BinarySig = SimpleType -> SimpleType -> Maybe SimpleType

binaryOperatorTable :: [[Operator ExprParser TypedExpr]]
binaryOperatorTable =
  [ [ binary AssocR "||" Or  $ sameSig BoolType
    ]
  , [ binary AssocR "&&" And $ sameSig BoolType
    ]
  , [ binary AssocN "==" Eq  $ anyCmpSig
    , binary AssocN "!=" Neq $ anyCmpSig
    , binary AssocN "<=" Le  $ intCmpSig
    , binary AssocN "<"  Lt  $ intCmpSig
    , binary AssocN ">=" Ge  $ intCmpSig
    , binary AssocN ">"  Gt  $ intCmpSig
    ]
  , [ Binary AssocL addP
    , binary AssocL "-"  Sub $ sameSig IntType
    ]
  , [ binary AssocL "*"  Mul $ sameSig IntType
    , binary AssocL "/"  Div $ sameSig IntType
    ]
  ]
  where
    sameSig :: SimpleType -> BinarySig
    sameSig t t1 t2 = if t == t1 && t == t2 then Just t else Nothing

    anyCmpSig t t'
      | t == t'   = Just BoolType
      | otherwise = Nothing

    intCmpSig IntType IntType = Just BoolType
    intCmpSig _       _       = Nothing

    addP :: ExprParser (TypedExpr -> TypedExpr -> Maybe TypedExpr)
    addP = do
      symbol "+"
      return $ \(t1, x1) (t2, x2) ->
        if t1 == t2
        then
          case t1 of
            StrType -> Just (StrType, Concat x1 x2)
            IntType -> Just (IntType, Add    x1 x2)
            _       -> Nothing
        else Nothing

    binary
      :: Associativity -> Text -> BinaryFun -> BinarySig
      -> Operator ExprParser TypedExpr
    binary assoc symb op sig = Binary assoc $ do
      symbol symb
      return $ \(t1, e1) (t2, e2) -> fmap (, op e1 e2) $ sig t1 t2


-- Unary operators and builtin unary functions.

type UnaryFun = Expr -> Expr
type UnarySig = SimpleType -> Maybe SimpleType
type UnaryParser = ExprParser (TypedExpr -> Maybe TypedExpr)

unaryOperators, builtinUnaryFuns :: [UnaryParser]
(unaryOperators, builtinUnaryFuns) =
  ( [ unaryOp  "!"      Not     $ uniqueSig BoolType BoolType
    , unaryOp  "-"      UMinus  $ uniqueSig IntType  IntType
    ]
  , [ unaryFun "length" Length  $ uniqueSig StrType  IntType
    , unaryFun "int"    IntCast $ uniqueSig StrType  IntType
    , unaryFun "str"    StrCast $ uniqueSig IntType  StrType
    ]
  )
  where
    uniqueSig :: SimpleType -> SimpleType -> UnarySig
    uniqueSig t1 t2 t1'
      | t1 == t1' = Just t2
      | otherwise = Nothing

    unaryOp :: Text -> UnaryFun -> UnarySig -> UnaryParser
    unaryOp = unary symbol

    unaryFun :: Text -> UnaryFun -> UnarySig -> UnaryParser
    unaryFun = unary keyword

    unary
      :: (Text -> ExprParser ()) -> Text -> UnaryFun -> UnarySig -> UnaryParser
    unary symbPF symb op sig = do
      symbPF symb
      return $ \(t, e) -> fmap (, op e) $ sig t

unaryOpP, builtinUnaryFunP :: ExprParser TypedExpr
(unaryOpP, builtinUnaryFunP) =
  ( asum $ map (aux "unary operator"         weakTermP  ) unaryOperators
  , asum $ map (aux "builtin unary function" strongTermP) builtinUnaryFuns
  )
  where
    aux
      :: String -> ExprParser TypedExpr -> UnaryParser -> ExprParser TypedExpr
    aux desc argP p = do
      f <- p
      x <- argP
      case f x of
        Just x' -> return x'
        Nothing -> fail $ "Mismatching " ++ desc ++ " signature."