{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
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
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
]
data ModuleConfig a = ModuleConfig
{ :: [String]
, forall a. ModuleConfig a -> Var
mcRender :: String
}
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
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
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)