Procedure.hs

{- -----------------------------------------------------------------------------
Copyright 2019-2020 Kevin P. Barry

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
----------------------------------------------------------------------------- -}

-- Author: Kevin P. Barry [ta0kira@gmail.com]

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}

module Parser.Procedure (
) where

import qualified Data.Set as Set

import Base.CompilerError
import Base.Positional
import Parser.Common
import Parser.Pragma
import Parser.TextParser
import Parser.TypeCategory ()
import Parser.TypeInstance ()
import Types.Pragma
import Types.Procedure
import Types.TypeCategory


instance ParseFromSource (ExecutableProcedure SourceContext) where
  sourceParser = labeled "executable procedure" $ do
    c <- getSourceContext
    n <- try sourceParser
    as <- sourceParser
    rs <- sourceParser
    sepAfter (string_ "{")
    pragmas <- parsePragmas [pragmaNoTrace,pragmaTraceCreation]
    pp <- sourceParser
    c2 <- getSourceContext
    sepAfter (string_ "}")
    return $ ExecutableProcedure [c] pragmas [c2] n as rs pp

instance ParseFromSource (TestProcedure SourceContext) where
  sourceParser = labeled "test procedure" $ do
    c <- getSourceContext
    kwUnittest
    n <- try sourceParser
    sepAfter (string_ "{")
    pp <- sourceParser
    sepAfter (string_ "}")
    return $ TestProcedure [c] n pp

instance ParseFromSource (ArgValues SourceContext) where
  sourceParser = labeled "procedure arguments" $ do
    c <- getSourceContext
    as <- between (sepAfter $ string_ "(")
                  (sepAfter $ string_ ")")
                  (sepBy sourceParser (sepAfter $ string_ ","))
    return $ ArgValues [c] (Positional as)

instance ParseFromSource (ReturnValues SourceContext) where
  sourceParser = labeled "procedure returns" $ namedReturns <|> unnamedReturns where
    namedReturns = do
      c <- getSourceContext
      rs <- between (sepAfter $ string_ "(")
                    (sepAfter $ string_ ")")
                    (sepBy sourceParser (sepAfter $ string_ ","))
      return $ NamedReturns [c] (Positional rs)
    unnamedReturns = do
      c <- getSourceContext
      notFollowedBy (string_ "(")
      return $ UnnamedReturns [c]

instance ParseFromSource VariableName where
  sourceParser = labeled "variable name" $ do
    noKeywords
    b <- lowerChar
    e <- sepAfter $ many alphaNumChar
    return $ VariableName (b:e)

instance ParseFromSource (InputValue SourceContext) where
  sourceParser = labeled "input variable" $ variable <|> discard where
    variable = do
      c <- getSourceContext
      v <- sourceParser
      return $ InputValue [c] v
    discard = do
      c <- getSourceContext
      sepAfter (string_ "_")
      return $ DiscardInput [c]

instance ParseFromSource (OutputValue SourceContext) where
  sourceParser = labeled "output variable" $ do
    c <- getSourceContext
    v <- sourceParser
    return $ OutputValue [c] v

instance ParseFromSource (Procedure SourceContext) where
  sourceParser = labeled "procedure" $ do
    c <- getSourceContext
    rs <- sepBy sourceParser optionalSpace
    return $ Procedure [c] rs

instance ParseFromSource (Statement SourceContext) where
  sourceParser = parseReturn <|>
                 parseBreak <|>
                 parseContinue <|>
                 parseFailCall <|>
                 parseVoid <|>
                 parseAssign <|>
                 parseIgnore where
    parseAssign = labeled "statement" $ do
      c <- getSourceContext
      as <- sepBy sourceParser (sepAfter $ string_ ",")
      assignOperator
      e <- sourceParser
      statementEnd
      return $ Assignment [c] (Positional as) e
    parseBreak = labeled "break" $ do
      c <- getSourceContext
      kwBreak
      return $ LoopBreak [c]
    parseContinue = labeled "continue" $ do
      c <- getSourceContext
      kwContinue
      return $ LoopContinue [c]
    parseFailCall = do
      c <- getSourceContext
      kwFail
      e <- between (sepAfter $ string_ "(") (sepAfter $ string_ ")") sourceParser
      return $ FailCall [c] e
    parseIgnore = do
      c <- getSourceContext
      statementStart
      e <- sourceParser
      statementEnd
      return $ IgnoreValues [c] e
    parseReturn = labeled "return" $ do
      c <- getSourceContext
      kwReturn
      emptyReturn c <|> multiReturn c
    multiReturn :: SourceContext -> TextParser (Statement SourceContext)
    multiReturn c = do
      rs <- sepBy sourceParser (sepAfter $ string_ ",")
      statementEnd
      return $ ExplicitReturn [c] (Positional rs)
    emptyReturn :: SourceContext -> TextParser (Statement SourceContext)
    emptyReturn c = do
      kwIgnore
      statementEnd
      return $ EmptyReturn [c]
    parseVoid = do
      c <- getSourceContext
      e <- sourceParser
      return $ NoValueExpression [c] e

instance ParseFromSource (Assignable SourceContext) where
  sourceParser = existing <|> create where
    create = labeled "variable creation" $ do
      t <- sourceParser
      strayFuncCall <|> return ()
      c <- getSourceContext
      n <- sourceParser
      return $ CreateVariable [c] t n
    existing = labeled "variable name" $ do
      n <- sourceParser
      strayFuncCall <|> return ()
      return $ ExistingVariable n
    strayFuncCall = do
      valueSymbolGet <|> typeSymbolGet <|> categorySymbolGet
      compilerErrorM "function returns must be explicitly handled"

instance ParseFromSource (VoidExpression SourceContext) where
  sourceParser = conditional <|> loop <|> scoped where
    conditional = do
      e <- sourceParser
      return $ Conditional e
    loop = do
      e <- sourceParser
      return $ Loop e
    scoped = do
      e <- sourceParser
      return $ WithScope e

instance ParseFromSource (IfElifElse SourceContext) where
  sourceParser = labeled "if-elif-else" $ do
    c <- getSourceContext
    kwIf >> parseIf c
    where
      parseIf c = do
        i <- between (sepAfter $ string_ "(") (sepAfter $ string_ ")") sourceParser
        p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser
        next <- parseElif <|> parseElse <|> return TerminateConditional
        return $ IfStatement [c] i p next
      parseElif = do
        c <- getSourceContext
        kwElif >> parseIf c
      parseElse = do
        c <- getSourceContext
        kwElse
        p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser
        return $ ElseStatement [c] p

instance ParseFromSource (WhileLoop SourceContext) where
  sourceParser = labeled "while" $ do
    c <- getSourceContext
    kwWhile
    i <- between (sepAfter $ string_ "(") (sepAfter $ string_ ")") sourceParser
    p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser
    u <- fmap Just parseUpdate <|> return Nothing
    return $ WhileLoop [c] i p u
    where
      parseUpdate = do
        kwUpdate
        between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser

instance ParseFromSource (ScopedBlock SourceContext) where
  sourceParser = scoped <|> justCleanup where
    scoped = labeled "scoped" $ do
      c <- getSourceContext
      kwScoped
      p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser
      cl <- fmap Just parseCleanup <|> return Nothing
      kwIn
      c2 <- getSourceContext
      -- TODO: If there's a parse error in an otherwise-valid {} then the actual
      -- error might look like a multi-assignment issue.
      s <- unconditional <|> sourceParser
      return $ ScopedBlock [c] p cl [c2] s
    justCleanup = do
      c <- getSourceContext
      cl <- parseCleanup
      kwIn
      c2 <- getSourceContext
      s <- sourceParser <|> unconditional
      return $ ScopedBlock [c] (Procedure [] []) (Just cl) [c2] s
    parseCleanup = do
      kwCleanup
      between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser
    unconditional = do
      c <- getSourceContext
      p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser
      return $ NoValueExpression [c] (Unconditional p)

unaryOperator :: TextParser (Operator c)
unaryOperator = op >>= return . NamedOperator where
  op = labeled "unary operator" $ foldr (<|>) empty $ map (try . operator) ops
  ops = logicalUnary ++ arithUnary ++ bitwiseUnary

logicalUnary :: [String]
logicalUnary = ["!"]

arithUnary :: [String]
arithUnary = ["-"]

bitwiseUnary :: [String]
bitwiseUnary = ["~"]

infixOperator :: TextParser (Operator c)
infixOperator = op >>= return . NamedOperator where
  op = labeled "binary operator" $ foldr (<|>) empty $ map (try . operator) ops
  ops = compareInfix ++ logicalInfix ++ addInfix ++ subInfix ++ multInfix ++ bitwiseInfix ++ bitshiftInfix

compareInfix :: [String]
compareInfix = ["==","!=","<","<=",">",">="]

logicalInfix :: [String]
logicalInfix = ["&&","||"]

addInfix :: [String]
addInfix = ["+"]

subInfix :: [String]
subInfix = ["-"]

multInfix :: [String]
multInfix = ["*","/","%"]

bitwiseInfix :: [String]
bitwiseInfix = ["&","|","^"]

bitshiftInfix :: [String]
bitshiftInfix = [">>","<<"]

infixBefore :: Operator c -> Operator c -> Bool
infixBefore o1 o2 = (infixOrder o1 :: Int) <= (infixOrder o2 :: Int) where
  infixOrder (NamedOperator o)
    -- TODO: Don't hard-code this.
    | o `Set.member` Set.fromList (multInfix ++ bitshiftInfix) = 1
    | o `Set.member` Set.fromList (addInfix ++ subInfix ++ bitwiseInfix) = 2
    | o `Set.member` Set.fromList compareInfix = 4
    | o `Set.member` Set.fromList logicalInfix = 5
  infixOrder _ = 3

functionOperator :: TextParser (Operator SourceContext)
functionOperator = do
  c <- getSourceContext
  infixFuncStart
  q <- sourceParser
  infixFuncEnd
  return $ FunctionOperator [c] q

instance ParseFromSource (Expression SourceContext) where
  sourceParser = do
    e <- notInfix
    asInfix [e] [] <|> return e
    where
      notInfix = literal <|> unary <|> initalize <|> expression
      asInfix es os = do
        c <- getSourceContext
        o <- infixOperator <|> functionOperator
        e2 <- notInfix
        let es' = es ++ [e2]
        let os' = os ++ [([c],o)]
        asInfix es' os' <|> return (infixToTree [] es' os')
      infixToTree [(e1,c1,o1)] [e2] [] = InfixExpression c1 e1 o1 e2
      infixToTree [] (e1:es) ((c1,o1):os) = infixToTree [(e1,c1,o1)] es os
      infixToTree ((e1,c1,o1):ss) [e2] [] = let e2' = InfixExpression c1 e1 o1 e2 in
                                                infixToTree ss [e2'] []
      infixToTree ((e1,c1,o1):ss) (e2:es) ((c2,o2):os)
        | o1 `infixBefore` o2 = let e1' = InfixExpression c1 e1 o1 e2 in
                                    infixToTree ss (e1':es) ((c2,o2):os)
        | otherwise = infixToTree ((e2,c2,o2):(e1,c1,o1):ss) es os
      infixToTree _ _ _ = undefined
      literal = do
        l <- sourceParser
        return $ Literal l
      unary = do
        c <- getSourceContext
        o <- unaryOperator <|> functionOperator
        e <- notInfix
        return $ UnaryExpression [c] o e
      expression = labeled "expression" $ do
        c <- getSourceContext
        s <- sourceParser
        vs <- many sourceParser
        return $ Expression [c] s vs
      initalize = do
        c <- getSourceContext
        t <- try $ do  -- Avoids consuming the type name if { isn't present.
          t2 <- sourceParser
          sepAfter (labeled "@value initializer" $ string_ "{")
          return t2
        withParams c t <|> withoutParams c t
      withParams c t = do
        kwTypes
        ps <- between (sepAfter $ string_ "<")
                      (sepAfter $ string_ ">")
                      (sepBy sourceParser (sepAfter $ string_ ","))
        as <- (sepAfter (string_ ",") >> sepBy sourceParser (sepAfter $ string_ ",")) <|> return []
        sepAfter (string_ "}")
        return $ InitializeValue [c] t (Positional ps) (Positional as)
      withoutParams c t = do
        as <- sepBy sourceParser (sepAfter $ string_ ",")
        sepAfter (string_ "}")
        return $ InitializeValue [c] t (Positional []) (Positional as)

instance ParseFromSource (FunctionQualifier SourceContext) where
  -- TODO: This is probably better done iteratively.
  sourceParser = valueFunc <|> categoryFunc <|> typeFunc where
    valueFunc = do
      c <- getSourceContext
      q <- try sourceParser
      valueSymbolGet
      return $ ValueFunction [c] q
    categoryFunc = do
      c <- getSourceContext
      q <- try $ do  -- Avoids consuming the type name if : isn't present.
        q2 <- sourceParser
        categorySymbolGet
        return q2
      return $ CategoryFunction [c] q
    typeFunc = do
      c <- getSourceContext
      q <- try sourceParser
      typeSymbolGet
      return $ TypeFunction [c] q

instance ParseFromSource (FunctionSpec SourceContext) where
  sourceParser = try qualified <|> unqualified where
    qualified = do
      c <- getSourceContext
      q <- sourceParser
      n <- sourceParser
      ps <- try $ between (sepAfter $ string_ "<")
                          (sepAfter $ string_ ">")
                          (sepBy sourceParser (sepAfter $ string_ ",")) <|> return []
      return $ FunctionSpec [c] q n (Positional ps)
    unqualified = do
      c <- getSourceContext
      n <- sourceParser
      ps <- try $ between (sepAfter $ string_ "<")
                          (sepAfter $ string_ ">")
                          (sepBy sourceParser (sepAfter $ string_ ",")) <|> return []
      return $ FunctionSpec [c] UnqualifiedFunction n (Positional ps)

instance ParseFromSource (InstanceOrInferred SourceContext) where
  sourceParser = assigned <|> inferred where
    assigned = do
      c <- getSourceContext
      t <- sourceParser
      return $ AssignedInstance [c] t
    inferred = do
      c <- getSourceContext
      sepAfter_ inferredParam
      return $ InferredInstance [c]

parseFunctionCall :: SourceContext -> FunctionName -> TextParser (FunctionCall SourceContext)
parseFunctionCall c n = do
  -- NOTE: try is needed here so that < operators work when the left side is
  -- just a variable name, e.g., x < y.
  ps <- try $ between (sepAfter $ string_ "<")
                      (sepAfter $ string_ ">")
                      (sepBy sourceParser (sepAfter $ string_ ",")) <|> return []
  es <- between (sepAfter $ string_ "(")
                (sepAfter $ string_ ")")
                (sepBy sourceParser (sepAfter $ string_ ","))
  return $ FunctionCall [c] n (Positional ps) (Positional es)

builtinFunction :: TextParser FunctionName
builtinFunction = foldr (<|>) empty $ map try [
    kwPresent >> return BuiltinPresent,
    kwReduce >> return BuiltinReduce,
    kwRequire >> return BuiltinRequire,
    kwStrong >> return BuiltinStrong,
    kwTypename >> return BuiltinTypename
  ]

instance ParseFromSource (ExpressionStart SourceContext) where
  sourceParser = labeled "expression start" $
                 parens <|>
                 variableOrUnqualified <|>
                 builtinCall <|>
                 builtinValue <|>
                 sourceContext <|>
                 exprLookup <|>
                 categoryCall <|>
                 typeCall where
    parens = do
      c <- getSourceContext
      sepAfter (string_ "(")
      e <- try (assign c) <|> expr c
      sepAfter (string_ ")")
      return e
    assign :: SourceContext -> TextParser (ExpressionStart SourceContext)
    assign c = do
      n <- sourceParser
      assignOperator
      e <- sourceParser
      return $ InlineAssignment [c] n e
    expr :: SourceContext -> TextParser (ExpressionStart SourceContext)
    expr c = do
      e <- sourceParser
      return $ ParensExpression [c] e
    builtinCall = do
      c <- getSourceContext
      n <- builtinFunction
      f <- parseFunctionCall c n
      return $ BuiltinCall [c] f
    builtinValue = do
      c <- getSourceContext
      n <- builtinValues
      return $ NamedVariable (OutputValue [c] (VariableName n))
    sourceContext = do
      pragma <- pragmaSourceContext
      case pragma of
           (PragmaSourceContext c) -> return $ ParensExpression [c] $ Literal (StringLiteral [c] (show c))
           _ -> undefined  -- Should be caught above.
    exprLookup = do
      pragma <- pragmaExprLookup
      case pragma of
           (PragmaExprLookup c name) -> return $ NamedMacro c name
           _ -> undefined  -- Should be caught above.
    variableOrUnqualified = do
      c <- getSourceContext
      n <- sourceParser :: TextParser VariableName
      asUnqualifiedCall c n <|> asVariable c n
    asVariable c n = do
      return $ NamedVariable (OutputValue [c] n)
    asUnqualifiedCall c n = do
      f <- parseFunctionCall c (FunctionName (vnName n))
      return $ UnqualifiedCall [c] f
    categoryCall = do
      c <- getSourceContext
      t <- try $ do  -- Avoids consuming the type name if : isn't present.
        t2 <- sourceParser
        categorySymbolGet
        return t2
      n <- sourceParser
      f <- parseFunctionCall c n
      return $ CategoryCall [c] t f
    typeCall = do
      c <- getSourceContext
      t <- try sourceParser
      typeSymbolGet
      n <- sourceParser
      f <- parseFunctionCall c n
      return $ TypeCall [c] t f

instance ParseFromSource (ValueLiteral SourceContext) where
  sourceParser = labeled "literal" $
                 stringLiteral <|>
                 charLiteral <|>
                 escapedInteger <|>
                 integerOrDecimal <|>
                 boolLiteral <|>
                 emptyLiteral where
    stringLiteral = do
      c <- getSourceContext
      ss <- quotedString
      optionalSpace
      return $ StringLiteral [c] ss
    charLiteral = do
      c <- getSourceContext
      string_ "'"
      ch <- stringChar <|> char '"'
      string_ "'"
      optionalSpace
      return $ CharLiteral [c] ch
    escapedInteger = do
      c <- getSourceContext
      escapeStart
      b <- oneOf "bBoOdDxX"
      d <- case b of
               'b' -> parseBin
               'B' -> parseBin
               'o' -> parseOct
               'O' -> parseOct
               'd' -> parseDec
               'D' -> parseDec
               'x' -> parseHex
               'X' -> parseHex
               _ -> undefined
      optionalSpace
      return $ IntegerLiteral [c] True d
    integerOrDecimal = do
      c <- getSourceContext
      d <- parseDec
      decimal c d <|> integer c d
    decimal c d = do
      char_ '.'
      (n,d2) <- parseSubOne
      e <- decExponent <|> return 0
      optionalSpace
      return $ DecimalLiteral [c] (d*10^n + d2) (e - n)
    decExponent = do
      string_ "e" <|> string_ "E"
      s <- (string_ "+" >> return 1) <|> (string_ "-" >> return (-1)) <|> return 1
      e <- parseDec
      return (s*e)
    integer c d = do
      optionalSpace
      return $ IntegerLiteral [c] False d
    boolLiteral = do
      c <- getSourceContext
      b <- try $ (kwTrue >> return True) <|> (kwFalse >> return False)
      return $ BoolLiteral [c] b
    emptyLiteral = do
      c <- getSourceContext
      kwEmpty
      return $ EmptyLiteral [c]

instance ParseFromSource (ValueOperation SourceContext) where
  sourceParser = try valueCall <|> try conversion where
    valueCall = labeled "function call" $ do
      c <- getSourceContext
      valueSymbolGet
      n <- sourceParser
      f <- parseFunctionCall c n
      return $ ValueCall [c] f
    conversion = labeled "type conversion" $ do
      c <- getSourceContext
      valueSymbolGet
      t <- sourceParser -- NOTE: Should not need try here.
      typeSymbolGet
      n <- sourceParser
      f <- parseFunctionCall c n
      return $ ConvertedCall [c] t f