{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE UndecidableInstances #-}
-- | This module has the same shape as "Zinza.Check".
module Zinza.Module (
    checkModule,
    ModuleConfig (..),
    ) where

import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State (StateT (..), get, modify')
import Data.Foldable             (traverse_)
import Data.Maybe                (fromMaybe)
import Data.Proxy                (Proxy (..))

import qualified Data.Map.Strict as Map

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

-------------------------------------------------------------------------------
-- Monad
-------------------------------------------------------------------------------

type M = StateT S (Either CompileError)

data S = S
    { S -> [(Int, Var)] -> [(Int, Var)]
sOutput :: [(Int, String)] -> [(Int, String)]
    , S -> Int
sIndent :: Int
    , S -> Int
sVars   :: Int
    , S -> Map Var HsExpr
sBlocks :: Map.Map Var HsExpr
    }

tell :: String -> M ()
tell :: Var -> M ()
tell Var
str = (S -> S) -> M ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((S -> S) -> M ()) -> (S -> S) -> M ()
forall a b. (a -> b) -> a -> b
$ \S
s -> S
s { sOutput = sOutput s . ((sIndent s, str) :)}

indented :: M a -> M a
indented :: forall a. M a -> M a
indented M a
m = do
    (S -> S) -> M ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((S -> S) -> M ()) -> (S -> S) -> M ()
forall a b. (a -> b) -> a -> b
$ \S
s -> S
s { sIndent = succ (sIndent s) }
    a
x <- M a
m
    (S -> S) -> M ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((S -> S) -> M ()) -> (S -> S) -> M ()
forall a b. (a -> b) -> a -> b
$ \S
s -> S
s { sIndent = pred (sIndent s) }
    a -> M a
forall a. a -> StateT S (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

newVar :: String -> M Selector
newVar :: Var -> M Var
newVar Var
name = do
    Int
n <- S -> Int
sVars (S -> Int)
-> StateT S (Either CompileError) S
-> StateT S (Either CompileError) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT S (Either CompileError) S
forall (m :: * -> *) s. Monad m => StateT s m s
get
    (S -> S) -> M ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((S -> S) -> M ()) -> (S -> S) -> M ()
forall a b. (a -> b) -> a -> b
$ \S
s -> S
s { sVars = succ n }
    Var -> M Var
forall a. a -> StateT S (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var
"z_var" Var -> Var -> Var
forall a. [a] -> [a] -> [a]
++ Int -> Var
forall a. Show a => a -> Var
show Int
n Var -> Var -> Var
forall a. [a] -> [a] -> [a]
++ Var
"_" Var -> Var -> Var
forall a. [a] -> [a] -> [a]
++ Var
name)


flatten :: [(Int, String)] -> String
flatten :: [(Int, Var)] -> Var
flatten [(Int, Var)]
xs = [Var] -> Var
unlines
    [ Int -> Char -> Var
forall a. Int -> a -> [a]
replicate (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) Char
' ' Var -> Var -> Var
forall a. [a] -> [a] -> [a]
++ Var
str
    | (Int
i, Var
str) <- [(Int, Var)]
xs
    ]

-------------------------------------------------------------------------------
-- ModuleConfig
-------------------------------------------------------------------------------

-- | Configuration for module rendering
data ModuleConfig a = ModuleConfig
    { forall a. ModuleConfig a -> [Var]
mcHeader :: [String]  -- ^ module header
    , forall a. ModuleConfig a -> Var
mcRender :: String    -- ^ name of the function
    }
  deriving Int -> ModuleConfig a -> Var -> Var
[ModuleConfig a] -> Var -> Var
ModuleConfig a -> Var
(Int -> ModuleConfig a -> Var -> Var)
-> (ModuleConfig a -> Var)
-> ([ModuleConfig a] -> Var -> Var)
-> Show (ModuleConfig a)
forall a. Int -> ModuleConfig a -> Var -> Var
forall a. [ModuleConfig a] -> Var -> Var
forall a. ModuleConfig a -> Var
forall a.
(Int -> a -> Var -> Var)
-> (a -> Var) -> ([a] -> Var -> Var) -> Show a
$cshowsPrec :: forall a. Int -> ModuleConfig a -> Var -> Var
showsPrec :: Int -> ModuleConfig a -> Var -> Var
$cshow :: forall a. ModuleConfig a -> Var
show :: ModuleConfig a -> Var
$cshowList :: forall a. [ModuleConfig a] -> Var -> Var
showList :: [ModuleConfig a] -> Var -> Var
Show

-------------------------------------------------------------------------------
-- Compilation
-------------------------------------------------------------------------------

checkModule
    :: forall a. Zinza a
    => ModuleConfig a
    -> Nodes Var
    -> Either CompileError String
checkModule :: forall a.
Zinza a =>
ModuleConfig a -> Nodes Var -> Either CompileError Var
checkModule ModuleConfig a
mc 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
    TyRecord Map Var (Var, Ty)
env -> do
        [Node (HsExpr, Ty)]
nodes' <- ((Loc -> Var -> Either CompileError (HsExpr, Ty))
 -> Nodes Var -> Either CompileError [Node (HsExpr, Ty)])
-> Nodes Var
-> (Loc -> Var -> Either CompileError (HsExpr, Ty))
-> Either CompileError [Node (HsExpr, Ty)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Node Var -> Either CompileError (Node (HsExpr, Ty)))
-> Nodes Var -> Either CompileError [Node (HsExpr, 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 (HsExpr, Ty)))
 -> Nodes Var -> Either CompileError [Node (HsExpr, Ty)])
-> ((Loc -> Var -> Either CompileError (HsExpr, Ty))
    -> Node Var -> Either CompileError (Node (HsExpr, Ty)))
-> (Loc -> Var -> Either CompileError (HsExpr, Ty))
-> Nodes Var
-> Either CompileError [Node (HsExpr, Ty)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Loc -> Var -> Either CompileError (HsExpr, Ty))
-> Node Var -> Either CompileError (Node (HsExpr, 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 (HsExpr, Ty))
 -> Either CompileError [Node (HsExpr, Ty)])
-> (Loc -> Var -> Either CompileError (HsExpr, Ty))
-> Either CompileError [Node (HsExpr, 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 (HsExpr, Ty)
forall a b. a -> Either a b
Left (Loc -> Var -> CompileError
UnboundTopLevelVar Loc
loc Var
var)
                Just (Var
sel, Ty
ty) -> (HsExpr, Ty) -> Either CompileError (HsExpr, Ty)
forall a b. b -> Either a b
Right (HsExpr
rootExpr HsExpr -> Var -> HsExpr
`access` Var
sel, Ty
ty)

        ((), S [(Int, Var)] -> [(Int, Var)]
out Int
_ Int
_ Map Var HsExpr
_) <- M () -> S -> Either CompileError ((), S)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (M ()
header M () -> M () -> M ()
forall a b.
StateT S (Either CompileError) a
-> StateT S (Either CompileError) b
-> StateT S (Either CompileError) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> M () -> M ()
forall a. M a -> M a
indented ([Node (HsExpr, Ty)] -> M ()
checkNodes [Node (HsExpr, Ty)]
nodes')) (([(Int, Var)] -> [(Int, Var)]) -> Int -> Int -> Map Var HsExpr -> S
S [(Int, Var)] -> [(Int, Var)]
forall a. a -> a
id Int
0 Int
0 Map Var HsExpr
forall k a. Map k a
Map.empty)
        Var -> Either CompileError Var
forall a. a -> Either CompileError a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Int, Var)] -> Var
flatten ([(Int, Var)] -> [(Int, Var)]
out []))
    Ty
rootTy -> RuntimeError -> Either CompileError Var
forall a. RuntimeError -> Either CompileError a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> RuntimeError
NotRecord Loc
zeroLoc Ty
rootTy)
  where
    header :: M ()
header = do
        (Var -> M ()) -> [Var] -> M ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Var -> M ()
tell (ModuleConfig a -> [Var]
forall a. ModuleConfig a -> [Var]
mcHeader ModuleConfig a
mc)
        Var -> M ()
tell (Var -> M ()) -> Var -> M ()
forall a b. (a -> b) -> a -> b
$ ModuleConfig a -> Var
forall a. ModuleConfig a -> Var
mcRender ModuleConfig a
mc Var -> Var -> Var
forall a. [a] -> [a] -> [a]
++ Var
" " Var -> Var -> Var
forall a. [a] -> [a] -> [a]
++ HsExpr -> Var
displayHsExpr HsExpr
rootExpr Var -> Var -> Var
forall a. [a] -> [a] -> [a]
++ Var
" = execWriter $ do"

    rootExpr :: HsExpr
    rootExpr :: HsExpr
rootExpr = Var -> HsExpr
hsVar Var
"z_root"

checkNodes :: Nodes (HsExpr, Ty) -> M ()
checkNodes :: [Node (HsExpr, Ty)] -> M ()
checkNodes = (Node (HsExpr, Ty) -> M ()) -> [Node (HsExpr, Ty)] -> M ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Node (HsExpr, Ty) -> M ()
checkNode

checkNode :: Node (HsExpr, Ty) -> M ()
checkNode :: Node (HsExpr, Ty) -> M ()
checkNode Node (HsExpr, Ty)
NComment = () -> M ()
forall a. a -> StateT S (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkNode (NRaw Var
s) = Var -> M ()
tell (Var -> M ()) -> Var -> M ()
forall a b. (a -> b) -> a -> b
$ Var
"tell " Var -> Var -> Var
forall a. [a] -> [a] -> [a]
++ Var -> Var
forall a. Show a => a -> Var
show Var
s
checkNode (NExpr LExpr (HsExpr, Ty)
expr) = do
    HsExpr
expr' <- Either CompileError HsExpr -> StateT S (Either CompileError) HsExpr
forall (m :: * -> *) a. Monad m => m a -> StateT S m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either CompileError HsExpr
 -> StateT S (Either CompileError) HsExpr)
-> Either CompileError HsExpr
-> StateT S (Either CompileError) HsExpr
forall a b. (a -> b) -> a -> b
$ LExpr (HsExpr, Ty) -> Either CompileError HsExpr
checkString LExpr (HsExpr, Ty)
expr
    Var -> M ()
tell (Var -> M ()) -> Var -> M ()
forall a b. (a -> b) -> a -> b
$ Var
"tell " Var -> Var -> Var
forall a. [a] -> [a] -> [a]
++ HsExpr -> Var
displayHsExpr HsExpr
expr'
checkNode (NIf LExpr (HsExpr, Ty)
expr [Node (HsExpr, Ty)]
xs [Node (HsExpr, Ty)]
ys) = do
    HsExpr
expr' <- Either CompileError HsExpr -> StateT S (Either CompileError) HsExpr
forall (m :: * -> *) a. Monad m => m a -> StateT S m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either CompileError HsExpr
 -> StateT S (Either CompileError) HsExpr)
-> Either CompileError HsExpr
-> StateT S (Either CompileError) HsExpr
forall a b. (a -> b) -> a -> b
$ LExpr (HsExpr, Ty) -> Either CompileError HsExpr
checkBool LExpr (HsExpr, Ty)
expr
    Var -> M ()
tell (Var -> M ()) -> Var -> M ()
forall a b. (a -> b) -> a -> b
$ Var
"if " Var -> Var -> Var
forall a. [a] -> [a] -> [a]
++ HsExpr -> Var
displayHsExpr HsExpr
expr'
    Var -> M ()
tell Var
"then do"
    M () -> M ()
forall a. M a -> M a
indented (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ do
        M () -> M ()
forall a. M a -> M a
resettingBlocks (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ [Node (HsExpr, Ty)] -> M ()
checkNodes [Node (HsExpr, Ty)]
xs
        Var -> M ()
tell Var
"return ()"
    Var -> M ()
tell Var
"else do"
    M () -> M ()
forall a. M a -> M a
indented (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ do
        M () -> M ()
forall a. M a -> M a
resettingBlocks (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ [Node (HsExpr, Ty)] -> M ()
checkNodes [Node (HsExpr, Ty)]
ys
        Var -> M ()
tell Var
"return ()"
checkNode (NFor Var
v LExpr (HsExpr, Ty)
expr Nodes (Maybe (HsExpr, Ty))
nodes) = do
    Var
v' <- Var -> M Var
newVar Var
v
    (HsExpr
expr', Ty
ty) <- Either CompileError (HsExpr, Ty)
-> StateT S (Either CompileError) (HsExpr, Ty)
forall (m :: * -> *) a. Monad m => m a -> StateT S m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LExpr (HsExpr, Ty) -> Either CompileError (HsExpr, Ty)
checkList LExpr (HsExpr, Ty)
expr)
    Var -> M ()
tell (Var -> M ()) -> Var -> M ()
forall a b. (a -> b) -> a -> b
$ Var
"forM_ " Var -> Var -> Var
forall a. [a] -> [a] -> [a]
++ HsExpr -> Var
displayHsExpr HsExpr
expr' Var -> Var -> Var
forall a. [a] -> [a] -> [a]
++ Var
" $ \\" Var -> Var -> Var
forall a. [a] -> [a] -> [a]
++ Var
v' Var -> Var -> Var
forall a. [a] -> [a] -> [a]
++ Var
" -> do"
    M () -> M ()
forall a. M a -> M a
indented (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ [Node (HsExpr, Ty)] -> M ()
checkNodes ([Node (HsExpr, Ty)] -> M ()) -> [Node (HsExpr, Ty)] -> M ()
forall a b. (a -> b) -> a -> b
$ (Node (Maybe (HsExpr, Ty)) -> Node (HsExpr, Ty))
-> Nodes (Maybe (HsExpr, Ty)) -> [Node (HsExpr, Ty)]
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe (HsExpr, Ty) -> (HsExpr, Ty))
-> Node (Maybe (HsExpr, Ty)) -> Node (HsExpr, Ty)
forall a b. (a -> b) -> Node a -> Node b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((HsExpr, Ty) -> Maybe (HsExpr, Ty) -> (HsExpr, Ty)
forall a. a -> Maybe a -> a
fromMaybe (Var -> HsExpr
hsVar Var
v', Ty
ty))) Nodes (Maybe (HsExpr, Ty))
nodes
checkNode (NDefBlock Loc
l Var
n [Node (HsExpr, Ty)]
nodes) = do
    Map Var HsExpr
blocks <- (S -> Map Var HsExpr)
-> StateT S (Either CompileError) S
-> StateT S (Either CompileError) (Map Var HsExpr)
forall a b.
(a -> b)
-> StateT S (Either CompileError) a
-> StateT S (Either CompileError) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap S -> Map Var HsExpr
sBlocks StateT S (Either CompileError) S
forall (m :: * -> *) s. Monad m => StateT s m s
get
    if Var -> Map Var HsExpr -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Var
n Map Var HsExpr
blocks
    then Either CompileError () -> M ()
forall (m :: * -> *) a. Monad m => m a -> StateT S 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
UnboundUseBlock Loc
l Var
n))
    else do
        HsExpr
v' <- (Var -> HsExpr) -> M Var -> StateT S (Either CompileError) HsExpr
forall a b.
(a -> b)
-> StateT S (Either CompileError) a
-> StateT S (Either CompileError) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Var -> HsExpr
hsVar (Var -> M Var
newVar Var
n)
        Var -> M ()
tell Var
"let"
        M () -> M ()
forall a. M a -> M a
indented (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ do
            Var -> M ()
tell (Var -> M ()) -> Var -> M ()
forall a b. (a -> b) -> a -> b
$ HsExpr -> Var
displayHsExpr HsExpr
v' Var -> Var -> Var
forall a. [a] -> [a] -> [a]
++ Var
" = do"
            M () -> M ()
forall a. M a -> M a
indented (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ do
                [Node (HsExpr, Ty)] -> M ()
checkNodes [Node (HsExpr, Ty)]
nodes
                Var -> M ()
tell Var
"return ()"
        (S -> S) -> M ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((S -> S) -> M ()) -> (S -> S) -> M ()
forall a b. (a -> b) -> a -> b
$ \S
s' -> S
s' { sBlocks = Map.insert n v' blocks }
checkNode (NUseBlock Loc
l Var
n) = do
    S [(Int, Var)] -> [(Int, Var)]
_ Int
_ Int
_ Map Var HsExpr
blocks <- StateT S (Either CompileError) S
forall (m :: * -> *) s. Monad m => StateT s m s
get
    case Var -> Map Var HsExpr -> Maybe HsExpr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
n Map Var HsExpr
blocks of
        Maybe HsExpr
Nothing -> Either CompileError () -> M ()
forall (m :: * -> *) a. Monad m => m a -> StateT S 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
UnboundUseBlock Loc
l Var
n))
        Just HsExpr
block -> Var -> M ()
tell (Var -> M ()) -> Var -> M ()
forall a b. (a -> b) -> a -> b
$ HsExpr -> Var
displayHsExpr HsExpr
block

resettingBlocks :: M a -> M a
resettingBlocks :: forall a. M a -> M a
resettingBlocks M a
m = do
    S
s <- StateT S (Either CompileError) S
forall (m :: * -> *) s. Monad m => StateT s m s
get
    a
x <- M a
m
    (S -> S) -> M ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((S -> S) -> M ()) -> (S -> S) -> M ()
forall a b. (a -> b) -> a -> b
$ \S
s' -> S
s' { sBlocks = sBlocks s }
    a -> M a
forall a. a -> StateT S (Either CompileError) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-------------------------------------------------------------------------------
-- Expression
-------------------------------------------------------------------------------

checkList :: LExpr (HsExpr, Ty) -> Either CompileError (HsExpr, Ty)
checkList :: LExpr (HsExpr, Ty) -> Either CompileError (HsExpr, Ty)
checkList e :: LExpr (HsExpr, Ty)
e@(L Loc
l Expr (HsExpr, Ty)
_) = do
    (HsExpr
e', Ty
ty) <- LExpr (HsExpr, Ty) -> Either CompileError (HsExpr, Ty)
checkType LExpr (HsExpr, Ty)
e
    case Ty
ty of
        TyList Maybe Var
sel Ty
ty' -> (HsExpr, Ty) -> Either CompileError (HsExpr, Ty)
forall a. a -> Either CompileError a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr
e' HsExpr -> Maybe Var -> HsExpr
`accessMaybe` Maybe Var
sel, Ty
ty')
        Ty
_ ->  RuntimeError -> Either CompileError (HsExpr, Ty)
forall a. RuntimeError -> Either CompileError a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> RuntimeError
NotList Loc
l Ty
ty)

checkString :: LExpr (HsExpr, Ty) -> Either CompileError HsExpr
checkString :: LExpr (HsExpr, Ty) -> Either CompileError HsExpr
checkString e :: LExpr (HsExpr, Ty)
e@(L Loc
l Expr (HsExpr, Ty)
_) = do
    (HsExpr
e', Ty
ty) <- LExpr (HsExpr, Ty) -> Either CompileError (HsExpr, Ty)
checkType LExpr (HsExpr, Ty)
e
    case Ty
ty of
        TyString Maybe Var
sel -> HsExpr -> Either CompileError HsExpr
forall a. a -> Either CompileError a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr
e' HsExpr -> Maybe Var -> HsExpr
`accessMaybe` Maybe Var
sel)
        Ty
_            -> RuntimeError -> Either CompileError HsExpr
forall a. RuntimeError -> Either CompileError a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> RuntimeError
NotString Loc
l Ty
ty)

checkBool :: LExpr (HsExpr, Ty) -> Either CompileError HsExpr
checkBool :: LExpr (HsExpr, Ty) -> Either CompileError HsExpr
checkBool e :: LExpr (HsExpr, Ty)
e@(L Loc
l Expr (HsExpr, Ty)
_) = do
    (HsExpr
e', Ty
ty) <- LExpr (HsExpr, Ty) -> Either CompileError (HsExpr, Ty)
checkType LExpr (HsExpr, Ty)
e
    case Ty
ty of
        Ty
TyBool -> HsExpr -> Either CompileError HsExpr
forall a. a -> Either CompileError a
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr
e'
        Ty
_      -> RuntimeError -> Either CompileError HsExpr
forall a. RuntimeError -> Either CompileError a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> RuntimeError
NotBool Loc
l Ty
ty)

checkType :: LExpr (HsExpr, Ty) -> Either CompileError (HsExpr, Ty)
checkType :: LExpr (HsExpr, Ty) -> Either CompileError (HsExpr, Ty)
checkType (L Loc
_ (EVar (L Loc
_ (HsExpr, Ty)
x))) = (HsExpr, Ty) -> Either CompileError (HsExpr, Ty)
forall a. a -> Either CompileError a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr, Ty)
x
checkType (L Loc
eLoc (EField LExpr (HsExpr, Ty)
e (L Loc
nameLoc Var
name))) =do
    (HsExpr
e', Ty
ty) <- LExpr (HsExpr, Ty) -> Either CompileError (HsExpr, Ty)
checkType LExpr (HsExpr, 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) -> (HsExpr, Ty) -> Either CompileError (HsExpr, Ty)
forall a. a -> Either CompileError a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr
e' HsExpr -> Var -> HsExpr
`access` Var
sel, Ty
tyf)
            Maybe (Var, Ty)
Nothing         -> RuntimeError -> Either CompileError (HsExpr, Ty)
forall a. RuntimeError -> 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 -> Either CompileError (HsExpr, Ty)
forall a. RuntimeError -> Either CompileError a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> RuntimeError
NotRecord Loc
eLoc Ty
ty)
checkType (L Loc
eLoc (EApp f :: LExpr (HsExpr, Ty)
f@(L Loc
fLoc Expr (HsExpr, Ty)
_) LExpr (HsExpr, Ty)
x)) = do
    (HsExpr
f', Ty
fTy) <- LExpr (HsExpr, Ty) -> Either CompileError (HsExpr, Ty)
checkType LExpr (HsExpr, Ty)
f
    (HsExpr
x', Ty
xTy) <- LExpr (HsExpr, Ty) -> Either CompileError (HsExpr, Ty)
checkType LExpr (HsExpr, 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
            (HsExpr, Ty) -> Either CompileError (HsExpr, Ty)
forall a. a -> Either CompileError a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr -> HsExpr -> HsExpr
HsApp HsExpr
f' HsExpr
x', Ty
yTy)
        TyFun Ty
xTy' Ty
_ -> RuntimeError -> Either CompileError (HsExpr, Ty)
forall a. RuntimeError -> 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 -> Either CompileError (HsExpr, Ty)
forall a. RuntimeError -> Either CompileError a
forall (m :: * -> *) a. ThrowRuntime m => RuntimeError -> m a
throwRuntime (Loc -> Ty -> RuntimeError
NotFunction Loc
eLoc Ty
fTy)