-- Copyright (C) 2018-2024 Jun Zhang <zhangjunphy[at]gmail[dot]com>
--
-- This file is a part of decafc.
--
-- decafc is free software: you can redistribute it and/or modify it under the
-- terms of the MIT (X11) License as described in the LICENSE file.
--
-- decafc is distributed in the hope that it will be useful, but WITHOUT ANY
-- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE.  See the X11 license for more details.

-- Semantic -- Decaf semantic checker
module Semantic
  ( analyze,
    SymbolTable (..),
    SemanticInfo (..),
    BlockType (..),
    lookupLocalVariableFromST,
    lookupLocalMethodFromST,
  )
where

import AST
import Util.Constants
import Control.Applicative ((<|>))
import Control.Lens (view, (%=), (^.), (.=))
import Control.Monad.Except
import Control.Monad.State
import Control.Monad.Writer.Lazy
import Data.Char (ord)
import Data.Functor ((<&>))
import Data.Generics.Labels
import Data.Int (Int64)
import Data.List (find)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (isJust, isNothing)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Read qualified as T
import Formatting
import GHC.Generics (Generic)
import Parser qualified as P
import Types
import Util.SourceLoc qualified as SL

---------------------------------------
-- Semantic informations and errors
---------------------------------------

data BlockType = RootBlock | IfBlock | ForBlock | WhileBlock | MethodBlock
  deriving (ScopeID -> BlockType -> ShowS
[BlockType] -> ShowS
BlockType -> String
(ScopeID -> BlockType -> ShowS)
-> (BlockType -> String)
-> ([BlockType] -> ShowS)
-> Show BlockType
forall a.
(ScopeID -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: ScopeID -> BlockType -> ShowS
showsPrec :: ScopeID -> BlockType -> ShowS
$cshow :: BlockType -> String
show :: BlockType -> String
$cshowList :: [BlockType] -> ShowS
showList :: [BlockType] -> ShowS
Show, BlockType -> BlockType -> Bool
(BlockType -> BlockType -> Bool)
-> (BlockType -> BlockType -> Bool) -> Eq BlockType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BlockType -> BlockType -> Bool
== :: BlockType -> BlockType -> Bool
$c/= :: BlockType -> BlockType -> Bool
/= :: BlockType -> BlockType -> Bool
Eq)

-- symbol table definitions
data SymbolTable = SymbolTable
  { SymbolTable -> ScopeID
scopeID :: ScopeID,
    SymbolTable -> Maybe SymbolTable
parent :: Maybe SymbolTable,
    SymbolTable -> Maybe (Map Name ImportDecl)
importSymbols :: Maybe (Map Name ImportDecl),
    SymbolTable -> Map Name FieldDecl
variableSymbols :: Map Name FieldDecl,
    SymbolTable -> Maybe (Map Name MethodDecl)
methodSymbols :: Maybe (Map Name MethodDecl),
    SymbolTable -> Maybe (Map Name Argument)
arguments :: Maybe (Map Name Argument),
    SymbolTable -> BlockType
blockType :: BlockType,
    SymbolTable -> Maybe MethodSig
methodSig :: Maybe MethodSig
  }
  deriving ((forall x. SymbolTable -> Rep SymbolTable x)
-> (forall x. Rep SymbolTable x -> SymbolTable)
-> Generic SymbolTable
forall x. Rep SymbolTable x -> SymbolTable
forall x. SymbolTable -> Rep SymbolTable x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SymbolTable -> Rep SymbolTable x
from :: forall x. SymbolTable -> Rep SymbolTable x
$cto :: forall x. Rep SymbolTable x -> SymbolTable
to :: forall x. Rep SymbolTable x -> SymbolTable
Generic)

instance Show SymbolTable where
  show :: SymbolTable -> String
show (SymbolTable ScopeID
sid Maybe SymbolTable
p Maybe (Map Name ImportDecl)
imports Map Name FieldDecl
variables Maybe (Map Name MethodDecl)
methods Maybe (Map Name Argument)
arguments BlockType
tpe Maybe MethodSig
_) =
    Format
  String
  (ScopeID
   -> Maybe ScopeID
   -> Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
-> ScopeID
-> Maybe ScopeID
-> Maybe (Map Name ImportDecl)
-> Map Name FieldDecl
-> Maybe (Map Name MethodDecl)
-> Maybe (Map Name Argument)
-> BlockType
-> String
forall a. Format String a -> a
formatToString
      (Format
  (ScopeID
   -> Maybe ScopeID
   -> Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
  (ScopeID
   -> Maybe ScopeID
   -> Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
"SymbolTable {scopeID=" Format
  (ScopeID
   -> Maybe ScopeID
   -> Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
  (ScopeID
   -> Maybe ScopeID
   -> Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
-> Format
     String
     (ScopeID
      -> Maybe ScopeID
      -> Maybe (Map Name ImportDecl)
      -> Map Name FieldDecl
      -> Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument)
      -> BlockType
      -> String)
-> Format
     String
     (ScopeID
      -> Maybe ScopeID
      -> Maybe (Map Name ImportDecl)
      -> Map Name FieldDecl
      -> Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument)
      -> BlockType
      -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format
  (Maybe ScopeID
   -> Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
  (ScopeID
   -> Maybe ScopeID
   -> Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
forall a r. Integral a => Format r (a -> r)
int Format
  (Maybe ScopeID
   -> Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
  (ScopeID
   -> Maybe ScopeID
   -> Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
-> Format
     String
     (Maybe ScopeID
      -> Maybe (Map Name ImportDecl)
      -> Map Name FieldDecl
      -> Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument)
      -> BlockType
      -> String)
-> Format
     String
     (ScopeID
      -> Maybe ScopeID
      -> Maybe (Map Name ImportDecl)
      -> Map Name FieldDecl
      -> Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument)
      -> BlockType
      -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format
  (Maybe ScopeID
   -> Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
  (Maybe ScopeID
   -> Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
", parent=" Format
  (Maybe ScopeID
   -> Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
  (Maybe ScopeID
   -> Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
-> Format
     String
     (Maybe ScopeID
      -> Maybe (Map Name ImportDecl)
      -> Map Name FieldDecl
      -> Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument)
      -> BlockType
      -> String)
-> Format
     String
     (Maybe ScopeID
      -> Maybe (Map Name ImportDecl)
      -> Map Name FieldDecl
      -> Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument)
      -> BlockType
      -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format
  (Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
  (Maybe ScopeID
   -> Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
forall a r. Show a => Format r (a -> r)
shown Format
  (Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
  (Maybe ScopeID
   -> Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
-> Format
     String
     (Maybe (Map Name ImportDecl)
      -> Map Name FieldDecl
      -> Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument)
      -> BlockType
      -> String)
-> Format
     String
     (Maybe ScopeID
      -> Maybe (Map Name ImportDecl)
      -> Map Name FieldDecl
      -> Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument)
      -> BlockType
      -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format
  (Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
  (Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
", imports=" Format
  (Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
  (Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
-> Format
     String
     (Maybe (Map Name ImportDecl)
      -> Map Name FieldDecl
      -> Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument)
      -> BlockType
      -> String)
-> Format
     String
     (Maybe (Map Name ImportDecl)
      -> Map Name FieldDecl
      -> Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument)
      -> BlockType
      -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format
  (Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
  (Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
forall a r. Show a => Format r (a -> r)
shown Format
  (Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
  (Maybe (Map Name ImportDecl)
   -> Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
-> Format
     String
     (Map Name FieldDecl
      -> Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument)
      -> BlockType
      -> String)
-> Format
     String
     (Maybe (Map Name ImportDecl)
      -> Map Name FieldDecl
      -> Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument)
      -> BlockType
      -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format
  (Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
  (Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
", variables=" Format
  (Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
  (Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
-> Format
     String
     (Map Name FieldDecl
      -> Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument)
      -> BlockType
      -> String)
-> Format
     String
     (Map Name FieldDecl
      -> Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument)
      -> BlockType
      -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format
  (Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument) -> BlockType -> String)
  (Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
forall a r. Show a => Format r (a -> r)
shown Format
  (Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument) -> BlockType -> String)
  (Map Name FieldDecl
   -> Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument)
   -> BlockType
   -> String)
-> Format
     String
     (Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument) -> BlockType -> String)
-> Format
     String
     (Map Name FieldDecl
      -> Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument)
      -> BlockType
      -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format
  (Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument) -> BlockType -> String)
  (Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument) -> BlockType -> String)
", methods=" Format
  (Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument) -> BlockType -> String)
  (Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument) -> BlockType -> String)
-> Format
     String
     (Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument) -> BlockType -> String)
-> Format
     String
     (Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument) -> BlockType -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format
  (Maybe (Map Name Argument) -> BlockType -> String)
  (Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument) -> BlockType -> String)
forall a r. Show a => Format r (a -> r)
shown Format
  (Maybe (Map Name Argument) -> BlockType -> String)
  (Maybe (Map Name MethodDecl)
   -> Maybe (Map Name Argument) -> BlockType -> String)
-> Format String (Maybe (Map Name Argument) -> BlockType -> String)
-> Format
     String
     (Maybe (Map Name MethodDecl)
      -> Maybe (Map Name Argument) -> BlockType -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format
  (Maybe (Map Name Argument) -> BlockType -> String)
  (Maybe (Map Name Argument) -> BlockType -> String)
", arguments=" Format
  (Maybe (Map Name Argument) -> BlockType -> String)
  (Maybe (Map Name Argument) -> BlockType -> String)
-> Format String (Maybe (Map Name Argument) -> BlockType -> String)
-> Format String (Maybe (Map Name Argument) -> BlockType -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format
  (BlockType -> String)
  (Maybe (Map Name Argument) -> BlockType -> String)
forall a r. Show a => Format r (a -> r)
shown Format
  (BlockType -> String)
  (Maybe (Map Name Argument) -> BlockType -> String)
-> Format String (BlockType -> String)
-> Format String (Maybe (Map Name Argument) -> BlockType -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (BlockType -> String) (BlockType -> String)
", tpe=" Format (BlockType -> String) (BlockType -> String)
-> Format String (BlockType -> String)
-> Format String (BlockType -> String)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format String (BlockType -> String)
forall a r. Show a => Format r (a -> r)
shown)
      ScopeID
sid
      (SymbolTable -> ScopeID
scopeID (SymbolTable -> ScopeID) -> Maybe SymbolTable -> Maybe ScopeID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SymbolTable
p)
      Maybe (Map Name ImportDecl)
imports
      Map Name FieldDecl
variables
      Maybe (Map Name MethodDecl)
methods
      Maybe (Map Name Argument)
arguments
      BlockType
tpe

data SemanticState = SemanticState
  { SemanticState -> ScopeID
nextScopeID :: ScopeID,
    SemanticState -> ScopeID
currentScopeID :: ScopeID,
    SemanticState -> Map ScopeID SymbolTable
symbolTables :: Map ScopeID SymbolTable,
    SemanticState -> Range
currentRange :: SL.Range,
    SemanticState -> Map ScopeID (Set (ScopeID, Name))
symbolWrites :: Map ScopeID (Set (ScopeID, Name))
  }
  deriving (ScopeID -> SemanticState -> ShowS
[SemanticState] -> ShowS
SemanticState -> String
(ScopeID -> SemanticState -> ShowS)
-> (SemanticState -> String)
-> ([SemanticState] -> ShowS)
-> Show SemanticState
forall a.
(ScopeID -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: ScopeID -> SemanticState -> ShowS
showsPrec :: ScopeID -> SemanticState -> ShowS
$cshow :: SemanticState -> String
show :: SemanticState -> String
$cshowList :: [SemanticState] -> ShowS
showList :: [SemanticState] -> ShowS
Show, (forall x. SemanticState -> Rep SemanticState x)
-> (forall x. Rep SemanticState x -> SemanticState)
-> Generic SemanticState
forall x. Rep SemanticState x -> SemanticState
forall x. SemanticState -> Rep SemanticState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SemanticState -> Rep SemanticState x
from :: forall x. SemanticState -> Rep SemanticState x
$cto :: forall x. Rep SemanticState x -> SemanticState
to :: forall x. Rep SemanticState x -> SemanticState
Generic)

data SemanticInfo = SemanticInfo
  { SemanticInfo -> Map ScopeID SymbolTable
symbolTables :: !(Map ScopeID SymbolTable),
    SemanticInfo -> Map ScopeID (Set (ScopeID, Name))
symbolWrites :: !(Map ScopeID (Set (ScopeID, Name)))
  } deriving (ScopeID -> SemanticInfo -> ShowS
[SemanticInfo] -> ShowS
SemanticInfo -> String
(ScopeID -> SemanticInfo -> ShowS)
-> (SemanticInfo -> String)
-> ([SemanticInfo] -> ShowS)
-> Show SemanticInfo
forall a.
(ScopeID -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: ScopeID -> SemanticInfo -> ShowS
showsPrec :: ScopeID -> SemanticInfo -> ShowS
$cshow :: SemanticInfo -> String
show :: SemanticInfo -> String
$cshowList :: [SemanticInfo] -> ShowS
showList :: [SemanticInfo] -> ShowS
Show, (forall x. SemanticInfo -> Rep SemanticInfo x)
-> (forall x. Rep SemanticInfo x -> SemanticInfo)
-> Generic SemanticInfo
forall x. Rep SemanticInfo x -> SemanticInfo
forall x. SemanticInfo -> Rep SemanticInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SemanticInfo -> Rep SemanticInfo x
from :: forall x. SemanticInfo -> Rep SemanticInfo x
$cto :: forall x. Rep SemanticInfo x -> SemanticInfo
to :: forall x. Rep SemanticInfo x -> SemanticInfo
Generic)

-- Monad used for semantic analysis
-- Symbol tables are built for every scope, and stored in SemanticState.
-- Semantic errors encountered are recorded by the writer monad (WriterT [CompileError]).
-- If a serious problem happened such that the analysis has to be aborted, a CompileError 
-- is thrown as an exception.
newtype Semantic a = Semantic {forall a.
Semantic a
-> ExceptT
     CompileError (WriterT [CompileError] (State SemanticState)) a
runSemantic :: ExceptT CompileError (WriterT [CompileError] (State SemanticState)) a}
  deriving ((forall a b. (a -> b) -> Semantic a -> Semantic b)
-> (forall a b. a -> Semantic b -> Semantic a) -> Functor Semantic
forall a b. a -> Semantic b -> Semantic a
forall a b. (a -> b) -> Semantic a -> Semantic b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Semantic a -> Semantic b
fmap :: forall a b. (a -> b) -> Semantic a -> Semantic b
$c<$ :: forall a b. a -> Semantic b -> Semantic a
<$ :: forall a b. a -> Semantic b -> Semantic a
Functor, Functor Semantic
Functor Semantic
-> (forall a. a -> Semantic a)
-> (forall a b. Semantic (a -> b) -> Semantic a -> Semantic b)
-> (forall a b c.
    (a -> b -> c) -> Semantic a -> Semantic b -> Semantic c)
-> (forall a b. Semantic a -> Semantic b -> Semantic b)
-> (forall a b. Semantic a -> Semantic b -> Semantic a)
-> Applicative Semantic
forall a. a -> Semantic a
forall a b. Semantic a -> Semantic b -> Semantic a
forall a b. Semantic a -> Semantic b -> Semantic b
forall a b. Semantic (a -> b) -> Semantic a -> Semantic b
forall a b c.
(a -> b -> c) -> Semantic a -> Semantic b -> Semantic c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Semantic a
pure :: forall a. a -> Semantic a
$c<*> :: forall a b. Semantic (a -> b) -> Semantic a -> Semantic b
<*> :: forall a b. Semantic (a -> b) -> Semantic a -> Semantic b
$cliftA2 :: forall a b c.
(a -> b -> c) -> Semantic a -> Semantic b -> Semantic c
liftA2 :: forall a b c.
(a -> b -> c) -> Semantic a -> Semantic b -> Semantic c
$c*> :: forall a b. Semantic a -> Semantic b -> Semantic b
*> :: forall a b. Semantic a -> Semantic b -> Semantic b
$c<* :: forall a b. Semantic a -> Semantic b -> Semantic a
<* :: forall a b. Semantic a -> Semantic b -> Semantic a
Applicative, Applicative Semantic
Applicative Semantic
-> (forall a b. Semantic a -> (a -> Semantic b) -> Semantic b)
-> (forall a b. Semantic a -> Semantic b -> Semantic b)
-> (forall a. a -> Semantic a)
-> Monad Semantic
forall a. a -> Semantic a
forall a b. Semantic a -> Semantic b -> Semantic b
forall a b. Semantic a -> (a -> Semantic b) -> Semantic b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Semantic a -> (a -> Semantic b) -> Semantic b
>>= :: forall a b. Semantic a -> (a -> Semantic b) -> Semantic b
$c>> :: forall a b. Semantic a -> Semantic b -> Semantic b
>> :: forall a b. Semantic a -> Semantic b -> Semantic b
$creturn :: forall a. a -> Semantic a
return :: forall a. a -> Semantic a
Monad, MonadError CompileError, MonadWriter [CompileError], MonadState SemanticState)

analyze :: P.Program -> Either [CompileError] (ASTRoot, SemanticInfo)
analyze :: Program -> Either [CompileError] (ASTRoot, SemanticInfo)
analyze Program
p =
  let ir :: Semantic ASTRoot
ir = Program -> Semantic ASTRoot
irgenRoot Program
p
      ((Either CompileError ASTRoot
except, [CompileError]
errors), SemanticState
state) = (State SemanticState (Either CompileError ASTRoot, [CompileError])
-> SemanticState
-> ((Either CompileError ASTRoot, [CompileError]), SemanticState)
forall s a. State s a -> s -> (a, s)
runState (State SemanticState (Either CompileError ASTRoot, [CompileError])
 -> SemanticState
 -> ((Either CompileError ASTRoot, [CompileError]), SemanticState))
-> State
     SemanticState (Either CompileError ASTRoot, [CompileError])
-> SemanticState
-> ((Either CompileError ASTRoot, [CompileError]), SemanticState)
forall a b. (a -> b) -> a -> b
$ WriterT
  [CompileError] (State SemanticState) (Either CompileError ASTRoot)
-> State
     SemanticState (Either CompileError ASTRoot, [CompileError])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT
   [CompileError] (State SemanticState) (Either CompileError ASTRoot)
 -> State
      SemanticState (Either CompileError ASTRoot, [CompileError]))
-> WriterT
     [CompileError] (State SemanticState) (Either CompileError ASTRoot)
-> State
     SemanticState (Either CompileError ASTRoot, [CompileError])
forall a b. (a -> b) -> a -> b
$ ExceptT
  CompileError (WriterT [CompileError] (State SemanticState)) ASTRoot
-> WriterT
     [CompileError] (State SemanticState) (Either CompileError ASTRoot)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   CompileError (WriterT [CompileError] (State SemanticState)) ASTRoot
 -> WriterT
      [CompileError] (State SemanticState) (Either CompileError ASTRoot))
-> ExceptT
     CompileError (WriterT [CompileError] (State SemanticState)) ASTRoot
-> WriterT
     [CompileError] (State SemanticState) (Either CompileError ASTRoot)
forall a b. (a -> b) -> a -> b
$ Semantic ASTRoot
-> ExceptT
     CompileError (WriterT [CompileError] (State SemanticState)) ASTRoot
forall a.
Semantic a
-> ExceptT
     CompileError (WriterT [CompileError] (State SemanticState)) a
runSemantic Semantic ASTRoot
ir) SemanticState
initialSemanticState
   in case Either CompileError ASTRoot
except of
        Left CompileError
except -> [CompileError] -> Either [CompileError] (ASTRoot, SemanticInfo)
forall a b. a -> Either a b
Left [CompileError
except]
        Either CompileError ASTRoot
_ | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [CompileError] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CompileError]
errors -> [CompileError] -> Either [CompileError] (ASTRoot, SemanticInfo)
forall a b. a -> Either a b
Left [CompileError]
errors
        Right ASTRoot
a -> (ASTRoot, SemanticInfo)
-> Either [CompileError] (ASTRoot, SemanticInfo)
forall a b. b -> Either a b
Right (ASTRoot
a, Map ScopeID SymbolTable
-> Map ScopeID (Set (ScopeID, Name)) -> SemanticInfo
SemanticInfo (SemanticState
state SemanticState
-> Getting
     (Map ScopeID SymbolTable) SemanticState (Map ScopeID SymbolTable)
-> Map ScopeID SymbolTable
forall s a. s -> Getting a s a -> a
^. Getting
  (Map ScopeID SymbolTable) SemanticState (Map ScopeID SymbolTable)
#symbolTables) (SemanticState
state SemanticState
-> Getting
     (Map ScopeID (Set (ScopeID, Name)))
     SemanticState
     (Map ScopeID (Set (ScopeID, Name)))
-> Map ScopeID (Set (ScopeID, Name))
forall s a. s -> Getting a s a -> a
^. Getting
  (Map ScopeID (Set (ScopeID, Name)))
  SemanticState
  (Map ScopeID (Set (ScopeID, Name)))
#symbolWrites))

initialSemanticState :: SemanticState
initialSemanticState :: SemanticState
initialSemanticState =
  let globalST :: SymbolTable
globalST =
        SymbolTable
          { $sel:scopeID:SymbolTable :: ScopeID
scopeID = ScopeID
globalScopeID,
            $sel:parent:SymbolTable :: Maybe SymbolTable
parent = Maybe SymbolTable
forall a. Maybe a
Nothing,
            $sel:importSymbols:SymbolTable :: Maybe (Map Name ImportDecl)
importSymbols = Map Name ImportDecl -> Maybe (Map Name ImportDecl)
forall a. a -> Maybe a
Just Map Name ImportDecl
forall k a. Map k a
Map.empty,
            $sel:variableSymbols:SymbolTable :: Map Name FieldDecl
variableSymbols = Map Name FieldDecl
forall k a. Map k a
Map.empty,
            $sel:methodSymbols:SymbolTable :: Maybe (Map Name MethodDecl)
methodSymbols = Map Name MethodDecl -> Maybe (Map Name MethodDecl)
forall a. a -> Maybe a
Just Map Name MethodDecl
forall k a. Map k a
Map.empty,
            $sel:arguments:SymbolTable :: Maybe (Map Name Argument)
arguments = Maybe (Map Name Argument)
forall a. Maybe a
Nothing,
            $sel:blockType:SymbolTable :: BlockType
blockType = BlockType
RootBlock,
            $sel:methodSig:SymbolTable :: Maybe MethodSig
methodSig = Maybe MethodSig
forall a. Maybe a
Nothing
          }
   in SemanticState
        { $sel:nextScopeID:SemanticState :: ScopeID
nextScopeID = ScopeID
globalScopeID ScopeID -> ScopeID -> ScopeID
forall a. Num a => a -> a -> a
+ ScopeID
1,
          $sel:currentScopeID:SemanticState :: ScopeID
currentScopeID = ScopeID
globalScopeID,
          $sel:symbolTables:SemanticState :: Map ScopeID SymbolTable
symbolTables = [(ScopeID, SymbolTable)] -> Map ScopeID SymbolTable
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ScopeID
globalScopeID, SymbolTable
globalST)],
          $sel:currentRange:SemanticState :: Range
currentRange = Posn -> Posn -> Range
SL.Range (ScopeID -> ScopeID -> ScopeID -> Posn
SL.Posn ScopeID
0 ScopeID
0 ScopeID
0) (ScopeID -> ScopeID -> ScopeID -> Posn
SL.Posn ScopeID
0 ScopeID
0 ScopeID
0),
          $sel:symbolWrites:SemanticState :: Map ScopeID (Set (ScopeID, Name))
symbolWrites = Map ScopeID (Set (ScopeID, Name))
forall k a. Map k a
Map.empty
        }

updateCurrentRange :: SL.Range -> Semantic ()
updateCurrentRange :: Range -> Semantic ()
updateCurrentRange Range
range = (SemanticState -> SemanticState) -> Semantic ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\SemanticState
s -> SemanticState
s {$sel:currentRange:SemanticState :: Range
currentRange = Range
range})

getCurrentRange :: Semantic SL.Range
getCurrentRange :: Semantic Range
getCurrentRange = (SemanticState -> Range) -> Semantic Range
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SemanticState -> Range
currentRange

-- throw exception or store errors
throwSemanticException :: Text -> Semantic a
throwSemanticException :: forall a. Name -> Semantic a
throwSemanticException Name
msg = do
  Range
range <- Semantic Range
getCurrentRange
  CompileError -> Semantic a
forall a. CompileError -> Semantic a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> Semantic a) -> CompileError -> Semantic a
forall a b. (a -> b) -> a -> b
$ Maybe Range -> Name -> CompileError
CompileError (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
range) Name
msg

addSemanticError :: Text -> Semantic ()
addSemanticError :: Name -> Semantic ()
addSemanticError Name
msg = do
  Range
range <- Semantic Range
getCurrentRange
  [CompileError] -> Semantic ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Maybe Range -> Name -> CompileError
CompileError (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
range) Name
msg]

-- find symbol table for global scope
getGlobalSymbolTable' :: Semantic SymbolTable
getGlobalSymbolTable' :: Semantic SymbolTable
getGlobalSymbolTable' = do
  SemanticState
state <- Semantic SemanticState
forall s (m :: * -> *). MonadState s m => m s
get
  case ScopeID -> Map ScopeID SymbolTable -> Maybe SymbolTable
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopeID
globalScopeID (Map ScopeID SymbolTable -> Maybe SymbolTable)
-> Map ScopeID SymbolTable -> Maybe SymbolTable
forall a b. (a -> b) -> a -> b
$ SemanticState
state SemanticState
-> Getting
     (Map ScopeID SymbolTable) SemanticState (Map ScopeID SymbolTable)
-> Map ScopeID SymbolTable
forall s a. s -> Getting a s a -> a
^. Getting
  (Map ScopeID SymbolTable) SemanticState (Map ScopeID SymbolTable)
#symbolTables of
    Maybe SymbolTable
Nothing -> Name -> Semantic SymbolTable
forall a. Name -> Semantic a
throwSemanticException Name
"No global symbol table found!"
    Just SymbolTable
t -> SymbolTable -> Semantic SymbolTable
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return SymbolTable
t

-- find symbol table for current scope
getSymbolTable :: Semantic (Maybe SymbolTable)
getSymbolTable :: Semantic (Maybe SymbolTable)
getSymbolTable = do
  SemanticState
state <- Semantic SemanticState
forall s (m :: * -> *). MonadState s m => m s
get
  let id :: ScopeID
id = SemanticState -> ScopeID
currentScopeID SemanticState
state
  Maybe SymbolTable -> Semantic (Maybe SymbolTable)
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SymbolTable -> Semantic (Maybe SymbolTable))
-> Maybe SymbolTable -> Semantic (Maybe SymbolTable)
forall a b. (a -> b) -> a -> b
$ ScopeID -> Map ScopeID SymbolTable -> Maybe SymbolTable
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopeID
id (Map ScopeID SymbolTable -> Maybe SymbolTable)
-> Map ScopeID SymbolTable -> Maybe SymbolTable
forall a b. (a -> b) -> a -> b
$ SemanticState
state SemanticState
-> Getting
     (Map ScopeID SymbolTable) SemanticState (Map ScopeID SymbolTable)
-> Map ScopeID SymbolTable
forall s a. s -> Getting a s a -> a
^. Getting
  (Map ScopeID SymbolTable) SemanticState (Map ScopeID SymbolTable)
#symbolTables

getCurrentScopeID :: Semantic Int
getCurrentScopeID :: Semantic ScopeID
getCurrentScopeID = (SemanticState -> ScopeID) -> Semantic ScopeID
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SemanticState -> ScopeID
currentScopeID

-- find symbol table for current scope
-- will throw SemanticException if nothing is found
getSymbolTable' :: Semantic SymbolTable
getSymbolTable' :: Semantic SymbolTable
getSymbolTable' = do
  ScopeID
scopeID <- Semantic ScopeID
getCurrentScopeID
  Maybe SymbolTable
t <- Semantic (Maybe SymbolTable)
getSymbolTable
  case Maybe SymbolTable
t of
    Maybe SymbolTable
Nothing ->
      Name -> Semantic SymbolTable
forall a. Name -> Semantic a
throwSemanticException (Name -> Semantic SymbolTable) -> Name -> Semantic SymbolTable
forall a b. (a -> b) -> a -> b
$ Format Name (ScopeID -> Name) -> ScopeID -> Name
forall a. Format Name a -> a
sformat (Format (ScopeID -> Name) (ScopeID -> Name)
"No symble table found for current scope " Format (ScopeID -> Name) (ScopeID -> Name)
-> Format Name (ScopeID -> Name) -> Format Name (ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (ScopeID -> Name)
forall a r. Integral a => Format r (a -> r)
int) ScopeID
scopeID
    Just SymbolTable
table -> SymbolTable -> Semantic SymbolTable
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return SymbolTable
table

getLocalVariables' :: Semantic (Map Name FieldDecl)
getLocalVariables' :: Semantic (Map Name FieldDecl)
getLocalVariables' = do
  SymbolTable -> Map Name FieldDecl
variableSymbols (SymbolTable -> Map Name FieldDecl)
-> Semantic SymbolTable -> Semantic (Map Name FieldDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Semantic SymbolTable
getSymbolTable'

getLocalImports' :: Semantic (Map Name ImportDecl)
getLocalImports' :: Semantic (Map Name ImportDecl)
getLocalImports' = do
  SymbolTable
localST <- Semantic SymbolTable
getSymbolTable'
  case SymbolTable -> Maybe (Map Name ImportDecl)
importSymbols SymbolTable
localST of
    Maybe (Map Name ImportDecl)
Nothing -> Name -> Semantic (Map Name ImportDecl)
forall a. Name -> Semantic a
throwSemanticException (Name -> Semantic (Map Name ImportDecl))
-> Name -> Semantic (Map Name ImportDecl)
forall a b. (a -> b) -> a -> b
$ Format Name (ScopeID -> Name) -> ScopeID -> Name
forall a. Format Name a -> a
sformat (Format (ScopeID -> Name) (ScopeID -> Name)
"No import table for scope " Format (ScopeID -> Name) (ScopeID -> Name)
-> Format Name (ScopeID -> Name) -> Format Name (ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (ScopeID -> Name)
forall a r. Integral a => Format r (a -> r)
int) (ScopeID -> Name) -> ScopeID -> Name
forall a b. (a -> b) -> a -> b
$ SymbolTable -> ScopeID
scopeID SymbolTable
localST
    Just Map Name ImportDecl
t -> Map Name ImportDecl -> Semantic (Map Name ImportDecl)
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return Map Name ImportDecl
t

getLocalMethods' :: Semantic (Map Name MethodDecl)
getLocalMethods' :: Semantic (Map Name MethodDecl)
getLocalMethods' = do
  SymbolTable
localST <- Semantic SymbolTable
getSymbolTable'
  case SymbolTable -> Maybe (Map Name MethodDecl)
methodSymbols SymbolTable
localST of
    Maybe (Map Name MethodDecl)
Nothing -> Name -> Semantic (Map Name MethodDecl)
forall a. Name -> Semantic a
throwSemanticException (Name -> Semantic (Map Name MethodDecl))
-> Name -> Semantic (Map Name MethodDecl)
forall a b. (a -> b) -> a -> b
$ Format Name (ScopeID -> Name) -> ScopeID -> Name
forall a. Format Name a -> a
sformat (Format (ScopeID -> Name) (ScopeID -> Name)
"No method table for scope " Format (ScopeID -> Name) (ScopeID -> Name)
-> Format Name (ScopeID -> Name) -> Format Name (ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (ScopeID -> Name)
forall a r. Integral a => Format r (a -> r)
int) (ScopeID -> Name) -> ScopeID -> Name
forall a b. (a -> b) -> a -> b
$ SymbolTable -> ScopeID
scopeID SymbolTable
localST
    Just Map Name MethodDecl
t -> Map Name MethodDecl -> Semantic (Map Name MethodDecl)
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return Map Name MethodDecl
t

updateSymbolTable :: SymbolTable -> Semantic ()
updateSymbolTable :: SymbolTable -> Semantic ()
updateSymbolTable SymbolTable
t = do
  SemanticState
state <- Semantic SemanticState
forall s (m :: * -> *). MonadState s m => m s
get
  -- ensure the symbol table is present, otherwise throw an exception
  Semantic SymbolTable
getSymbolTable'
  #symbolTables .= Map.insert (currentScopeID state) t (state ^. #symbolTables)

getMethodSignature :: Semantic (Maybe MethodSig)
getMethodSignature :: Semantic (Maybe MethodSig)
getMethodSignature = do SymbolTable -> Maybe MethodSig
lookup (SymbolTable -> Maybe MethodSig)
-> Semantic SymbolTable -> Semantic (Maybe MethodSig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Semantic SymbolTable
getSymbolTable'
  where
    lookup :: SymbolTable -> Maybe MethodSig
    lookup :: SymbolTable -> Maybe MethodSig
lookup SymbolTable {$sel:blockType:SymbolTable :: SymbolTable -> BlockType
blockType = BlockType
RootBlock} = Maybe MethodSig
forall a. Maybe a
Nothing
    lookup SymbolTable {$sel:blockType:SymbolTable :: SymbolTable -> BlockType
blockType = BlockType
MethodBlock, $sel:methodSig:SymbolTable :: SymbolTable -> Maybe MethodSig
methodSig = Maybe MethodSig
sig} = Maybe MethodSig
sig
    lookup SymbolTable {$sel:parent:SymbolTable :: SymbolTable -> Maybe SymbolTable
parent = Just SymbolTable
p} = SymbolTable -> Maybe MethodSig
lookup SymbolTable
p

getMethodSignature' :: Semantic MethodSig
getMethodSignature' :: Semantic MethodSig
getMethodSignature' = do
  Maybe MethodSig
sig <- Semantic (Maybe MethodSig)
getMethodSignature
  case Maybe MethodSig
sig of
    Maybe MethodSig
Nothing -> Name -> Semantic MethodSig
forall a. Name -> Semantic a
throwSemanticException Name
"Cannot find signature for current function!"
    Just MethodSig
s -> MethodSig -> Semantic MethodSig
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return MethodSig
s

enterScope :: BlockType -> Maybe MethodSig -> Semantic ScopeID
enterScope :: BlockType -> Maybe MethodSig -> Semantic ScopeID
enterScope BlockType
blockType Maybe MethodSig
sig = do
  SemanticState
state <- Semantic SemanticState
forall s (m :: * -> *). MonadState s m => m s
get
  Maybe SymbolTable
parentST <- Semantic (Maybe SymbolTable)
getSymbolTable
  let nextID :: ScopeID
nextID = SemanticState -> ScopeID
nextScopeID SemanticState
state
      args :: Maybe (Map Name Argument)
args = Maybe MethodSig
sig Maybe MethodSig
-> (MethodSig -> Map Name Argument) -> Maybe (Map Name Argument)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \MethodSig
s -> [(Name, Argument)] -> Map Name Argument
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Argument)] -> Map Name Argument)
-> [(Name, Argument)] -> Map Name Argument
forall a b. (a -> b) -> a -> b
$ (MethodSig
s MethodSig -> Getting [Argument] MethodSig [Argument] -> [Argument]
forall s a. s -> Getting a s a -> a
^. Getting [Argument] MethodSig [Argument]
#args) [Argument] -> (Argument -> (Name, Argument)) -> [(Name, Argument)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\Argument
a -> (Argument
a Argument -> Getting Name Argument Name -> Name
forall s a. s -> Getting a s a -> a
^. Getting Name Argument Name
#name, Argument
a))
      localST :: SymbolTable
localST =
        SymbolTable
          { $sel:scopeID:SymbolTable :: ScopeID
scopeID = ScopeID
nextID,
            $sel:parent:SymbolTable :: Maybe SymbolTable
parent = Maybe SymbolTable
parentST,
            $sel:variableSymbols:SymbolTable :: Map Name FieldDecl
variableSymbols = Map Name FieldDecl
forall k a. Map k a
Map.empty,
            $sel:importSymbols:SymbolTable :: Maybe (Map Name ImportDecl)
importSymbols = Maybe (Map Name ImportDecl)
forall a. Maybe a
Nothing,
            $sel:methodSymbols:SymbolTable :: Maybe (Map Name MethodDecl)
methodSymbols = Maybe (Map Name MethodDecl)
forall a. Maybe a
Nothing,
            $sel:arguments:SymbolTable :: Maybe (Map Name Argument)
arguments = Maybe (Map Name Argument)
args,
            $sel:blockType:SymbolTable :: BlockType
blockType = BlockType
blockType,
            $sel:methodSig:SymbolTable :: Maybe MethodSig
methodSig = Maybe MethodSig
sig
          }
  SemanticState -> Semantic ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (SemanticState -> Semantic ()) -> SemanticState -> Semantic ()
forall a b. (a -> b) -> a -> b
$
    SemanticState
state
      { $sel:nextScopeID:SemanticState :: ScopeID
nextScopeID = ScopeID
nextID ScopeID -> ScopeID -> ScopeID
forall a. Num a => a -> a -> a
+ ScopeID
1,
        $sel:currentScopeID:SemanticState :: ScopeID
currentScopeID = ScopeID
nextID,
        $sel:symbolTables:SemanticState :: Map ScopeID SymbolTable
symbolTables = ScopeID
-> SymbolTable
-> Map ScopeID SymbolTable
-> Map ScopeID SymbolTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScopeID
nextID SymbolTable
localST (Map ScopeID SymbolTable -> Map ScopeID SymbolTable)
-> Map ScopeID SymbolTable -> Map ScopeID SymbolTable
forall a b. (a -> b) -> a -> b
$ SemanticState
state SemanticState
-> Getting
     (Map ScopeID SymbolTable) SemanticState (Map ScopeID SymbolTable)
-> Map ScopeID SymbolTable
forall s a. s -> Getting a s a -> a
^. Getting
  (Map ScopeID SymbolTable) SemanticState (Map ScopeID SymbolTable)
#symbolTables
      }
  ScopeID -> Semantic ScopeID
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return ScopeID
nextID

exitScope :: Semantic ()
exitScope :: Semantic ()
exitScope = do
  SemanticState
state <- Semantic SemanticState
forall s (m :: * -> *). MonadState s m => m s
get
  Maybe SymbolTable
localST <- Semantic (Maybe SymbolTable)
getSymbolTable
  case Maybe SymbolTable
localST of
    Maybe SymbolTable
Nothing ->
      Name -> Semantic ()
forall a. Name -> Semantic a
throwSemanticException (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$
        Format Name (ScopeID -> Name) -> ScopeID -> Name
forall a. Format Name a -> a
sformat (Format (ScopeID -> Name) (ScopeID -> Name)
"No symbol table is associated with scope(" Format (ScopeID -> Name) (ScopeID -> Name)
-> Format Name (ScopeID -> Name) -> Format Name (ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (ScopeID -> Name)
forall a r. Integral a => Format r (a -> r)
int Format Name (ScopeID -> Name)
-> Format Name Name -> Format Name (ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
")!") (ScopeID -> Name) -> ScopeID -> Name
forall a b. (a -> b) -> a -> b
$
          SemanticState -> ScopeID
currentScopeID SemanticState
state
    Just SymbolTable
table ->
      case SymbolTable -> Maybe SymbolTable
parent SymbolTable
table of
        Maybe SymbolTable
Nothing ->
          Name -> Semantic ()
forall a. Name -> Semantic a
throwSemanticException Name
"Cannot exit root scope!"
        Just SymbolTable
p ->
          SemanticState -> Semantic ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (SemanticState -> Semantic ()) -> SemanticState -> Semantic ()
forall a b. (a -> b) -> a -> b
$ SemanticState
state {$sel:currentScopeID:SemanticState :: ScopeID
currentScopeID = SymbolTable -> ScopeID
scopeID SymbolTable
p}

----------------------------------------------------------------------
-- Convert the parser tree into an AST
-- Generate symbol tables at the same time.
-- Also detects semantic errors.
----------------------------------------------------------------------

{-
Semantic rules to be checked, this will be referenced as Semantic[n]in comments below.
1. Identifier duplication.
2. Identifier should be declared before used.
3. Check for method "main". Also check the parameters and return type.
4. Array length should be greater than 0.
5. Method call has matching type and number of arguments.
6. Method must return something if used in expressions.
7. String literals and array variables may not be used as args to non-import methods.
8. Method declared without a return type shall return nothing.
9. Method return type should match declared type.
10. id used as location should name a variable or parameter.
11. Method should be declared or imported before used.
12. Array location must refer to an array varaible, also the index expression must be of type int.
13. Argument of len operator must be an array.
14. The expression of 'if' and 'when', as well as the second expression of 'for' must have type 'bool'.
15. In a conditional expression (?:):
    The first expression must have type bool.
    The alternatives must have the same type.
16. The operands of the unary negative operator, arithmetic ops and relational ops must have type int.
17. The operands of equal ops must have the same type.
18. The operands of the logical not op and conditional op must have type bool.
19. The location and expression in an assignment must have the same type.
20. The location and expression in an incremental assignment must have type int.
21. All break and continue statment must be within a for or while loop.
22. All int literals must be in the range of -9223372036854775808 ≤ x ≤ 9223372036854775807
(64 bits).
-}

{-
  Helper functions to manipulate symbol tables.
-}

{- Varaible lookup. -}

lookupLocalVariableFromST :: Name -> SymbolTable -> Maybe (Either Argument FieldDecl)
lookupLocalVariableFromST :: Name -> SymbolTable -> Maybe (Either Argument FieldDecl)
lookupLocalVariableFromST Name
name SymbolTable
st =
  let f :: Maybe FieldDecl
f = Name -> SymbolTable -> Maybe FieldDecl
lookupLocalFieldDecl Name
name SymbolTable
st
      a :: Maybe Argument
a = Name -> SymbolTable -> Maybe Argument
lookupArgument Name
name SymbolTable
st
   in (FieldDecl -> Either Argument FieldDecl
forall a b. b -> Either a b
Right (FieldDecl -> Either Argument FieldDecl)
-> Maybe FieldDecl -> Maybe (Either Argument FieldDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FieldDecl
f) Maybe (Either Argument FieldDecl)
-> Maybe (Either Argument FieldDecl)
-> Maybe (Either Argument FieldDecl)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Argument -> Either Argument FieldDecl
forall a b. a -> Either a b
Left (Argument -> Either Argument FieldDecl)
-> Maybe Argument -> Maybe (Either Argument FieldDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Argument
a)
  where
    lookupLocalFieldDecl :: Name -> SymbolTable -> Maybe FieldDecl
lookupLocalFieldDecl Name
name SymbolTable
st = Name -> Map Name FieldDecl -> Maybe FieldDecl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name (Map Name FieldDecl -> Maybe FieldDecl)
-> Map Name FieldDecl -> Maybe FieldDecl
forall a b. (a -> b) -> a -> b
$ SymbolTable -> Map Name FieldDecl
variableSymbols SymbolTable
st
    lookupArgument :: Name -> SymbolTable -> Maybe Argument
lookupArgument Name
name SymbolTable
st = SymbolTable -> Maybe (Map Name Argument)
arguments SymbolTable
st Maybe (Map Name Argument)
-> (Map Name Argument -> Maybe Argument) -> Maybe Argument
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Map Name Argument -> Maybe Argument
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name

lookupVariable :: Name -> Semantic (Maybe (Either Argument FieldDecl))
lookupVariable :: Name -> Semantic (Maybe (Either Argument FieldDecl))
lookupVariable Name
name = do
  Maybe SymbolTable
st <- Semantic (Maybe SymbolTable)
getSymbolTable
  Maybe (Either Argument FieldDecl)
-> Semantic (Maybe (Either Argument FieldDecl))
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either Argument FieldDecl)
 -> Semantic (Maybe (Either Argument FieldDecl)))
-> Maybe (Either Argument FieldDecl)
-> Semantic (Maybe (Either Argument FieldDecl))
forall a b. (a -> b) -> a -> b
$ Maybe SymbolTable
st Maybe SymbolTable
-> (SymbolTable -> Maybe (Either Argument FieldDecl))
-> Maybe (Either Argument FieldDecl)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> SymbolTable -> Maybe (Either Argument FieldDecl)
lookup Name
name
  where
    lookup :: Name -> SymbolTable -> Maybe (Either Argument FieldDecl)
lookup Name
name SymbolTable
st' =
      (Name -> SymbolTable -> Maybe (Either Argument FieldDecl)
lookupLocalVariableFromST Name
name SymbolTable
st')
        Maybe (Either Argument FieldDecl)
-> Maybe (Either Argument FieldDecl)
-> Maybe (Either Argument FieldDecl)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (SymbolTable -> Maybe SymbolTable
parent SymbolTable
st' Maybe SymbolTable
-> (SymbolTable -> Maybe (Either Argument FieldDecl))
-> Maybe (Either Argument FieldDecl)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> SymbolTable -> Maybe (Either Argument FieldDecl)
lookup Name
name)

lookupVariable' :: Name -> Semantic (Either Argument FieldDecl)
lookupVariable' :: Name -> Semantic (Either Argument FieldDecl)
lookupVariable' Name
name = do
  Maybe (Either Argument FieldDecl)
v <- Name -> Semantic (Maybe (Either Argument FieldDecl))
lookupVariable Name
name
  case Maybe (Either Argument FieldDecl)
v of
    Maybe (Either Argument FieldDecl)
Nothing -> Name -> Semantic (Either Argument FieldDecl)
forall a. Name -> Semantic a
throwSemanticException (Name -> Semantic (Either Argument FieldDecl))
-> Name -> Semantic (Either Argument FieldDecl)
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"Varaible " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext Format Name (Name -> Name)
-> Format Name Name -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
" not defined") Name
name
    Just Either Argument FieldDecl
v -> Either Argument FieldDecl -> Semantic (Either Argument FieldDecl)
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return Either Argument FieldDecl
v

lookupVariableScope :: Name -> Semantic (Maybe ScopeID)
lookupVariableScope :: Name -> Semantic (Maybe ScopeID)
lookupVariableScope Name
name = do
  Maybe SymbolTable
st <- Semantic (Maybe SymbolTable)
getSymbolTable
  Maybe ScopeID -> Semantic (Maybe ScopeID)
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ScopeID -> Semantic (Maybe ScopeID))
-> Maybe ScopeID -> Semantic (Maybe ScopeID)
forall a b. (a -> b) -> a -> b
$ Maybe SymbolTable
st Maybe SymbolTable
-> (SymbolTable -> Maybe ScopeID) -> Maybe ScopeID
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> SymbolTable -> Maybe ScopeID
lookup Name
name
  where
    lookup :: Name -> SymbolTable -> Maybe ScopeID
lookup Name
name SymbolTable
st' =
      (Name -> SymbolTable -> Maybe (Either Argument FieldDecl)
lookupLocalVariableFromST Name
name SymbolTable
st' Maybe (Either Argument FieldDecl)
-> (Either Argument FieldDecl -> ScopeID) -> Maybe ScopeID
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Either Argument FieldDecl
_ -> SymbolTable
st' SymbolTable -> Getting ScopeID SymbolTable ScopeID -> ScopeID
forall s a. s -> Getting a s a -> a
^. Getting ScopeID SymbolTable ScopeID
#scopeID)
        Maybe ScopeID -> Maybe ScopeID -> Maybe ScopeID
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (SymbolTable -> Maybe SymbolTable
parent SymbolTable
st' Maybe SymbolTable
-> (SymbolTable -> Maybe ScopeID) -> Maybe ScopeID
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> SymbolTable -> Maybe ScopeID
lookup Name
name)

lookupVariableScope' :: Name -> Semantic ScopeID
lookupVariableScope' :: Name -> Semantic ScopeID
lookupVariableScope' Name
name = do
  Maybe ScopeID
sid <- Name -> Semantic (Maybe ScopeID)
lookupVariableScope Name
name
  case Maybe ScopeID
sid of
    Maybe ScopeID
Nothing -> Name -> Semantic ScopeID
forall a. Name -> Semantic a
throwSemanticException (Name -> Semantic ScopeID) -> Name -> Semantic ScopeID
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"Varaible " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext Format Name (Name -> Name)
-> Format Name Name -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
" not defined") Name
name
    Just ScopeID
sid -> ScopeID -> Semantic ScopeID
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return ScopeID
sid

{- Method lookup. -}

lookupLocalMethodFromST :: Name -> SymbolTable -> Maybe (Either ImportDecl MethodDecl)
lookupLocalMethodFromST :: Name -> SymbolTable -> Maybe (Either ImportDecl MethodDecl)
lookupLocalMethodFromST Name
name SymbolTable
table =
  let method :: Maybe MethodDecl
method = do
        Map Name MethodDecl
methodTable <- SymbolTable -> Maybe (Map Name MethodDecl)
methodSymbols SymbolTable
table
        Name -> Map Name MethodDecl -> Maybe MethodDecl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name MethodDecl
methodTable
      import' :: Maybe ImportDecl
import' = do
        Map Name ImportDecl
importTable <- SymbolTable -> Maybe (Map Name ImportDecl)
importSymbols SymbolTable
table
        Name -> Map Name ImportDecl -> Maybe ImportDecl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name ImportDecl
importTable
   in (MethodDecl -> Either ImportDecl MethodDecl
forall a b. b -> Either a b
Right (MethodDecl -> Either ImportDecl MethodDecl)
-> Maybe MethodDecl -> Maybe (Either ImportDecl MethodDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe MethodDecl
method) Maybe (Either ImportDecl MethodDecl)
-> Maybe (Either ImportDecl MethodDecl)
-> Maybe (Either ImportDecl MethodDecl)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ImportDecl -> Either ImportDecl MethodDecl
forall a b. a -> Either a b
Left (ImportDecl -> Either ImportDecl MethodDecl)
-> Maybe ImportDecl -> Maybe (Either ImportDecl MethodDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ImportDecl
import')

lookupMethod :: Name -> Semantic (Maybe (Either ImportDecl MethodDecl))
lookupMethod :: Name -> Semantic (Maybe (Either ImportDecl MethodDecl))
lookupMethod Name
name = do
  Name -> SymbolTable -> Maybe (Either ImportDecl MethodDecl)
lookup Name
name (SymbolTable -> Maybe (Either ImportDecl MethodDecl))
-> Semantic SymbolTable
-> Semantic (Maybe (Either ImportDecl MethodDecl))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Semantic SymbolTable
getSymbolTable'
  where
    lookup :: Name -> SymbolTable -> Maybe (Either ImportDecl MethodDecl)
lookup Name
name SymbolTable
table = (Name -> SymbolTable -> Maybe (Either ImportDecl MethodDecl)
lookupLocalMethodFromST Name
name SymbolTable
table) Maybe (Either ImportDecl MethodDecl)
-> Maybe (Either ImportDecl MethodDecl)
-> Maybe (Either ImportDecl MethodDecl)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (SymbolTable -> Maybe SymbolTable
parent SymbolTable
table Maybe SymbolTable
-> (SymbolTable -> Maybe (Either ImportDecl MethodDecl))
-> Maybe (Either ImportDecl MethodDecl)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> SymbolTable -> Maybe (Either ImportDecl MethodDecl)
lookup Name
name)

lookupMethod' :: Name -> Semantic (Either ImportDecl MethodDecl)
lookupMethod' :: Name -> Semantic (Either ImportDecl MethodDecl)
lookupMethod' Name
name = do
  Maybe (Either ImportDecl MethodDecl)
m <- Name -> Semantic (Maybe (Either ImportDecl MethodDecl))
lookupMethod Name
name
  case Maybe (Either ImportDecl MethodDecl)
m of
    Maybe (Either ImportDecl MethodDecl)
Nothing -> Name -> Semantic (Either ImportDecl MethodDecl)
forall a. Name -> Semantic a
throwSemanticException (Name -> Semantic (Either ImportDecl MethodDecl))
-> Name -> Semantic (Either ImportDecl MethodDecl)
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"Method " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext Format Name (Name -> Name)
-> Format Name Name -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
" not found") Name
name
    Just Either ImportDecl MethodDecl
m' -> Either ImportDecl MethodDecl
-> Semantic (Either ImportDecl MethodDecl)
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return Either ImportDecl MethodDecl
m'

{- Add variables and methods -}

addVariableDef :: FieldDecl -> Semantic ()
addVariableDef :: FieldDecl -> Semantic ()
addVariableDef FieldDecl
def = do
  SymbolTable
localST <- Semantic SymbolTable
getSymbolTable'
  -- Semantic[1]
  let nm :: Name
nm = Getting Name FieldDecl Name -> FieldDecl -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name FieldDecl Name
#name FieldDecl
def
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Maybe (Either Argument FieldDecl) -> Bool
forall a. Maybe a -> Bool
isJust (Name -> SymbolTable -> Maybe (Either Argument FieldDecl)
lookupLocalVariableFromST Name
nm SymbolTable
localST))
    (Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"duplicate definition for variable " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext) Name
nm)
  let variableSymbols' :: Map Name FieldDecl
variableSymbols' = Name -> FieldDecl -> Map Name FieldDecl -> Map Name FieldDecl
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
nm FieldDecl
def (SymbolTable -> Map Name FieldDecl
variableSymbols SymbolTable
localST)
      newST :: SymbolTable
newST = SymbolTable
localST {$sel:variableSymbols:SymbolTable :: Map Name FieldDecl
variableSymbols = Map Name FieldDecl
variableSymbols'}
  -- Semantic[4]
  case FieldDecl
def of
    (FieldDecl Name
_ (ArrayType Type
_ Int64
sz) Range
_)
      | Int64
sz Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
0 ->
          Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"Invalid size of array " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext) Name
nm
    FieldDecl
_ -> () -> Semantic ()
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  SymbolTable -> Semantic ()
updateSymbolTable SymbolTable
newST

addImportDef :: ImportDecl -> Semantic ()
addImportDef :: ImportDecl -> Semantic ()
addImportDef ImportDecl
def = do
  SymbolTable
localST <- Semantic SymbolTable
getSymbolTable'
  Map Name ImportDecl
importTable <- Semantic (Map Name ImportDecl)
getLocalImports'
  -- Semantic[1]
  let nm :: Name
nm = Getting Name ImportDecl Name -> ImportDecl -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name ImportDecl Name
#name ImportDecl
def
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Maybe ImportDecl -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ImportDecl -> Bool) -> Maybe ImportDecl -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> Map Name ImportDecl -> Maybe ImportDecl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
nm Map Name ImportDecl
importTable)
    (Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"duplicate import " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext) Name
nm)
  let importSymbols' :: Map Name ImportDecl
importSymbols' = Name -> ImportDecl -> Map Name ImportDecl -> Map Name ImportDecl
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
nm ImportDecl
def Map Name ImportDecl
importTable
      newST :: SymbolTable
newST = SymbolTable
localST {$sel:importSymbols:SymbolTable :: Maybe (Map Name ImportDecl)
importSymbols = Map Name ImportDecl -> Maybe (Map Name ImportDecl)
forall a. a -> Maybe a
Just Map Name ImportDecl
importSymbols'}
  SymbolTable -> Semantic ()
updateSymbolTable SymbolTable
newST

addMethodDef :: MethodDecl -> Semantic ()
addMethodDef :: MethodDecl -> Semantic ()
addMethodDef MethodDecl
def = do
  SymbolTable
localST <- Semantic SymbolTable
getSymbolTable'
  Map Name MethodDecl
methodTable <- Semantic (Map Name MethodDecl)
getLocalMethods'
  -- Semantic[1]
  let nm :: Name
nm = MethodDecl
def MethodDecl -> Getting Name MethodDecl Name -> Name
forall s a. s -> Getting a s a -> a
^. ((MethodSig -> Const Name MethodSig)
-> MethodDecl -> Const Name MethodDecl
#sig ((MethodSig -> Const Name MethodSig)
 -> MethodDecl -> Const Name MethodDecl)
-> ((Name -> Const Name Name) -> MethodSig -> Const Name MethodSig)
-> Getting Name MethodDecl Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Const Name Name) -> MethodSig -> Const Name MethodSig
#name)
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Maybe (Either ImportDecl MethodDecl) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Either ImportDecl MethodDecl) -> Bool)
-> Maybe (Either ImportDecl MethodDecl) -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> SymbolTable -> Maybe (Either ImportDecl MethodDecl)
lookupLocalMethodFromST Name
nm SymbolTable
localST)
    (Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"duplicate definition for method " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext) Name
nm)
  let methodSymbols' :: Map Name MethodDecl
methodSymbols' = Name -> MethodDecl -> Map Name MethodDecl -> Map Name MethodDecl
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
nm MethodDecl
def Map Name MethodDecl
methodTable
      newST :: SymbolTable
newST = SymbolTable
localST {$sel:methodSymbols:SymbolTable :: Maybe (Map Name MethodDecl)
methodSymbols = Map Name MethodDecl -> Maybe (Map Name MethodDecl)
forall a. a -> Maybe a
Just Map Name MethodDecl
methodSymbols'}
  SymbolTable -> Semantic ()
updateSymbolTable SymbolTable
newST

{-
  Helper methods to do semantic checks.
-}

-- Semantic[8] and Semantic[9]
checkReturnType :: Maybe Expr -> Semantic ()
checkReturnType :: Maybe Expr -> Semantic ()
checkReturnType Maybe Expr
Nothing = do
  (MethodSig Name
method Maybe Type
tpe [Argument]
_) <- Semantic MethodSig
getMethodSignature'
  case Maybe Type
tpe of
    Just Type
t -> Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Type -> Name) -> Name -> Type -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Type -> Name) (Name -> Type -> Name)
"Method " Format (Name -> Type -> Name) (Name -> Type -> Name)
-> Format Name (Name -> Type -> Name)
-> Format Name (Name -> Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Type -> Name) (Name -> Type -> Name)
forall r. Format r (Name -> r)
stext Format (Type -> Name) (Name -> Type -> Name)
-> Format Name (Type -> Name) -> Format Name (Name -> Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Type -> Name) (Type -> Name)
" expects return type of " Format (Type -> Name) (Type -> Name)
-> Format Name (Type -> Name) -> Format Name (Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Type -> Name)
forall a r. Show a => Format r (a -> r)
shown Format Name (Type -> Name)
-> Format Name Name -> Format Name (Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
"!") Name
method Type
t
    Maybe Type
_ -> () -> Semantic ()
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkReturnType (Just Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
tpe'}) = do
  (MethodSig Name
method Maybe Type
tpe [Argument]
_) <- Semantic MethodSig
getMethodSignature'
  case Maybe Type
tpe of
    Maybe Type
Nothing -> Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"Method " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext Format Name (Name -> Name)
-> Format Name Name -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
" expects no return value!") Name
method
    Maybe Type
t
      | Maybe Type
t Maybe Type -> Maybe Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Type
tpe ->
          Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$
            Format Name (Name -> Maybe Type -> Type -> Name)
-> Name -> Maybe Type -> Type -> Name
forall a. Format Name a -> a
sformat
              (Format
  (Name -> Maybe Type -> Type -> Name)
  (Name -> Maybe Type -> Type -> Name)
"Method " Format
  (Name -> Maybe Type -> Type -> Name)
  (Name -> Maybe Type -> Type -> Name)
-> Format Name (Name -> Maybe Type -> Type -> Name)
-> Format Name (Name -> Maybe Type -> Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format
  (Maybe Type -> Type -> Name) (Name -> Maybe Type -> Type -> Name)
forall r. Format r (Name -> r)
stext Format
  (Maybe Type -> Type -> Name) (Name -> Maybe Type -> Type -> Name)
-> Format Name (Maybe Type -> Type -> Name)
-> Format Name (Name -> Maybe Type -> Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Maybe Type -> Type -> Name) (Maybe Type -> Type -> Name)
" expects return type of " Format (Maybe Type -> Type -> Name) (Maybe Type -> Type -> Name)
-> Format Name (Maybe Type -> Type -> Name)
-> Format Name (Maybe Type -> Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Type -> Name) (Maybe Type -> Type -> Name)
forall a r. Show a => Format r (a -> r)
shown Format (Type -> Name) (Maybe Type -> Type -> Name)
-> Format Name (Type -> Name)
-> Format Name (Maybe Type -> Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Type -> Name) (Type -> Name)
", but got " Format (Type -> Name) (Type -> Name)
-> Format Name (Type -> Name) -> Format Name (Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Type -> Name)
forall a r. Show a => Format r (a -> r)
shown Format Name (Type -> Name)
-> Format Name Name -> Format Name (Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
" instead.")
              Name
method
              Maybe Type
tpe
              Type
tpe'
    Maybe Type
_ -> () -> Semantic ()
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Check if content of lit is a valid int64.
-- lit should be striped of whitespace from both ends and contains only
-- numeric characters or the minus sign '-'.
-- -9223372036854775808 ≤ x ≤ 9223372036854775807
-- checks Semantic[22].
checkInt64Literal :: Text -> Semantic Int64
checkInt64Literal :: Name -> Semantic Int64
checkInt64Literal Name
lit = do
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Bool
T.null Name
lit) (Semantic () -> Semantic ()) -> Semantic () -> Semantic ()
forall a b. (a -> b) -> a -> b
$
    Name -> Semantic ()
forall a. Name -> Semantic a
throwSemanticException Name
"Cannot parse int literal from an empty token!"
  let isNegative :: Bool
isNegative = (HasCallStack => Name -> Char
Name -> Char
T.head Name
lit) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
  -- unless
  --   ( (isNegative && (T.drop 1 lit) <= "9223372036854775808")
  --       || (not isNegative && lit <= "9223372036854775807")
  --   )
  --   throwSemanticException
  --   $ printf "Int literal %s is out of bound" lit
  case Reader Int64
forall a. Integral a => Reader a
T.decimal Name
lit of
    Right (Int64
n, Name
_) -> Int64 -> Semantic Int64
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
n
    Left String
msg -> Name -> Semantic Int64
forall a. Name -> Semantic a
throwSemanticException (Name -> Semantic Int64) -> Name -> Semantic Int64
forall a b. (a -> b) -> a -> b
$ Format Name (String -> Name) -> String -> Name
forall a. Format Name a -> a
sformat (Format (String -> Name) (String -> Name)
"cannot parse int literal " Format (String -> Name) (String -> Name)
-> Format Name (String -> Name) -> Format Name (String -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (String -> Name)
forall r. Format r (String -> r)
string) String
msg

checkBoolLiteral :: Text -> Semantic Bool
checkBoolLiteral :: Name -> Semantic Bool
checkBoolLiteral Name
lit
  | Name
lit Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
"true" = Bool -> Semantic Bool
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  | Name
lit Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
"false" = Bool -> Semantic Bool
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  | Bool
otherwise = do
      Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"error parsing bool literal from string " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext) Name
lit
      Bool -> Semantic Bool
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

checkCharLiteral :: Text -> Semantic Char
checkCharLiteral :: Name -> Semantic Char
checkCharLiteral Name
lit = do
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Name -> ScopeID
T.length Name
lit ScopeID -> ScopeID -> Bool
forall a. Ord a => a -> a -> Bool
> ScopeID
1 Bool -> Bool -> Bool
|| Name -> Bool
T.null Name
lit)
    (Name -> Semantic ()
forall a. Name -> Semantic a
throwSemanticException (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"cannot parse char literal from string " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext) Name
lit)
  Char -> Semantic Char
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Semantic Char) -> Char -> Semantic Char
forall a b. (a -> b) -> a -> b
$ HasCallStack => Name -> Char
Name -> Char
T.head Name
lit

isInsideLoop :: Semantic Bool
isInsideLoop :: Semantic Bool
isInsideLoop = do
  SymbolTable -> Bool
lookup (SymbolTable -> Bool) -> Semantic SymbolTable -> Semantic Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Semantic SymbolTable
getSymbolTable'
  where
    lookup :: SymbolTable -> Bool
lookup SymbolTable {$sel:blockType:SymbolTable :: SymbolTable -> BlockType
blockType = BlockType
ForBlock} = Bool
True
    lookup SymbolTable {$sel:blockType:SymbolTable :: SymbolTable -> BlockType
blockType = BlockType
WhileBlock} = Bool
True
    lookup SymbolTable {$sel:blockType:SymbolTable :: SymbolTable -> BlockType
blockType = BlockType
IfBlock, $sel:parent:SymbolTable :: SymbolTable -> Maybe SymbolTable
parent = Maybe SymbolTable
Nothing} = Bool
False
    lookup SymbolTable {$sel:blockType:SymbolTable :: SymbolTable -> BlockType
blockType = BlockType
IfBlock, $sel:parent:SymbolTable :: SymbolTable -> Maybe SymbolTable
parent = Just SymbolTable
p} = SymbolTable -> Bool
lookup SymbolTable
p

{-
  Methods to generate ir piece by piece.
-}

irgenRoot :: P.Program -> Semantic ASTRoot
irgenRoot :: Program -> Semantic ASTRoot
irgenRoot (P.Program [Located ImportDecl]
imports [Located FieldDecl]
fields [Located MethodDecl]
methods) = do
  [ImportDecl]
imports' <- [Located ImportDecl] -> Semantic [ImportDecl]
irgenImports [Located ImportDecl]
imports
  [FieldDecl]
variables' <- [Located FieldDecl] -> Semantic [FieldDecl]
irgenFieldDecls [Located FieldDecl]
fields
  [MethodDecl]
methods' <- [Located MethodDecl] -> Semantic [MethodDecl]
irgenMethodDecls [Located MethodDecl]
methods

  -- check method "main"
  -- Semantic[3]
  SymbolTable
globalTable <- Semantic SymbolTable
getGlobalSymbolTable'
  let main :: Maybe MethodDecl
main = do
        Map Name MethodDecl
methodSyms <- SymbolTable -> Maybe (Map Name MethodDecl)
methodSymbols SymbolTable
globalTable
        Name -> Map Name MethodDecl -> Maybe MethodDecl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
mainMethodName Map Name MethodDecl
methodSyms
  Maybe MethodDecl
mainDecl <- Maybe MethodDecl -> Semantic (Maybe MethodDecl)
forall {a}. Maybe a -> Semantic (Maybe a)
checkMainExist Maybe MethodDecl
main
  case Maybe MethodDecl
mainDecl Maybe MethodDecl
-> (MethodDecl -> Maybe MethodSig) -> Maybe MethodSig
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MethodSig -> Maybe MethodSig
forall a. a -> Maybe a
Just (MethodSig -> Maybe MethodSig)
-> (MethodDecl -> MethodSig) -> MethodDecl -> Maybe MethodSig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting MethodSig MethodDecl MethodSig -> MethodDecl -> MethodSig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting MethodSig MethodDecl MethodSig
#sig of
    Just (MethodSig Name
_ Maybe Type
retType [Argument]
args) -> do
      Maybe Type -> Semantic ()
forall {a}. Show a => Maybe a -> Semantic ()
checkMainRetType Maybe Type
retType
      [Argument] -> Semantic ()
forall {t :: * -> *} {a}. Foldable t => t a -> Semantic ()
checkMainArgsType [Argument]
args
    Maybe MethodSig
Nothing -> () -> Semantic ()
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  ASTRoot -> Semantic ASTRoot
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (ASTRoot -> Semantic ASTRoot) -> ASTRoot -> Semantic ASTRoot
forall a b. (a -> b) -> a -> b
$ [ImportDecl] -> [FieldDecl] -> [MethodDecl] -> ASTRoot
ASTRoot [ImportDecl]
imports' [FieldDecl]
variables' [MethodDecl]
methods'
  where
    checkMainExist :: Maybe a -> Semantic (Maybe a)
checkMainExist Maybe a
main =
      case Maybe a
main of
        Maybe a
Nothing -> do
          Name -> Semantic ()
addSemanticError Name
"Method \"main\" not found!"
          Maybe a -> Semantic (Maybe a)
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        Just a
decl -> Maybe a -> Semantic (Maybe a)
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> Semantic (Maybe a)) -> Maybe a -> Semantic (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
decl
    checkMainRetType :: Maybe a -> Semantic ()
checkMainRetType Maybe a
tpe = case Maybe a
tpe of
      Maybe a
Nothing -> () -> Semantic ()
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just a
tpe ->
        Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$
          Format Name (a -> Name) -> a -> Name
forall a. Format Name a -> a
sformat
            (Format (a -> Name) (a -> Name)
"Method \"main\" should have return type of void, got " Format (a -> Name) (a -> Name)
-> Format Name (a -> Name) -> Format Name (a -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (a -> Name)
forall a r. Show a => Format r (a -> r)
shown Format Name (a -> Name)
-> Format Name Name -> Format Name (a -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
" instead.")
            a
tpe
    checkMainArgsType :: t a -> Semantic ()
checkMainArgsType t a
args =
      Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        (t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
args)
        (Name -> Semantic ()
addSemanticError Name
"Method \"main\" should have no argument.")

irgenType :: P.Type -> Type
irgenType :: Type -> Type
irgenType Type
P.IntType = Type
IntType
irgenType Type
P.BoolType = Type
BoolType

irgenImports :: [SL.Located P.ImportDecl] -> Semantic [ImportDecl]
irgenImports :: [Located ImportDecl] -> Semantic [ImportDecl]
irgenImports [] = [ImportDecl] -> Semantic [ImportDecl]
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return []
irgenImports ((SL.LocatedAt Range
range (P.ImportDecl Name
id)) : [Located ImportDecl]
rest) = do
  let importSymbol :: ImportDecl
importSymbol = Name -> Range -> ImportDecl
ImportDecl Name
id Range
range
  ImportDecl -> Semantic ()
addImportDef ImportDecl
importSymbol
  -- TODO: This kind of recursions potentially lead to stack overflows.
  -- For now it should do the job. Will try to fix in the future.
  [ImportDecl]
rest' <- [Located ImportDecl] -> Semantic [ImportDecl]
irgenImports [Located ImportDecl]
rest
  [ImportDecl] -> Semantic [ImportDecl]
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ImportDecl] -> Semantic [ImportDecl])
-> [ImportDecl] -> Semantic [ImportDecl]
forall a b. (a -> b) -> a -> b
$ ImportDecl
importSymbol ImportDecl -> [ImportDecl] -> [ImportDecl]
forall a. a -> [a] -> [a]
: [ImportDecl]
rest'

irgenFieldDecls :: [SL.Located P.FieldDecl] -> Semantic [FieldDecl]
irgenFieldDecls :: [Located FieldDecl] -> Semantic [FieldDecl]
irgenFieldDecls [] = [FieldDecl] -> Semantic [FieldDecl]
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return []
irgenFieldDecls ((SL.LocatedAt Range
pos FieldDecl
decl) : [Located FieldDecl]
rest) = do
  [FieldDecl]
fields <- [Semantic FieldDecl] -> Semantic [FieldDecl]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Semantic FieldDecl] -> Semantic [FieldDecl])
-> [Semantic FieldDecl] -> Semantic [FieldDecl]
forall a b. (a -> b) -> a -> b
$ FieldDecl -> [Semantic FieldDecl]
convertFieldDecl FieldDecl
decl
  [FieldDecl]
vars <- [FieldDecl] -> Semantic [FieldDecl]
addVariables [FieldDecl]
fields
  [FieldDecl]
rest' <- [Located FieldDecl] -> Semantic [FieldDecl]
irgenFieldDecls [Located FieldDecl]
rest
  [FieldDecl] -> Semantic [FieldDecl]
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return ([FieldDecl]
vars [FieldDecl] -> [FieldDecl] -> [FieldDecl]
forall a. [a] -> [a] -> [a]
++ [FieldDecl]
rest')
  where
    convertFieldDecl :: FieldDecl -> [Semantic FieldDecl]
convertFieldDecl (P.FieldDecl Type
tpe [Located FieldElem]
elems) =
      [Located FieldElem]
elems [Located FieldElem]
-> (Located FieldElem -> Semantic FieldDecl)
-> [Semantic FieldDecl]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Located FieldElem
e -> case Located FieldElem
e of
        (SL.LocatedAt Range
range (P.ScalarField Name
id)) -> do
          Range -> Semantic ()
updateCurrentRange Range
range
          FieldDecl -> Semantic FieldDecl
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldDecl -> Semantic FieldDecl)
-> FieldDecl -> Semantic FieldDecl
forall a b. (a -> b) -> a -> b
$ Name -> Type -> Range -> FieldDecl
FieldDecl Name
id (Type -> Type
irgenType Type
tpe) Range
pos
        (SL.LocatedAt Range
range (P.VectorField Name
id Name
size)) -> do
          Range -> Semantic ()
updateCurrentRange Range
pos
          Int64
sz <- Name -> Semantic Int64
checkInt64Literal Name
size
          FieldDecl -> Semantic FieldDecl
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldDecl -> Semantic FieldDecl)
-> FieldDecl -> Semantic FieldDecl
forall a b. (a -> b) -> a -> b
$ Name -> Type -> Range -> FieldDecl
FieldDecl Name
id (Type -> Int64 -> Type
ArrayType (Type -> Type
irgenType Type
tpe) Int64
sz) Range
pos
    addVariables :: [FieldDecl] -> Semantic [FieldDecl]
addVariables [] = [FieldDecl] -> Semantic [FieldDecl]
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    addVariables (FieldDecl
v : [FieldDecl]
vs) = do
      FieldDecl -> Semantic ()
addVariableDef FieldDecl
v
      [FieldDecl]
vs' <- [FieldDecl] -> Semantic [FieldDecl]
addVariables [FieldDecl]
vs
      [FieldDecl] -> Semantic [FieldDecl]
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldDecl
v FieldDecl -> [FieldDecl] -> [FieldDecl]
forall a. a -> [a] -> [a]
: [FieldDecl]
vs')

irgenMethodDecls :: [SL.Located P.MethodDecl] -> Semantic [MethodDecl]
irgenMethodDecls :: [Located MethodDecl] -> Semantic [MethodDecl]
irgenMethodDecls [] = [MethodDecl] -> Semantic [MethodDecl]
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return []
irgenMethodDecls ((SL.LocatedAt Range
range MethodDecl
decl) : [Located MethodDecl]
rest) = do
  Range -> Semantic ()
updateCurrentRange Range
range
  MethodDecl
method <- MethodDecl -> Semantic MethodDecl
convertMethodDecl MethodDecl
decl
  -- Semantic[8] and Semantic[9]
  -- checkMethod method
  MethodDecl -> Semantic ()
addMethodDef MethodDecl
method
  [MethodDecl]
rest' <- [Located MethodDecl] -> Semantic [MethodDecl]
irgenMethodDecls [Located MethodDecl]
rest
  [MethodDecl] -> Semantic [MethodDecl]
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (MethodDecl
method MethodDecl -> [MethodDecl] -> [MethodDecl]
forall a. a -> [a] -> [a]
: [MethodDecl]
rest')
  where
    convertMethodDecl :: MethodDecl -> Semantic MethodDecl
convertMethodDecl (P.MethodDecl Name
id Maybe Type
returnType [Located Argument]
arguments Block
block) = do
      let sig :: MethodSig
sig = Name -> Maybe Type -> [Argument] -> MethodSig
MethodSig Name
id (Type -> Type
irgenType (Type -> Type) -> Maybe Type -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Type
returnType) [Argument]
args
      Block
block <- BlockType -> Maybe MethodSig -> Block -> Semantic Block
irgenBlock BlockType
MethodBlock (MethodSig -> Maybe MethodSig
forall a. a -> Maybe a
Just MethodSig
sig) Block
block
      MethodDecl -> Semantic MethodDecl
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (MethodDecl -> Semantic MethodDecl)
-> MethodDecl -> Semantic MethodDecl
forall a b. (a -> b) -> a -> b
$ MethodSig -> Block -> Range -> MethodDecl
MethodDecl MethodSig
sig Block
block Range
range
      where
        args :: [Argument]
args =
          [Located Argument]
arguments [Located Argument] -> (Located Argument -> Argument) -> [Argument]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(SL.LocatedAt Range
range (P.Argument Name
id Type
tpe)) ->
            Name -> Type -> Range -> Argument
Argument Name
id (Type -> Type
irgenType Type
tpe) Range
range

irgenBlock :: BlockType -> Maybe MethodSig -> P.Block -> Semantic Block
irgenBlock :: BlockType -> Maybe MethodSig -> Block -> Semantic Block
irgenBlock BlockType
blockType Maybe MethodSig
sig (P.Block [Located FieldDecl]
fieldDecls [Located Statement]
statements) = do
  ScopeID
nextID <- BlockType -> Maybe MethodSig -> Semantic ScopeID
enterScope BlockType
blockType Maybe MethodSig
sig
  [FieldDecl]
fields <- [Located FieldDecl] -> Semantic [FieldDecl]
irgenFieldDecls [Located FieldDecl]
fieldDecls
  [Statement]
stmts <- [Located Statement] -> Semantic [Statement]
irgenStatements [Located Statement]
statements
  let block :: Block
block = [FieldDecl] -> [Statement] -> ScopeID -> Block
Block [FieldDecl]
fields [Statement]
stmts ScopeID
nextID
  Semantic ()
exitScope
  Block -> Semantic Block
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return Block
block

irgenLocation :: P.Location -> Semantic Location
irgenLocation :: Location -> Semantic Location
irgenLocation (P.ScalarLocation Name
id) = do
  -- Semantic[10] (checked in lookupVariable')
  Either Argument FieldDecl
def <- Name -> Semantic (Either Argument FieldDecl)
lookupVariable' Name
id
  Range
range <- Semantic Range
getCurrentRange
  let tpe :: Type
tpe = (Argument -> Type)
-> (FieldDecl -> Type) -> Either Argument FieldDecl -> Type
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(Argument Name
_ Type
tpe' Range
_) -> Type
tpe') (\(FieldDecl Name
_ Type
tpe' Range
_) -> Type
tpe') Either Argument FieldDecl
def
  let sz :: Maybe Int64
sz =
        (Argument -> Maybe Int64)
-> (FieldDecl -> Maybe Int64)
-> Either Argument FieldDecl
-> Maybe Int64
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          (Maybe Int64 -> Argument -> Maybe Int64
forall a b. a -> b -> a
const Maybe Int64
forall a. Maybe a
Nothing)
          ( \(FieldDecl Name
_ Type
tpe Range
_) -> case Type
tpe of
              (ArrayType Type
_ Int64
sz') -> Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
sz'
              Type
_ -> Maybe Int64
forall a. Maybe a
Nothing
          )
          Either Argument FieldDecl
def
  -- Semantic[12]
  case Maybe Int64
sz of
    Maybe Int64
Nothing -> Location -> Semantic Location
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Location -> Semantic Location) -> Location -> Semantic Location
forall a b. (a -> b) -> a -> b
$ Name
-> Maybe Expr
-> Either Argument FieldDecl
-> Type
-> Range
-> Location
Location Name
id Maybe Expr
forall a. Maybe a
Nothing Either Argument FieldDecl
def Type
tpe Range
range
    Just Int64
v -> Location -> Semantic Location
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Location -> Semantic Location) -> Location -> Semantic Location
forall a b. (a -> b) -> a -> b
$ Name
-> Maybe Expr
-> Either Argument FieldDecl
-> Type
-> Range
-> Location
Location Name
id Maybe Expr
forall a. Maybe a
Nothing Either Argument FieldDecl
def (Type -> Int64 -> Type
ArrayType Type
tpe Int64
v) Range
range
irgenLocation (P.VectorLocation Name
id Located Expr
expr) = do
  expr' :: Expr
expr'@(Expr Expr_
_ Type
indexTpe Range
_) <- Located Expr -> Semantic Expr
irgenExpr Located Expr
expr
  -- Semantic[10] (checked in lookupVariable')
  Either Argument FieldDecl
def <- Name -> Semantic (Either Argument FieldDecl)
lookupVariable' Name
id
  Range
range <- Semantic Range
getCurrentRange
  let tpe :: Type
tpe = (Argument -> Type)
-> (FieldDecl -> Type) -> Either Argument FieldDecl -> Type
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(Argument Name
_ Type
tpe' Range
_) -> Type
tpe') (\(FieldDecl Name
_ Type
tpe' Range
_) -> Type
tpe') Either Argument FieldDecl
def
  let sz :: Maybe Int64
sz =
        (Argument -> Maybe Int64)
-> (FieldDecl -> Maybe Int64)
-> Either Argument FieldDecl
-> Maybe Int64
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          (Maybe Int64 -> Argument -> Maybe Int64
forall a b. a -> b -> a
const Maybe Int64
forall a. Maybe a
Nothing)
          ( \(FieldDecl Name
_ Type
tpe Range
_) -> case Type
tpe of
              (ArrayType Type
_ Int64
sz') -> Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
sz'
              Type
_ -> Maybe Int64
forall a. Maybe a
Nothing
          )
          Either Argument FieldDecl
def
  -- Semantic[12]
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Type
indexTpe Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
IntType) (Name -> Semantic ()
addSemanticError Name
"Index must be of int type!")
  case Maybe Int64
sz of
    Maybe Int64
Nothing -> do
      Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$
        Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"Cannot access index of scalar variable " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext Format Name (Name -> Name)
-> Format Name Name -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
".") Name
id
      Location -> Semantic Location
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Location -> Semantic Location) -> Location -> Semantic Location
forall a b. (a -> b) -> a -> b
$ Name
-> Maybe Expr
-> Either Argument FieldDecl
-> Type
-> Range
-> Location
Location Name
id Maybe Expr
forall a. Maybe a
Nothing Either Argument FieldDecl
def Type
tpe Range
range
    Just Int64
_ -> Location -> Semantic Location
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Location -> Semantic Location) -> Location -> Semantic Location
forall a b. (a -> b) -> a -> b
$ Name
-> Maybe Expr
-> Either Argument FieldDecl
-> Type
-> Range
-> Location
Location Name
id (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
expr') Either Argument FieldDecl
def Type
tpe Range
range

checkAssignType :: Type -> Type -> Bool
checkAssignType :: Type -> Type -> Bool
checkAssignType (ArrayType Type
tpe Int64
_) Type
exprType = Type
tpe Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
exprType
checkAssignType Type
locType Type
exprType = Type
locType Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
exprType

recordSymbolWrite :: Location -> Semantic ()
recordSymbolWrite :: Location -> Semantic ()
recordSymbolWrite Location
loc = do
  ScopeID
sid <- Semantic ScopeID
getCurrentScopeID
  let name :: Name
name = Location
loc Location -> Getting Name Location Name -> Name
forall s a. s -> Getting a s a -> a
^. Getting Name Location Name
#name
  ScopeID
varScope <- Name -> Semantic ScopeID
lookupVariableScope' Name
name
  case Either Argument FieldDecl -> Type
typeOfDef (Location
loc Location
-> Getting
     (Either Argument FieldDecl) Location (Either Argument FieldDecl)
-> Either Argument FieldDecl
forall s a. s -> Getting a s a -> a
^. Getting
  (Either Argument FieldDecl) Location (Either Argument FieldDecl)
#variableDef) of
    Type
Void -> () -> Semantic ()
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ArrayType Type
_ Int64
_ -> () -> Semantic ()
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Ptr Type
_ -> () -> Semantic ()
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Type
_ScalarType -> do
      let newSet :: Set (ScopeID, Name)
newSet = [(ScopeID, Name)] -> Set (ScopeID, Name)
forall a. Ord a => [a] -> Set a
Set.fromList ([(ScopeID, Name)] -> Set (ScopeID, Name))
-> [(ScopeID, Name)] -> Set (ScopeID, Name)
forall a b. (a -> b) -> a -> b
$ ((ScopeID, Name) -> Bool) -> [(ScopeID, Name)] -> [(ScopeID, Name)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ScopeID
s, Name
_) -> ScopeID
s ScopeID -> ScopeID -> Bool
forall a. Eq a => a -> a -> Bool
/= ScopeID
0) [(ScopeID
varScope, Name
name)]
      #symbolWrites %= Map.insertWith Set.union sid newSet

irgenAssign :: P.Location -> P.AssignExpr -> Semantic Assignment
irgenAssign :: Location -> AssignExpr -> Semantic Assignment
irgenAssign Location
loc (P.AssignExpr Name
op Located Expr
expr) = do
  loc' :: Location
loc'@Location {$sel:tpe:Location :: Location -> Type
tpe = Type
tpe} <- Location -> Semantic Location
irgenLocation Location
loc
  expr' :: Expr
expr'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
tpe'} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
expr
  Range
range <- Semantic Range
getCurrentRange
  -- Semantic[19]
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
    (Type -> Type -> Bool
checkAssignType Type
tpe Type
tpe')
    (Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$ Format Name (Type -> Type -> Name) -> Type -> Type -> Name
forall a. Format Name a -> a
sformat (Format (Type -> Type -> Name) (Type -> Type -> Name)
"Assign statement has different types: " Format (Type -> Type -> Name) (Type -> Type -> Name)
-> Format Name (Type -> Type -> Name)
-> Format Name (Type -> Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Type -> Name) (Type -> Type -> Name)
forall a r. Show a => Format r (a -> r)
shown Format (Type -> Name) (Type -> Type -> Name)
-> Format Name (Type -> Name) -> Format Name (Type -> Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Type -> Name) (Type -> Name)
" and " Format (Type -> Name) (Type -> Name)
-> Format Name (Type -> Name) -> Format Name (Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Type -> Name)
forall a r. Show a => Format r (a -> r)
shown Format Name (Type -> Name)
-> Format Name Name -> Format Name (Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
"") Type
tpe Type
tpe')
  let op' :: AssignOp
op' = Name -> AssignOp
parseAssignOp Name
op
  -- Semantic[20]
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    ((AssignOp
op' AssignOp -> AssignOp -> Bool
forall a. Eq a => a -> a -> Bool
== AssignOp
IncAssign Bool -> Bool -> Bool
|| AssignOp
op' AssignOp -> AssignOp -> Bool
forall a. Eq a => a -> a -> Bool
== AssignOp
DecAssign) Bool -> Bool -> Bool
&& (Type
tpe Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
IntType))
    (Name -> Semantic ()
addSemanticError Name
"Inc or dec assign only works with int type!")
  -- Record symbol write to ease cfg construction
  Location -> Semantic ()
recordSymbolWrite Location
loc'
  Assignment -> Semantic Assignment
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Assignment -> Semantic Assignment)
-> Assignment -> Semantic Assignment
forall a b. (a -> b) -> a -> b
$ Location -> AssignOp -> Maybe Expr -> Range -> Assignment
Assignment Location
loc' AssignOp
op' (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
expr') Range
range
irgenAssign Location
loc (P.IncrementExpr Name
op) = do
  loc' :: Location
loc'@Location {$sel:tpe:Location :: Location -> Type
tpe = Type
tpe} <- Location -> Semantic Location
irgenLocation Location
loc
  Range
range <- Semantic Range
getCurrentRange
  let op' :: AssignOp
op' = Name -> AssignOp
parseAssignOp Name
op
  -- Semantic[20]
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Type
tpe Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
IntType) (Name -> Semantic ()
addSemanticError Name
"Inc or dec operator only works on int type!")
  -- Record symbol write to ease cfg construction
  Location -> Semantic ()
recordSymbolWrite Location
loc'
  Assignment -> Semantic Assignment
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Assignment -> Semantic Assignment)
-> Assignment -> Semantic Assignment
forall a b. (a -> b) -> a -> b
$ Location -> AssignOp -> Maybe Expr -> Range -> Assignment
Assignment Location
loc' AssignOp
op' Maybe Expr
forall a. Maybe a
Nothing Range
range

irgenStatements :: [SL.Located P.Statement] -> Semantic [Statement]
irgenStatements :: [Located Statement] -> Semantic [Statement]
irgenStatements [] = [Statement] -> Semantic [Statement]
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return []
irgenStatements ((SL.LocatedAt Range
range Statement
s) : [Located Statement]
xs) = do
  Range -> Semantic ()
updateCurrentRange Range
range
  Statement
s' <- Statement -> Semantic Statement
irgenStmt Statement
s
  [Statement]
xs' <- [Located Statement] -> Semantic [Statement]
irgenStatements [Located Statement]
xs
  [Statement] -> Semantic [Statement]
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Statement
s' Statement -> [Statement] -> [Statement]
forall a. a -> [a] -> [a]
: [Statement]
xs')

irgenMethod :: P.MethodCall -> Semantic MethodCall
irgenMethod :: MethodCall -> Semantic MethodCall
irgenMethod (P.MethodCall Name
method [Located ImportArg]
args') = do
  -- Semantic[2] and Semantic[11]
  Maybe (Either ImportDecl MethodDecl)
decl' <- Name -> Semantic (Maybe (Either ImportDecl MethodDecl))
lookupMethod Name
method
  [Expr]
argsTyped <- (Located ImportArg -> Semantic Expr)
-> [Located ImportArg] -> Semantic [Expr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Located ImportArg -> Semantic Expr
irgenImportArg [Located ImportArg]
args'
  Range
range <- Semantic Range
getCurrentRange
  case Maybe (Either ImportDecl MethodDecl)
decl' of
    Maybe (Either ImportDecl MethodDecl)
Nothing -> do
      Maybe MethodSig
currentMethod <- Semantic (Maybe MethodSig)
getMethodSignature
      case Maybe MethodSig
currentMethod of
        -- Recursive method calling itself
        (Just (MethodSig Name
name Maybe Type
_ [Argument]
formal)) | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
method -> do
          [Argument] -> [Expr] -> Semantic ()
checkCallingSemantics [Argument]
formal [Expr]
argsTyped
          MethodCall -> Semantic MethodCall
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (MethodCall -> Semantic MethodCall)
-> MethodCall -> Semantic MethodCall
forall a b. (a -> b) -> a -> b
$ Name -> [Expr] -> Range -> MethodCall
MethodCall Name
method [Expr]
argsTyped Range
range
        Maybe MethodSig
_ -> Name -> Semantic MethodCall
forall a. Name -> Semantic a
throwSemanticException (Name -> Semantic MethodCall) -> Name -> Semantic MethodCall
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"method " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext Format Name (Name -> Name)
-> Format Name Name -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
" not declared!") Name
method
    Just Either ImportDecl MethodDecl
decl -> case Either ImportDecl MethodDecl
decl of
      Left ImportDecl
_ -> MethodCall -> Semantic MethodCall
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (MethodCall -> Semantic MethodCall)
-> MethodCall -> Semantic MethodCall
forall a b. (a -> b) -> a -> b
$ Name -> [Expr] -> Range -> MethodCall
MethodCall Name
method [Expr]
argsTyped Range
range
      Right MethodDecl
m -> do
        let formal :: [Argument]
formal = MethodDecl
m MethodDecl
-> Getting [Argument] MethodDecl [Argument] -> [Argument]
forall s a. s -> Getting a s a -> a
^. ((MethodSig -> Const [Argument] MethodSig)
-> MethodDecl -> Const [Argument] MethodDecl
#sig ((MethodSig -> Const [Argument] MethodSig)
 -> MethodDecl -> Const [Argument] MethodDecl)
-> Getting [Argument] MethodSig [Argument]
-> Getting [Argument] MethodDecl [Argument]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting [Argument] MethodSig [Argument]
#args)
        -- Semantic[5] and Semantic[7]
        [Argument] -> [Expr] -> Semantic ()
checkCallingSemantics [Argument]
formal [Expr]
argsTyped
        MethodCall -> Semantic MethodCall
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (MethodCall -> Semantic MethodCall)
-> MethodCall -> Semantic MethodCall
forall a b. (a -> b) -> a -> b
$ Name -> [Expr] -> Range -> MethodCall
MethodCall Name
method [Expr]
argsTyped Range
range
  where
    matchPred :: (Argument, Expr) -> Bool
matchPred (Argument Name
_ Type
tpe Range
_, Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
tpe'}) = Type
tpe Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
tpe'
    argName :: (Argument, b) -> Name
argName (Argument Name
name Type
_ Range
_, b
_) = Name
name
    checkArgNum :: [Argument] -> [Expr] -> Semantic ()
checkArgNum [Argument]
formal [Expr]
args =
      Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        ([Argument] -> ScopeID
forall a. [a] -> ScopeID
forall (t :: * -> *) a. Foldable t => t a -> ScopeID
length [Argument]
formal ScopeID -> ScopeID -> Bool
forall a. Eq a => a -> a -> Bool
== [Expr] -> ScopeID
forall a. [a] -> ScopeID
forall (t :: * -> *) a. Foldable t => t a -> ScopeID
length [Expr]
args)
        ( Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$
            Format Name (Name -> ScopeID -> ScopeID -> Name)
-> Name -> ScopeID -> ScopeID -> Name
forall a. Format Name a -> a
sformat
              (Format
  (Name -> ScopeID -> ScopeID -> Name)
  (Name -> ScopeID -> ScopeID -> Name)
"Calling " Format
  (Name -> ScopeID -> ScopeID -> Name)
  (Name -> ScopeID -> ScopeID -> Name)
-> Format Name (Name -> ScopeID -> ScopeID -> Name)
-> Format Name (Name -> ScopeID -> ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format
  (ScopeID -> ScopeID -> Name) (Name -> ScopeID -> ScopeID -> Name)
forall r. Format r (Name -> r)
stext Format
  (ScopeID -> ScopeID -> Name) (Name -> ScopeID -> ScopeID -> Name)
-> Format Name (ScopeID -> ScopeID -> Name)
-> Format Name (Name -> ScopeID -> ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (ScopeID -> ScopeID -> Name) (ScopeID -> ScopeID -> Name)
" with wrong number of args. Required: " Format (ScopeID -> ScopeID -> Name) (ScopeID -> ScopeID -> Name)
-> Format Name (ScopeID -> ScopeID -> Name)
-> Format Name (ScopeID -> ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (ScopeID -> Name) (ScopeID -> ScopeID -> Name)
forall a r. Integral a => Format r (a -> r)
int Format (ScopeID -> Name) (ScopeID -> ScopeID -> Name)
-> Format Name (ScopeID -> Name)
-> Format Name (ScopeID -> ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (ScopeID -> Name) (ScopeID -> Name)
", supplied: " Format (ScopeID -> Name) (ScopeID -> Name)
-> Format Name (ScopeID -> Name) -> Format Name (ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (ScopeID -> Name)
forall a r. Integral a => Format r (a -> r)
int Format Name (ScopeID -> Name)
-> Format Name Name -> Format Name (ScopeID -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
".")
              Name
method
              ([Argument] -> ScopeID
forall a. [a] -> ScopeID
forall (t :: * -> *) a. Foldable t => t a -> ScopeID
length [Argument]
formal)
              ([Expr] -> ScopeID
forall a. [a] -> ScopeID
forall (t :: * -> *) a. Foldable t => t a -> ScopeID
length [Expr]
args)
        )
    checkArgType :: [Argument] -> [Expr] -> Semantic ()
checkArgType [Argument]
formal [Expr]
args =
      let mismatch :: [Name]
mismatch = ((Argument, Expr) -> Name) -> [(Argument, Expr)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Argument, Expr) -> Name
forall {b}. (Argument, b) -> Name
argName ([(Argument, Expr)] -> [Name]) -> [(Argument, Expr)] -> [Name]
forall a b. (a -> b) -> a -> b
$ ((Argument, Expr) -> Bool)
-> [(Argument, Expr)] -> [(Argument, Expr)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Argument, Expr) -> Bool) -> (Argument, Expr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Argument, Expr) -> Bool
matchPred) ([(Argument, Expr)] -> [(Argument, Expr)])
-> [(Argument, Expr)] -> [(Argument, Expr)]
forall a b. (a -> b) -> a -> b
$ [Argument] -> [Expr] -> [(Argument, Expr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Argument]
formal [Expr]
args
       in Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
            ([Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
mismatch)
            ( Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$
                Format Name (Name -> [Name] -> Name) -> Name -> [Name] -> Name
forall a. Format Name a -> a
sformat
                  (Format (Name -> [Name] -> Name) (Name -> [Name] -> Name)
"Calling " Format (Name -> [Name] -> Name) (Name -> [Name] -> Name)
-> Format Name (Name -> [Name] -> Name)
-> Format Name (Name -> [Name] -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format ([Name] -> Name) (Name -> [Name] -> Name)
forall r. Format r (Name -> r)
stext Format ([Name] -> Name) (Name -> [Name] -> Name)
-> Format Name ([Name] -> Name)
-> Format Name (Name -> [Name] -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format ([Name] -> Name) ([Name] -> Name)
" with wrong type of args: " Format ([Name] -> Name) ([Name] -> Name)
-> Format Name ([Name] -> Name) -> Format Name ([Name] -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name ([Name] -> Name)
forall a r. Show a => Format r (a -> r)
shown)
                  Name
method
                  [Name]
mismatch
            )
    arrayOrStringTypePred :: Expr -> Bool
arrayOrStringTypePred Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
tpe} = case Type
tpe of
      ArrayType Type
_ Int64
_ -> Bool
True
      Type
StringType -> Bool
True
      Type
_ -> Bool
False
    checkForArrayArg :: [Expr] -> Semantic ()
checkForArrayArg [Expr]
args =
      let arrayArgs :: [Expr]
arrayArgs = (Expr -> Bool) -> [Expr] -> [Expr]
forall a. (a -> Bool) -> [a] -> [a]
filter Expr -> Bool
arrayOrStringTypePred [Expr]
args
       in Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
            ([Expr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr]
arrayArgs)
            ( Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$
                Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat
                  (Format (Name -> Name) (Name -> Name)
"Argument of array or string type can not be used for method " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext)
                  Name
method
            )
    checkCallingSemantics :: [Argument] -> [Expr] -> Semantic ()
checkCallingSemantics [Argument]
formal [Expr]
args = do
      [Argument] -> [Expr] -> Semantic ()
checkArgNum [Argument]
formal [Expr]
args
      [Argument] -> [Expr] -> Semantic ()
checkArgType [Argument]
formal [Expr]
args
      [Expr] -> Semantic ()
checkForArrayArg [Expr]
args

irgenStmt :: P.Statement -> Semantic Statement
irgenStmt :: Statement -> Semantic Statement
irgenStmt (P.AssignStatement Location
loc AssignExpr
expr) = do
  Assignment
assign <- Location -> AssignExpr -> Semantic Assignment
irgenAssign Location
loc AssignExpr
expr
  Range
range <- Semantic Range
getCurrentRange
  Statement -> Semantic Statement
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Statement -> Semantic Statement)
-> Statement -> Semantic Statement
forall a b. (a -> b) -> a -> b
$ Statement_ -> Range -> Statement
Statement (Assignment -> Statement_
AssignStmt Assignment
assign) Range
range
irgenStmt (P.MethodCallStatement MethodCall
method) = do
  MethodCall
method' <- MethodCall -> Semantic MethodCall
irgenMethod MethodCall
method
  Range
range <- Semantic Range
getCurrentRange
  Statement -> Semantic Statement
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Statement -> Semantic Statement)
-> Statement -> Semantic Statement
forall a b. (a -> b) -> a -> b
$ Statement_ -> Range -> Statement
Statement (MethodCall -> Statement_
MethodCallStmt MethodCall
method') Range
range
irgenStmt (P.IfStatement Located Expr
expr Block
block) = do
  Block
ifBlock <- BlockType -> Maybe MethodSig -> Block -> Semantic Block
irgenBlock BlockType
IfBlock Maybe MethodSig
forall a. Maybe a
Nothing Block
block
  expr' :: Expr
expr'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
tpe} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
expr
  Range
range <- Semantic Range
getCurrentRange
  -- Semantic[14]
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Type
tpe Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
BoolType)
    (Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$ Format Name (Type -> Name) -> Type -> Name
forall a. Format Name a -> a
sformat (Format (Type -> Name) (Type -> Name)
"The pred of if statment must have type bool, but got " Format (Type -> Name) (Type -> Name)
-> Format Name (Type -> Name) -> Format Name (Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Type -> Name)
forall a r. Show a => Format r (a -> r)
shown Format Name (Type -> Name)
-> Format Name Name -> Format Name (Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
" instead!") Type
tpe)
  Statement -> Semantic Statement
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Statement -> Semantic Statement)
-> Statement -> Semantic Statement
forall a b. (a -> b) -> a -> b
$ Statement_ -> Range -> Statement
Statement (Expr -> Block -> Maybe Block -> Statement_
IfStmt Expr
expr' Block
ifBlock Maybe Block
forall a. Maybe a
Nothing) Range
range
irgenStmt (P.IfElseStatement Located Expr
expr Block
ifBlock Block
elseBlock) = do
  Block
ifBlock' <- BlockType -> Maybe MethodSig -> Block -> Semantic Block
irgenBlock BlockType
IfBlock Maybe MethodSig
forall a. Maybe a
Nothing Block
ifBlock
  Block
elseBlock' <- BlockType -> Maybe MethodSig -> Block -> Semantic Block
irgenBlock BlockType
IfBlock Maybe MethodSig
forall a. Maybe a
Nothing Block
elseBlock
  expr' :: Expr
expr'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
tpe} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
expr
  Range
range <- Semantic Range
getCurrentRange
  -- Semantic[14]
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Type
tpe Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
BoolType)
    (Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$ Format Name (Type -> Name) -> Type -> Name
forall a. Format Name a -> a
sformat (Format (Type -> Name) (Type -> Name)
"The pred of if statment must have type bool, but got " Format (Type -> Name) (Type -> Name)
-> Format Name (Type -> Name) -> Format Name (Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Type -> Name)
forall a r. Show a => Format r (a -> r)
shown Format Name (Type -> Name)
-> Format Name Name -> Format Name (Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
" instead!") Type
tpe)
  Statement -> Semantic Statement
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Statement -> Semantic Statement)
-> Statement -> Semantic Statement
forall a b. (a -> b) -> a -> b
$ Statement_ -> Range -> Statement
Statement (Expr -> Block -> Maybe Block -> Statement_
IfStmt Expr
expr' Block
ifBlock' (Block -> Maybe Block
forall a. a -> Maybe a
Just Block
elseBlock')) Range
range
irgenStmt (P.ForStatement Name
counter Located Expr
initExpr Located Expr
predExpr (P.CounterUpdate Location
updateLoc AssignExpr
updateExpr) Block
block) = do
  Assignment
init <- Location -> AssignExpr -> Semantic Assignment
irgenAssign (Name -> Location
P.ScalarLocation Name
counter) (Name -> Located Expr -> AssignExpr
P.AssignExpr Name
"=" Located Expr
initExpr)
  Block
block' <- BlockType -> Maybe MethodSig -> Block -> Semantic Block
irgenBlock BlockType
ForBlock Maybe MethodSig
forall a. Maybe a
Nothing Block
block
  predExpr' :: Expr
predExpr'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
tpe} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
predExpr
  Range
range <- Semantic Range
getCurrentRange
  -- Semantic[14]
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Type
tpe Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
BoolType)
    (Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$ Format Name (Type -> Name) -> Type -> Name
forall a. Format Name a -> a
sformat (Format (Type -> Name) (Type -> Name)
"The pred of for statment must have type bool, but got " Format (Type -> Name) (Type -> Name)
-> Format Name (Type -> Name) -> Format Name (Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Type -> Name)
forall a r. Show a => Format r (a -> r)
shown Format Name (Type -> Name)
-> Format Name Name -> Format Name (Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
" instead!") Type
tpe)
  Assignment
update <- Location -> AssignExpr -> Semantic Assignment
irgenAssign Location
updateLoc AssignExpr
updateExpr
  Statement -> Semantic Statement
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Statement -> Semantic Statement)
-> Statement -> Semantic Statement
forall a b. (a -> b) -> a -> b
$ Statement_ -> Range -> Statement
Statement (Maybe Assignment -> Expr -> Maybe Assignment -> Block -> Statement_
ForStmt (Assignment -> Maybe Assignment
forall a. a -> Maybe a
Just Assignment
init) Expr
predExpr' (Assignment -> Maybe Assignment
forall a. a -> Maybe a
Just Assignment
update) Block
block') Range
range
irgenStmt (P.WhileStatement Located Expr
expr Block
block) = do
  Block
block' <- BlockType -> Maybe MethodSig -> Block -> Semantic Block
irgenBlock BlockType
WhileBlock Maybe MethodSig
forall a. Maybe a
Nothing Block
block
  expr' :: Expr
expr'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
tpe} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
expr
  Range
range <- Semantic Range
getCurrentRange
  -- Semantic[14]
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Type
tpe Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
BoolType)
    (Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$ Format Name (Type -> Name) -> Type -> Name
forall a. Format Name a -> a
sformat (Format (Type -> Name) (Type -> Name)
"The pred of while statment must have type bool, but got " Format (Type -> Name) (Type -> Name)
-> Format Name (Type -> Name) -> Format Name (Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Type -> Name)
forall a r. Show a => Format r (a -> r)
shown Format Name (Type -> Name)
-> Format Name Name -> Format Name (Type -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
" instead!") Type
tpe)
  Statement -> Semantic Statement
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Statement -> Semantic Statement)
-> Statement -> Semantic Statement
forall a b. (a -> b) -> a -> b
$ Statement_ -> Range -> Statement
Statement (Maybe Assignment -> Expr -> Maybe Assignment -> Block -> Statement_
ForStmt Maybe Assignment
forall a. Maybe a
Nothing Expr
expr' Maybe Assignment
forall a. Maybe a
Nothing Block
block') Range
range
irgenStmt (P.ReturnExprStatement Located Expr
expr) = do
  Expr
expr' <- Located Expr -> Semantic Expr
irgenExpr Located Expr
expr
  Range
range <- Semantic Range
getCurrentRange
  -- Semantic[8] and Semantic[9]
  Maybe Expr -> Semantic ()
checkReturnType (Maybe Expr -> Semantic ()) -> Maybe Expr -> Semantic ()
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
expr'
  Statement -> Semantic Statement
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Statement -> Semantic Statement)
-> Statement -> Semantic Statement
forall a b. (a -> b) -> a -> b
$ Statement_ -> Range -> Statement
Statement (Maybe Expr -> Statement_
ReturnStmt (Maybe Expr -> Statement_) -> Maybe Expr -> Statement_
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
expr') Range
range
irgenStmt Statement
P.ReturnVoidStatement = do
  Range
range <- Semantic Range
getCurrentRange
  -- Semantic[8] and Semantic[9]
  Maybe Expr -> Semantic ()
checkReturnType Maybe Expr
forall a. Maybe a
Nothing
  Statement -> Semantic Statement
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Statement -> Semantic Statement)
-> Statement -> Semantic Statement
forall a b. (a -> b) -> a -> b
$ Statement_ -> Range -> Statement
Statement (Maybe Expr -> Statement_
ReturnStmt Maybe Expr
forall a. Maybe a
Nothing) Range
range
irgenStmt Statement
P.BreakStatement = do
  Range
range <- Semantic Range
getCurrentRange
  -- Semantic[21]
  Bool
inLoop <- Semantic Bool
isInsideLoop
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
    Bool
inLoop
    (Name -> Semantic ()
addSemanticError Name
"Found break statement outside for or while block!")
  Statement -> Semantic Statement
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Statement -> Semantic Statement)
-> Statement -> Semantic Statement
forall a b. (a -> b) -> a -> b
$ Statement_ -> Range -> Statement
Statement Statement_
BreakStmt Range
range
irgenStmt Statement
P.ContinueStatement = do
  Range
range <- Semantic Range
getCurrentRange
  -- Semantic[21]
  Bool
inLoop <- Semantic Bool
isInsideLoop
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
    Bool
inLoop
    (Name -> Semantic ()
addSemanticError Name
"Found continue statement outside for or while block!")
  Statement -> Semantic Statement
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Statement -> Semantic Statement)
-> Statement -> Semantic Statement
forall a b. (a -> b) -> a -> b
$ Statement_ -> Range -> Statement
Statement Statement_
ContinueStmt Range
range

{- generate expressions, also do type inference -}
irgenExpr :: SL.Located P.Expr -> Semantic Expr
irgenExpr :: Located Expr -> Semantic Expr
irgenExpr (SL.LocatedAt Range
range (P.LocationExpr Location
loc)) = do
  Range -> Semantic ()
updateCurrentRange Range
range
  loc' :: Location
loc'@Location {$sel:tpe:Location :: Location -> Type
tpe = Type
tpe} <- Location -> Semantic Location
irgenLocation Location
loc
  Expr -> Semantic Expr
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Semantic Expr) -> Expr -> Semantic Expr
forall a b. (a -> b) -> a -> b
$ Expr_ -> Type -> Range -> Expr
Expr (Location -> Expr_
LocationExpr Location
loc') Type
tpe Range
range
irgenExpr (SL.LocatedAt Range
range (P.MethodCallExpr method :: MethodCall
method@(P.MethodCall Name
name [Located ImportArg]
_))) = do
  Range -> Semantic ()
updateCurrentRange Range
range
  MethodCall
method' <- MethodCall -> Semantic MethodCall
irgenMethod MethodCall
method
  Either ImportDecl MethodDecl
m <- Name -> Semantic (Either ImportDecl MethodDecl)
lookupMethod' Name
name
  case Either ImportDecl MethodDecl
m of
    -- treat import methods as always return int
    Left ImportDecl
_ -> Expr -> Semantic Expr
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Semantic Expr) -> Expr -> Semantic Expr
forall a b. (a -> b) -> a -> b
$ Expr_ -> Type -> Range -> Expr
Expr (MethodCall -> Expr_
MethodCallExpr MethodCall
method') Type
IntType Range
range
    Right (MethodDecl (MethodSig Name
_ Maybe Type
tpe [Argument]
_) Block
_ Range
_) -> do
      case Maybe Type
tpe of
        -- Semantic[6]
        Maybe Type
Nothing ->
          Name -> Semantic Expr
forall a. Name -> Semantic a
throwSemanticException (Name -> Semantic Expr) -> Name -> Semantic Expr
forall a b. (a -> b) -> a -> b
$
            Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"Method " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext Format Name (Name -> Name)
-> Format Name Name -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
" cannot be used in expressions as it returns nothing!") Name
name
        Just Type
tpe' -> Expr -> Semantic Expr
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Semantic Expr) -> Expr -> Semantic Expr
forall a b. (a -> b) -> a -> b
$ Expr_ -> Type -> Range -> Expr
Expr (MethodCall -> Expr_
MethodCallExpr MethodCall
method') Type
tpe' Range
range
irgenExpr (SL.LocatedAt Range
range (P.IntLiteralExpr Name
i)) = do
  Range -> Semantic ()
updateCurrentRange Range
range
  Int64
literalVal <- Name -> Semantic Int64
checkInt64Literal Name
i
  Expr -> Semantic Expr
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Semantic Expr) -> Expr -> Semantic Expr
forall a b. (a -> b) -> a -> b
$ Expr_ -> Type -> Range -> Expr
Expr (Int64 -> Expr_
IntLiteralExpr Int64
literalVal) Type
IntType Range
range
irgenExpr (SL.LocatedAt Range
range (P.BoolLiteralExpr Name
b)) = do
  Range -> Semantic ()
updateCurrentRange Range
range
  Bool
lit <- Name -> Semantic Bool
checkBoolLiteral Name
b
  Expr -> Semantic Expr
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Semantic Expr) -> Expr -> Semantic Expr
forall a b. (a -> b) -> a -> b
$ Expr_ -> Type -> Range -> Expr
Expr (Bool -> Expr_
BoolLiteralExpr Bool
lit) Type
BoolType Range
range
irgenExpr (SL.LocatedAt Range
range (P.CharLiteralExpr Name
c)) = do
  Range -> Semantic ()
updateCurrentRange Range
range
  Char
lit <- Name -> Semantic Char
checkCharLiteral Name
c
  Expr -> Semantic Expr
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Semantic Expr) -> Expr -> Semantic Expr
forall a b. (a -> b) -> a -> b
$ Expr_ -> Type -> Range -> Expr
Expr (Char -> Expr_
CharLiteralExpr Char
lit) Type
CharType Range
range
irgenExpr (SL.LocatedAt Range
range (P.LenExpr Name
id)) = do
  Range -> Semantic ()
updateCurrentRange Range
range
  Either Argument FieldDecl
def <- Name -> Semantic (Either Argument FieldDecl)
lookupVariable' Name
id
  -- Semantic[13]
  case Either Argument FieldDecl
def of
    Left (Argument Name
nm Type
_ Range
_) -> Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"len cannot operate on argument " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext Format Name (Name -> Name)
-> Format Name Name -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
"!") Name
nm
    Right (FieldDecl Name
nm (ArrayType Type
_ Int64
_) Range
_) -> () -> Semantic ()
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Right (FieldDecl Name
nm Type
_ Range
_) -> Name -> Semantic ()
addSemanticError (Name -> Semantic ()) -> Name -> Semantic ()
forall a b. (a -> b) -> a -> b
$ Format Name (Name -> Name) -> Name -> Name
forall a. Format Name a -> a
sformat (Format (Name -> Name) (Name -> Name)
"len cannot operate on scalar variable " Format (Name -> Name) (Name -> Name)
-> Format Name (Name -> Name) -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name (Name -> Name)
forall r. Format r (Name -> r)
stext Format Name (Name -> Name)
-> Format Name Name -> Format Name (Name -> Name)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Name Name
"!") Name
nm
  Expr -> Semantic Expr
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Semantic Expr) -> Expr -> Semantic Expr
forall a b. (a -> b) -> a -> b
$ Expr_ -> Type -> Range -> Expr
Expr (Name -> Expr_
LengthExpr Name
id) Type
IntType Range
range
irgenExpr (SL.LocatedAt Range
range (P.ArithOpExpr Name
op Located Expr
l Located Expr
r)) = do
  Range -> Semantic ()
updateCurrentRange Range
range
  -- Semantic[16]
  l' :: Expr
l'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
ltp} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
l
  r' :: Expr
r'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
rtp} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
r
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Type
ltp Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
IntType Bool -> Bool -> Bool
|| Type
rtp Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
IntType)
    (Name -> Semantic ()
addSemanticError Name
"There can only be integer values in arithmetic expressions.")
  Expr -> Semantic Expr
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Semantic Expr) -> Expr -> Semantic Expr
forall a b. (a -> b) -> a -> b
$ Expr_ -> Type -> Range -> Expr
Expr (ArithOp -> Expr -> Expr -> Expr_
ArithOpExpr (Name -> ArithOp
parseArithOp Name
op) Expr
l' Expr
r') Type
IntType Range
range
irgenExpr (SL.LocatedAt Range
range (P.RelOpExpr Name
op Located Expr
l Located Expr
r)) = do
  Range -> Semantic ()
updateCurrentRange Range
range
  -- Semantic[16]
  l' :: Expr
l'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
ltp} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
l
  r' :: Expr
r'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
rtp} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
r
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Type
ltp Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
IntType Bool -> Bool -> Bool
|| Type
rtp Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
IntType)
    (Name -> Semantic ()
addSemanticError Name
"There can only be integer values in relational expressions.")
  Expr -> Semantic Expr
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Semantic Expr) -> Expr -> Semantic Expr
forall a b. (a -> b) -> a -> b
$ Expr_ -> Type -> Range -> Expr
Expr (RelOp -> Expr -> Expr -> Expr_
RelOpExpr (Name -> RelOp
parseRelOp Name
op) Expr
l' Expr
r') Type
BoolType Range
range
irgenExpr (SL.LocatedAt Range
range (P.EqOpExpr Name
op Located Expr
l Located Expr
r)) = do
  Range -> Semantic ()
updateCurrentRange Range
range
  -- Semantic[17]
  l' :: Expr
l'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
ltp} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
l
  r' :: Expr
r'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
rtp} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
r
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    ((Type
ltp, Type
rtp) (Type, Type) -> (Type, Type) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Type
IntType, Type
IntType) Bool -> Bool -> Bool
&& (Type
ltp, Type
rtp) (Type, Type) -> (Type, Type) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Type
BoolType, Type
BoolType))
    (Name -> Semantic ()
addSemanticError Name
"Can only check equality of expressions with the SAME type!")
  Expr -> Semantic Expr
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Semantic Expr) -> Expr -> Semantic Expr
forall a b. (a -> b) -> a -> b
$ Expr_ -> Type -> Range -> Expr
Expr (EqOp -> Expr -> Expr -> Expr_
EqOpExpr (Name -> EqOp
parseEqOp Name
op) Expr
l' Expr
r') Type
BoolType Range
range
irgenExpr (SL.LocatedAt Range
range (P.CondOpExpr Name
op Located Expr
l Located Expr
r)) = do
  Range -> Semantic ()
updateCurrentRange Range
range
  -- Semantic[18]
  l' :: Expr
l'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
ltp} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
l
  r' :: Expr
r'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
rtp} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
r
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Type
ltp Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
BoolType Bool -> Bool -> Bool
|| Type
rtp Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
BoolType)
    (Name -> Semantic ()
addSemanticError Name
"Conditional ops only accept booleans!")
  Expr -> Semantic Expr
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Semantic Expr) -> Expr -> Semantic Expr
forall a b. (a -> b) -> a -> b
$ Expr_ -> Type -> Range -> Expr
Expr (CondOp -> Expr -> Expr -> Expr_
CondOpExpr (Name -> CondOp
parseCondOp Name
op) Expr
l' Expr
r') Type
BoolType Range
range
irgenExpr (SL.LocatedAt Range
range (P.NegativeExpr Located Expr
expr)) = do
  Range -> Semantic ()
updateCurrentRange Range
range
  -- Semantic[16]
  expr' :: Expr
expr'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
tpe} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
expr
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Type
tpe Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
IntType)
    (Name -> Semantic ()
addSemanticError Name
"Operator \"-\" only accepts integers!")
  Expr -> Semantic Expr
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Semantic Expr) -> Expr -> Semantic Expr
forall a b. (a -> b) -> a -> b
$ Expr_ -> Type -> Range -> Expr
Expr (NegOp -> Expr -> Expr_
NegOpExpr NegOp
Neg Expr
expr') Type
IntType Range
range
irgenExpr (SL.LocatedAt Range
range (P.NegateExpr Located Expr
expr)) = do
  Range -> Semantic ()
updateCurrentRange Range
range
  -- Semantic[18]
  expr' :: Expr
expr'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
tpe} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
expr
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Type
tpe Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
BoolType)
    (Name -> Semantic ()
addSemanticError Name
"Operator \"!\" only accepts integers!")
  Expr -> Semantic Expr
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Semantic Expr) -> Expr -> Semantic Expr
forall a b. (a -> b) -> a -> b
$ Expr_ -> Type -> Range -> Expr
Expr (NotOp -> Expr -> Expr_
NotOpExpr NotOp
Not Expr
expr') Type
BoolType Range
range
irgenExpr (SL.LocatedAt Range
range (P.ChoiceExpr Located Expr
pred Located Expr
l Located Expr
r)) = do
  Range -> Semantic ()
updateCurrentRange Range
range
  pred' :: Expr
pred'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
ptp} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
pred
  l' :: Expr
l'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
ltp} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
l
  r' :: Expr
r'@Expr {$sel:tpe:Expr :: Expr -> Type
tpe = Type
rtp} <- Located Expr -> Semantic Expr
irgenExpr Located Expr
r
  -- Semantic[15]
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Type
ptp Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
BoolType)
    (Name -> Semantic ()
addSemanticError Name
"Predicate of choice operator must be a boolean!")
  Bool -> Semantic () -> Semantic ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Type
ltp Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
rtp)
    (Name -> Semantic ()
addSemanticError Name
"Alternatives of choice op should have same type!")
  Expr -> Semantic Expr
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Semantic Expr) -> Expr -> Semantic Expr
forall a b. (a -> b) -> a -> b
$ Expr_ -> Type -> Range -> Expr
Expr (ChoiceOp -> Expr -> Expr -> Expr -> Expr_
ChoiceOpExpr ChoiceOp
Choice Expr
pred' Expr
l' Expr
r') Type
ltp Range
range
irgenExpr (SL.LocatedAt Range
range (P.ParenExpr Located Expr
expr)) = do
  Range -> Semantic ()
updateCurrentRange Range
range
  Located Expr -> Semantic Expr
irgenExpr Located Expr
expr

irgenImportArg :: SL.Located P.ImportArg -> Semantic Expr
irgenImportArg :: Located ImportArg -> Semantic Expr
irgenImportArg (SL.LocatedAt Range
range (P.ExprImportArg Located Expr
expr)) = Located Expr -> Semantic Expr
irgenExpr Located Expr
expr
irgenImportArg (SL.LocatedAt Range
range (P.StringImportArg Name
arg)) = do
  Range -> Semantic ()
updateCurrentRange Range
range
  Expr -> Semantic Expr
forall a. a -> Semantic a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Semantic Expr) -> Expr -> Semantic Expr
forall a b. (a -> b) -> a -> b
$ Expr_ -> Type -> Range -> Expr
Expr (Name -> Expr_
StringLiteralExpr Name
arg) Type
StringType Range
range