{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE UndecidableInstances #-}
module Zinza.Check (check) where

import Control.Monad             ((>=>))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State (StateT (..), evalStateT, get, put)
import Data.Functor.Identity     (Identity (..))
import Data.Proxy                (Proxy (..))
import Data.Traversable          (for)

import qualified Data.Map.Strict as Map

import Zinza.Class
import Zinza.Errors
import Zinza.Expr
import Zinza.Indexing
import Zinza.Node
import Zinza.Pos
import Zinza.Type
import Zinza.Value
import Zinza.Var

-------------------------------------------------------------------------------
-- Type
-------------------------------------------------------------------------------

type Check v m = StateT (Map.Map Var (v Value -> m ShowS)) (Either CompileError)

-------------------------------------------------------------------------------
-- Nodes
-------------------------------------------------------------------------------

check :: forall a m. (Zinza a, ThrowRuntime m) => Nodes Var -> Either CompileError (a -> m String)
check :: forall a (m :: * -> *).
(Zinza a, ThrowRuntime m) =>
Nodes Var -> Either CompileError (a -> m Var)
check Nodes Var
nodes = case Proxy a -> Ty
forall a. Zinza a => Proxy a -> Ty
toType (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a) of
    rootTy :: Ty
rootTy@(TyRecord Map Var (Var, Ty)
env) -> do
        [Node (Expr (Identity Ty))]
nodes' <- ((Loc -> Var -> Either CompileError (Expr (Identity Ty)))
 -> Nodes Var -> Either CompileError [Node (Expr (Identity Ty))])
-> Nodes Var
-> (Loc -> Var -> Either CompileError (Expr (Identity Ty)))
-> Either CompileError [Node (Expr (Identity Ty))]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Node Var -> Either CompileError (Node (Expr (Identity Ty))))
-> Nodes Var -> Either CompileError [Node (Expr (Identity Ty))]
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 ((Node Var -> Either CompileError (Node (Expr (Identity Ty))))
 -> Nodes Var -> Either CompileError [Node (Expr (Identity Ty))])
-> ((Loc -> Var -> Either CompileError (Expr (Identity Ty)))
    -> Node Var -> Either CompileError (Node (Expr (Identity Ty))))
-> (Loc -> Var -> Either CompileError (Expr (Identity Ty)))
-> Nodes Var
-> Either CompileError [Node (Expr (Identity Ty))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Loc -> Var -> Either CompileError (Expr (Identity Ty)))
-> Node Var -> Either CompileError (Node (Expr (Identity Ty)))
forall (t :: * -> *) (f :: * -> *) a b.
(TraversableWithLoc t, Applicative f) =>
(Loc -> a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(Loc -> a -> f b) -> Node a -> f (Node b)
traverseWithLoc) Nodes Var
nodes ((Loc -> Var -> Either CompileError (Expr (Identity Ty)))
 -> Either CompileError [Node (Expr (Identity Ty))])
-> (Loc -> Var -> Either CompileError (Expr (Identity Ty)))
-> Either CompileError [Node (Expr (Identity Ty))]
forall a b. (a -> b) -> a -> b
$ \Loc
loc Var
var ->
            case Var -> Map Var (Var, Ty) -> Maybe (Var, Ty)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
var Map Var (Var, Ty)
env of
                Maybe (Var, Ty)
Nothing -> CompileError -> Either CompileError (Expr (Identity Ty))
forall a b. a -> Either a b
Left (Loc -> Var -> CompileError
UnboundTopLevelVar Loc
loc Var
var)
                Just (Var, Ty)
_  -> Expr (Identity Ty) -> Either CompileError (Expr (Identity Ty))
forall a b. b -> Either a b
Right (LExpr (Identity Ty) -> Located Var -> Expr (Identity Ty)
forall a. LExpr a -> Located Var -> Expr a
EField (Loc -> Expr (Identity Ty) -> LExpr (Identity Ty)
forall a. Loc -> a -> Located a
L Loc
loc (Located (Identity Ty) -> Expr (Identity Ty)
forall a. Located a -> Expr a
EVar (Loc -> Identity Ty -> Located (Identity Ty)
forall a. Loc -> a -> Located a
L Loc
loc (Ty -> Identity Ty
forall a. a -> Identity a
Identity Ty
rootTy)))) (Loc -> Var -> Located Var
forall a. Loc -> a -> Located a
L Loc
loc Var
var))

        Identity Value -> m ShowS
run <- StateT
  (Map Var (Identity Value -> m ShowS))
  (Either CompileError)
  (Identity Value -> m ShowS)
-> Map Var (Identity Value -> m ShowS)
-> Either CompileError (Identity Value -> m ShowS)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Nodes (Identity Ty)
-> StateT
     (Map Var (Identity Value -> m ShowS))
     (Either CompileError)
     (Identity Value -> m ShowS)
forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
Nodes (i Ty) -> Check v m (v Value -> m ShowS)
checkNodes ((Node (Expr (Identity Ty)) -> Node (Identity Ty))
-> [Node (Expr (Identity Ty))] -> Nodes (Identity Ty)
forall a b. (a -> b) -> [a] -> [b]
map (Node (Expr (Identity Ty))
-> (Expr (Identity Ty) -> Expr (Identity Ty)) -> Node (Identity Ty)
forall a b. Node a -> (a -> Expr b) -> Node b
>>== Expr (Identity Ty) -> Expr (Identity Ty)
forall a. a -> a
id) [Node (Expr (Identity Ty))]
nodes')) Map Var (Identity Value -> m ShowS)
forall k a. Map k a
Map.empty
        (a -> m Var) -> Either CompileError (a -> m Var)
forall a. a -> Either CompileError a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> m Var) -> Either CompileError (a -> m Var))
-> (a -> m Var) -> Either CompileError (a -> m Var)
forall a b. (a -> b) -> a -> b
$ (ShowS -> Var) -> m ShowS -> m Var
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Var
"") (m ShowS -> m Var) -> (a -> m ShowS) -> a -> m Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity Value -> m ShowS
run (Identity Value -> m ShowS)
-> (a -> Identity Value) -> a -> m ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Identity Value
forall a. a -> Identity a
Identity (Value -> Identity Value) -> (a -> Value) -> a -> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. Zinza a => a -> Value
toValue

    Ty
rootTy -> RuntimeError -> Either CompileError (a -> m Var)
forall a. RuntimeError -> Either CompileError a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> RuntimeError
NotRecord Loc
zeroLoc Ty
rootTy)

checkNodes
    :: (Indexing v i, ThrowRuntime m)
    => Nodes (i Ty)                    -- ^ nodes with root object
    -> Check v m (v Value -> m ShowS)
checkNodes :: forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
Nodes (i Ty) -> Check v m (v Value -> m ShowS)
checkNodes Nodes (i Ty)
nodes = do
    [v Value -> m ShowS]
nodes' <- (Node (i Ty) -> Check v m (v Value -> m ShowS))
-> Nodes (i Ty)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     [v Value -> m ShowS]
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 Node (i Ty) -> Check v m (v Value -> m ShowS)
forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
Node (i Ty) -> Check v m (v Value -> m ShowS)
checkNode Nodes (i Ty)
nodes
    (v Value -> m ShowS) -> Check v m (v Value -> m ShowS)
forall a.
a -> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((v Value -> m ShowS) -> Check v m (v Value -> m ShowS))
-> (v Value -> m ShowS) -> Check v m (v Value -> m ShowS)
forall a b. (a -> b) -> a -> b
$ \v Value
val -> do
        [ShowS]
ss <- ((v Value -> m ShowS) -> m ShowS)
-> [v Value -> m ShowS] -> m [ShowS]
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 ((v Value -> m ShowS) -> v Value -> m ShowS
forall a b. (a -> b) -> a -> b
$ v Value
val) [v Value -> m ShowS]
nodes'
        ShowS -> m ShowS
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id [ShowS]
ss)

checkNode
    :: (Indexing v i, ThrowRuntime m)
    => Node (i Ty)
    -> Check v m (v Value -> m ShowS)
checkNode :: forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
Node (i Ty) -> Check v m (v Value -> m ShowS)
checkNode Node (i Ty)
NComment = (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall a.
a -> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((v Value -> m ShowS)
 -> StateT
      (Map Var (v Value -> m ShowS))
      (Either CompileError)
      (v Value -> m ShowS))
-> (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall a b. (a -> b) -> a -> b
$ \v Value
_val -> ShowS -> m ShowS
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ShowS
forall a. a -> a
id
checkNode (NRaw Var
s) = (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall a.
a -> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((v Value -> m ShowS)
 -> StateT
      (Map Var (v Value -> m ShowS))
      (Either CompileError)
      (v Value -> m ShowS))
-> (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall a b. (a -> b) -> a -> b
$ \v Value
_val -> ShowS -> m ShowS
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> ShowS
showString Var
s)
checkNode (NIf LExpr (i Ty)
expr Nodes (i Ty)
xs Nodes (i Ty)
ys) = do
    v Value -> m Bool
b' <- LExpr (i Ty) -> Check v m (v Value -> m Bool)
forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
LExpr (i Ty) -> Check v m (v Value -> m Bool)
checkBool LExpr (i Ty)
expr
    v Value -> m ShowS
xs' <- StateT
  (Map Var (v Value -> m ShowS))
  (Either CompileError)
  (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall (m :: * -> *) s a. Monad m => StateT s m a -> StateT s m a
resetingState (StateT
   (Map Var (v Value -> m ShowS))
   (Either CompileError)
   (v Value -> m ShowS)
 -> StateT
      (Map Var (v Value -> m ShowS))
      (Either CompileError)
      (v Value -> m ShowS))
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall a b. (a -> b) -> a -> b
$ Nodes (i Ty)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
Nodes (i Ty) -> Check v m (v Value -> m ShowS)
checkNodes Nodes (i Ty)
xs
    v Value -> m ShowS
ys' <- StateT
  (Map Var (v Value -> m ShowS))
  (Either CompileError)
  (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall (m :: * -> *) s a. Monad m => StateT s m a -> StateT s m a
resetingState (StateT
   (Map Var (v Value -> m ShowS))
   (Either CompileError)
   (v Value -> m ShowS)
 -> StateT
      (Map Var (v Value -> m ShowS))
      (Either CompileError)
      (v Value -> m ShowS))
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall a b. (a -> b) -> a -> b
$ Nodes (i Ty)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
Nodes (i Ty) -> Check v m (v Value -> m ShowS)
checkNodes Nodes (i Ty)
ys
    (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall a.
a -> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((v Value -> m ShowS)
 -> StateT
      (Map Var (v Value -> m ShowS))
      (Either CompileError)
      (v Value -> m ShowS))
-> (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall a b. (a -> b) -> a -> b
$ \v Value
ctx -> do
        Bool
b'' <- v Value -> m Bool
b' v Value
ctx
        if Bool
b''
        then v Value -> m ShowS
xs' v Value
ctx
        else v Value -> m ShowS
ys' v Value
ctx
checkNode (NExpr LExpr (i Ty)
e) = do
    v Value -> m Var
e' <- LExpr (i Ty) -> Check v m (v Value -> m Var)
forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
LExpr (i Ty) -> Check v m (v Value -> m Var)
checkString LExpr (i Ty)
e
    (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall a.
a -> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((v Value -> m ShowS)
 -> StateT
      (Map Var (v Value -> m ShowS))
      (Either CompileError)
      (v Value -> m ShowS))
-> (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall a b. (a -> b) -> a -> b
$ \v Value
ctx -> do
        Var
s <- v Value -> m Var
e' v Value
ctx
        ShowS -> m ShowS
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ShowS -> m ShowS) -> ShowS -> m ShowS
forall a b. (a -> b) -> a -> b
$ Var -> ShowS
showString Var
s
checkNode (NFor Var
_v LExpr (i Ty)
expr Nodes (Maybe (i Ty))
nodes) = do
    (v Value -> m [Value]
expr', Ty
ty) <- LExpr (i Ty) -> Check v m (v Value -> m [Value], Ty)
forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
LExpr (i Ty) -> Check v m (v Value -> m [Value], Ty)
checkList LExpr (i Ty)
expr
    Map Var (v Value -> m ShowS)
blocks <- StateT
  (Map Var (v Value -> m ShowS))
  (Either CompileError)
  (Map Var (v Value -> m ShowS))
forall (m :: * -> *) s. Monad m => StateT s m s
get
    Cons v Value -> m ShowS
nodes' <- Either CompileError (Cons v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (Cons v Value -> m ShowS)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Var (v Value -> m ShowS)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either CompileError (Cons v Value -> m ShowS)
 -> StateT
      (Map Var (v Value -> m ShowS))
      (Either CompileError)
      (Cons v Value -> m ShowS))
-> Either CompileError (Cons v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (Cons v Value -> m ShowS)
forall a b. (a -> b) -> a -> b
$ StateT
  (Map Var (Cons v Value -> m ShowS))
  (Either CompileError)
  (Cons v Value -> m ShowS)
-> Map Var (Cons v Value -> m ShowS)
-> Either CompileError (Cons v Value -> m ShowS)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT
        (Nodes (Idx i Ty)
-> StateT
     (Map Var (Cons v Value -> m ShowS))
     (Either CompileError)
     (Cons v Value -> m ShowS)
forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
Nodes (i Ty) -> Check v m (v Value -> m ShowS)
checkNodes ((Node (Maybe (i Ty)) -> Node (Idx i Ty))
-> Nodes (Maybe (i Ty)) -> Nodes (Idx i Ty)
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe (i Ty) -> Idx i Ty)
-> Node (Maybe (i Ty)) -> Node (Idx i Ty)
forall a b. (a -> b) -> Node a -> Node b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Idx i Ty -> (i Ty -> Idx i Ty) -> Maybe (i Ty) -> Idx i Ty
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Ty -> Idx i Ty
forall (f :: * -> *) a. a -> Idx f a
Here Ty
ty) i Ty -> Idx i Ty
forall (f :: * -> *) a. f a -> Idx f a
There)) Nodes (Maybe (i Ty))
nodes))
        (((v Value -> m ShowS) -> Cons v Value -> m ShowS)
-> Map Var (v Value -> m ShowS)
-> Map Var (Cons v Value -> m ShowS)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\v Value -> m ShowS
f (Value
_ ::: v Value
xs) -> v Value -> m ShowS
f v Value
xs) Map Var (v Value -> m ShowS)
blocks)
    (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall a.
a -> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((v Value -> m ShowS)
 -> StateT
      (Map Var (v Value -> m ShowS))
      (Either CompileError)
      (v Value -> m ShowS))
-> (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall a b. (a -> b) -> a -> b
$ \v Value
ctx -> do
        [Value]
xs <- v Value -> m [Value]
expr' v Value
ctx
        [ShowS]
pieces <- [Value] -> (Value -> m ShowS) -> m [ShowS]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Value]
xs ((Value -> m ShowS) -> m [ShowS])
-> (Value -> m ShowS) -> m [ShowS]
forall a b. (a -> b) -> a -> b
$ \Value
x -> Cons v Value -> m ShowS
nodes' (Value
x Value -> v Value -> Cons v Value
forall (f :: * -> *) a. a -> f a -> Cons f a
::: v Value
ctx)
        ShowS -> m ShowS
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ShowS -> m ShowS) -> ShowS -> m ShowS
forall a b. (a -> b) -> a -> b
$ (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id [ShowS]
pieces
checkNode (NDefBlock Loc
l Var
n Nodes (i Ty)
nodes) = do
    Map Var (v Value -> m ShowS)
blocks <- StateT
  (Map Var (v Value -> m ShowS))
  (Either CompileError)
  (Map Var (v Value -> m ShowS))
forall (m :: * -> *) s. Monad m => StateT s m s
get
    if Var -> Map Var (v Value -> m ShowS) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Var
n Map Var (v Value -> m ShowS)
blocks
    then Either CompileError ()
-> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Var (v Value -> m ShowS)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CompileError -> Either CompileError ()
forall a b. a -> Either a b
Left (Loc -> Var -> CompileError
ShadowingBlock Loc
l Var
n))
    else do
        v Value -> m ShowS
nodes' <- Nodes (i Ty)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
Nodes (i Ty) -> Check v m (v Value -> m ShowS)
checkNodes Nodes (i Ty)
nodes
        Map Var (v Value -> m ShowS)
-> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Map Var (v Value -> m ShowS)
 -> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) ())
-> Map Var (v Value -> m ShowS)
-> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) ()
forall a b. (a -> b) -> a -> b
$ Var
-> (v Value -> m ShowS)
-> Map Var (v Value -> m ShowS)
-> Map Var (v Value -> m ShowS)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Var
n v Value -> m ShowS
nodes' Map Var (v Value -> m ShowS)
blocks
    (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall a.
a -> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((v Value -> m ShowS)
 -> StateT
      (Map Var (v Value -> m ShowS))
      (Either CompileError)
      (v Value -> m ShowS))
-> (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall a b. (a -> b) -> a -> b
$ \v Value
_ -> ShowS -> m ShowS
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ShowS
forall a. a -> a
id
checkNode (NUseBlock Loc
l Var
n) = do
    Map Var (v Value -> m ShowS)
blocks <- StateT
  (Map Var (v Value -> m ShowS))
  (Either CompileError)
  (Map Var (v Value -> m ShowS))
forall (m :: * -> *) s. Monad m => StateT s m s
get
    case Var -> Map Var (v Value -> m ShowS) -> Maybe (v Value -> m ShowS)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
n Map Var (v Value -> m ShowS)
blocks of
        Maybe (v Value -> m ShowS)
Nothing -> Either CompileError (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Var (v Value -> m ShowS)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CompileError -> Either CompileError (v Value -> m ShowS)
forall a b. a -> Either a b
Left (Loc -> Var -> CompileError
UnboundUseBlock Loc
l Var
n))
        Just v Value -> m ShowS
block -> (v Value -> m ShowS)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m ShowS)
forall a.
a -> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return v Value -> m ShowS
block

resetingState :: Monad m => StateT s m a -> StateT s m a
resetingState :: forall (m :: * -> *) s a. Monad m => StateT s m a -> StateT s m a
resetingState StateT s m a
m = do
    s
s <- StateT s m s
forall (m :: * -> *) s. Monad m => StateT s m s
get
    a
x <- StateT s m a
m
    s -> StateT s m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put s
s
    a -> StateT s m a
forall a. a -> StateT s m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-------------------------------------------------------------------------------
-- Expressions
-------------------------------------------------------------------------------

checkList :: (Indexing v i, ThrowRuntime m) => LExpr (i Ty) -> Check v m (v Value -> m [Value], Ty)
checkList :: forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
LExpr (i Ty) -> Check v m (v Value -> m [Value], Ty)
checkList e :: LExpr (i Ty)
e@(L Loc
l Expr (i Ty)
_) = do
    (v Value -> m Value
e', Ty
ty) <- LExpr (i Ty) -> Check v m (v Value -> m Value, Ty)
forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
LExpr (i Ty) -> Check v m (v Value -> m Value, Ty)
checkType LExpr (i Ty)
e
    case Ty
ty of
        TyList Maybe Var
_ Ty
ty' -> (v Value -> m [Value], Ty) -> Check v m (v Value -> m [Value], Ty)
forall a.
a -> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (v Value -> m Value
e' (v Value -> m Value)
-> (Value -> m [Value]) -> v Value -> m [Value]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Value -> m [Value]
forall {m :: * -> *}. ThrowRuntime m => Value -> m [Value]
go, Ty
ty')
        Ty
_            -> RuntimeError -> Check v m (v Value -> m [Value], Ty)
forall a.
RuntimeError
-> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> RuntimeError
NotList Loc
l Ty
ty)
  where
    go :: Value -> m [Value]
go (VList [Value]
xs) = [Value] -> m [Value]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Value]
xs
    go Value
x          = RuntimeError -> m [Value]
forall a. RuntimeError -> m a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> RuntimeError
NotList Loc
l (Value -> Ty
valueType Value
x))

checkBool :: (Indexing v i, ThrowRuntime m) => LExpr (i Ty) -> Check v m (v Value -> m Bool)
checkBool :: forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
LExpr (i Ty) -> Check v m (v Value -> m Bool)
checkBool e :: LExpr (i Ty)
e@(L Loc
l Expr (i Ty)
_) = do
    (v Value -> m Value
e', Ty
ty) <- LExpr (i Ty) -> Check v m (v Value -> m Value, Ty)
forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
LExpr (i Ty) -> Check v m (v Value -> m Value, Ty)
checkType LExpr (i Ty)
e
    case Ty
ty of
        Ty
TyBool -> (v Value -> m Bool) -> Check v m (v Value -> m Bool)
forall a.
a -> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (v Value -> m Value
e' (v Value -> m Value) -> (Value -> m Bool) -> v Value -> m Bool
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Value -> m Bool
forall {m :: * -> *}. ThrowRuntime m => Value -> m Bool
go)
        Ty
_      -> RuntimeError -> Check v m (v Value -> m Bool)
forall a.
RuntimeError
-> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> RuntimeError
NotBool Loc
l Ty
ty)
  where
    go :: Value -> m Bool
go (VBool Bool
b) = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
    go Value
x         = RuntimeError -> m Bool
forall a. RuntimeError -> m a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> RuntimeError
NotBool Loc
l (Value -> Ty
valueType Value
x))

checkString :: (Indexing v i, ThrowRuntime m) => LExpr (i Ty) -> Check v m (v Value -> m String)
checkString :: forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
LExpr (i Ty) -> Check v m (v Value -> m Var)
checkString e :: LExpr (i Ty)
e@(L Loc
l Expr (i Ty)
_) = do
    (v Value -> m Value
e', Ty
ty) <- LExpr (i Ty) -> Check v m (v Value -> m Value, Ty)
forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
LExpr (i Ty) -> Check v m (v Value -> m Value, Ty)
checkType LExpr (i Ty)
e
    case Ty
ty of
        TyString Maybe Var
_ -> (v Value -> m Var) -> Check v m (v Value -> m Var)
forall a.
a -> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (v Value -> m Value
e' (v Value -> m Value) -> (Value -> m Var) -> v Value -> m Var
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Value -> m Var
forall {m :: * -> *}. ThrowRuntime m => Value -> m Var
go)
        Ty
_          -> RuntimeError -> Check v m (v Value -> m Var)
forall a.
RuntimeError
-> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> RuntimeError
NotString Loc
l Ty
ty)
  where
    go :: Value -> m Var
go (VString Var
b) = Var -> m Var
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
b
    go Value
x           = RuntimeError -> m Var
forall a. RuntimeError -> m a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> RuntimeError
NotString Loc
l (Value -> Ty
valueType Value
x))

checkType :: (Indexing v i, ThrowRuntime m) => LExpr (i Ty) -> Check v m (v Value -> m Value, Ty)
checkType :: forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
LExpr (i Ty) -> Check v m (v Value -> m Value, Ty)
checkType (L Loc
_ (EVar (L Loc
_ i Ty
i))) =
    (v Value -> m Value, Ty)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m Value, Ty)
forall a.
a -> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (\v Value
v -> Value -> m Value
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Value, Ty) -> Value
forall a b. (a, b) -> a
fst (v Value -> i Ty -> (Value, Ty)
forall a b. v a -> i b -> (a, b)
forall (v :: * -> *) (i :: * -> *) a b.
Indexing v i =>
v a -> i b -> (a, b)
index v Value
v i Ty
i)), i Ty -> Ty
forall a. i a -> a
forall (v :: * -> *) (i :: * -> *) a. Indexing v i => i a -> a
extract i Ty
i)
checkType (L Loc
eLoc (EField Located (Expr (i Ty))
e (L Loc
nameLoc Var
name))) = do
    (v Value -> m Value
e', Ty
ty) <- Located (Expr (i Ty))
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m Value, Ty)
forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
LExpr (i Ty) -> Check v m (v Value -> m Value, Ty)
checkType Located (Expr (i Ty))
e
    case Ty
ty of
        TyRecord Map Var (Var, Ty)
tym -> case Var -> Map Var (Var, Ty) -> Maybe (Var, Ty)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
name Map Var (Var, Ty)
tym of
            Just (Var
_sel, Ty
tyf) -> (v Value -> m Value, Ty)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m Value, Ty)
forall a.
a -> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (v Value -> m Value
e' (v Value -> m Value) -> (Value -> m Value) -> v Value -> m Value
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Value -> m Value
forall {m :: * -> *}. ThrowRuntime m => Value -> m Value
go, Ty
tyf)
            Maybe (Var, Ty)
Nothing          -> RuntimeError
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m Value, Ty)
forall a.
RuntimeError
-> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Var -> Ty -> RuntimeError
FieldNotInRecord Loc
nameLoc Var
name Ty
ty)
        Ty
_ -> RuntimeError
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m Value, Ty)
forall a.
RuntimeError
-> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> RuntimeError
NotRecord Loc
eLoc Ty
ty)
  where
    go :: Value -> m Value
go x :: Value
x@(VRecord Map Var Value
r) = case Var -> Map Var Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
name Map Var Value
r of
        Just Value
y  -> Value -> m Value
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
y
        Maybe Value
Nothing -> RuntimeError -> m Value
forall a. RuntimeError -> m a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Var -> Ty -> RuntimeError
FieldNotInRecord Loc
nameLoc Var
name (Value -> Ty
valueType Value
x))
    go Value
x = RuntimeError -> m Value
forall a. RuntimeError -> m a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> RuntimeError
NotRecord Loc
eLoc (Value -> Ty
valueType Value
x))
checkType (L Loc
eLoc (EApp f :: Located (Expr (i Ty))
f@(L Loc
fLoc Expr (i Ty)
_) Located (Expr (i Ty))
x)) = do
    (v Value -> m Value
f', Ty
fTy) <- Located (Expr (i Ty))
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m Value, Ty)
forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
LExpr (i Ty) -> Check v m (v Value -> m Value, Ty)
checkType Located (Expr (i Ty))
f
    (v Value -> m Value
x', Ty
xTy) <- Located (Expr (i Ty))
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m Value, Ty)
forall (v :: * -> *) (i :: * -> *) (m :: * -> *).
(Indexing v i, ThrowRuntime m) =>
LExpr (i Ty) -> Check v m (v Value -> m Value, Ty)
checkType Located (Expr (i Ty))
x
    case Ty
fTy of
        TyFun Ty
xTy' Ty
yTy | Ty
xTy Ty -> Ty -> Bool
forall a. Eq a => a -> a -> Bool
== Ty
xTy' -> do
            (v Value -> m Value, Ty)
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m Value, Ty)
forall a.
a -> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((v Value -> m Value) -> (v Value -> m Value) -> v Value -> m Value
forall {m :: * -> *} {t}.
ThrowRuntime m =>
(t -> m Value) -> (t -> m Value) -> t -> m Value
go v Value -> m Value
f' v Value -> m Value
x', Ty
yTy)
        TyFun Ty
xTy' Ty
_ -> RuntimeError
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m Value, Ty)
forall a.
RuntimeError
-> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> Ty -> RuntimeError
FunArgDontMatch Loc
fLoc Ty
xTy Ty
xTy')
        Ty
_            -> RuntimeError
-> StateT
     (Map Var (v Value -> m ShowS))
     (Either CompileError)
     (v Value -> m Value, Ty)
forall a.
RuntimeError
-> StateT (Map Var (v Value -> m ShowS)) (Either CompileError) a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> RuntimeError
NotFunction Loc
eLoc Ty
fTy)
  where
    go :: (t -> m Value) -> (t -> m Value) -> t -> m Value
go t -> m Value
f' t -> m Value
x' t
ctx = do
        Value
f2 <- t -> m Value
f' t
ctx
        Value
x2 <- t -> m Value
x' t
ctx
        case Value
f2 of
            VFun Value -> Either RuntimeError Value
f3 -> (RuntimeError -> m Value)
-> (Value -> m Value) -> Either RuntimeError Value -> m Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either RuntimeError -> m Value
forall a. RuntimeError -> m a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime Value -> m Value
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either RuntimeError Value -> m Value)
-> Either RuntimeError Value -> m Value
forall a b. (a -> b) -> a -> b
$ Value -> Either RuntimeError Value
f3 Value
x2
            Value
_    -> RuntimeError -> m Value
forall a. RuntimeError -> m a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> RuntimeError
NotFunction Loc
eLoc (Value -> Ty
valueType Value
f2))