7
7
8
8
module Main (main ) where
9
9
10
- import Control.Monad (unless , (>=>) )
10
+ import Control.Monad (unless , (>=>) , foldM )
11
11
import Control.Monad.Error.Class (throwError )
12
12
import Control.Monad.IO.Class (liftIO )
13
13
import Control.Monad.Logger (runLogger' )
@@ -16,6 +16,7 @@ import qualified Control.Monad.State as State
16
16
import Control.Monad.Trans (lift )
17
17
import Control.Monad.Trans.Except (ExceptT (.. ), runExceptT )
18
18
import Control.Monad.Trans.Reader (runReaderT )
19
+ import Control.Monad.Writer.Strict (runWriterT )
19
20
import qualified Data.Aeson as A
20
21
import Data.Aeson ((.=) )
21
22
import Data.Bifunctor (first , second )
@@ -59,8 +60,8 @@ data Error
59
60
60
61
instance A. ToJSON Error
61
62
62
- server :: [P. ExternsFile ] -> P. Environment -> Int -> IO ()
63
- server externs initEnv port = do
63
+ server :: [P. ExternsFile ] -> P. Env -> P. Environment -> Int -> IO ()
64
+ server externs initNamesEnv initEnv port = do
64
65
let compile :: Text -> IO (Either Error ([P. JSONError ], JS ))
65
66
compile input
66
67
| T. length input > 20000 = return (Left (OtherError " Please limit your input to 20000 characters" ))
@@ -72,7 +73,7 @@ server externs initEnv port = do
72
73
Right m | P. getModuleName m == P. ModuleName [P. ProperName " Main" ] -> do
73
74
(resultMay, ws) <- runLogger' . runExceptT . flip runReaderT P. defaultOptions $ do
74
75
((P. Module ss coms moduleName elaborated exps, env), nextVar) <- P. runSupplyT 0 $ do
75
- desugared <- P. desugar externs [P. importPrim m] >>= \ case
76
+ desugared <- P. desugar initNamesEnv externs [P. importPrim m] >>= \ case
76
77
[d] -> pure d
77
78
_ -> error " desugaring did not produce one module"
78
79
P. runCheck' (P. emptyCheckState initEnv) $ P. typeCheckModule desugared
@@ -167,7 +168,9 @@ main = do
167
168
let onError f = either (Left . f) Right
168
169
e <- runExceptT $ do
169
170
modules <- ExceptT $ I. loadAllModules inputFiles
170
- ExceptT . I. runMake . I. make $ map (second CST. pureResult) modules
171
+ (exts, env) <- ExceptT . I. runMake . I. make $ map (second CST. pureResult) modules
172
+ namesEnv <- fmap fst . runWriterT $ foldM P. externsEnv P. primEnv exts
173
+ pure (exts, namesEnv, env)
171
174
case e of
172
175
Left err -> print err >> exitFailure
173
- Right (exts, env) -> server exts env port
176
+ Right (exts, namesEnv, env) -> server exts namesEnv env port
0 commit comments