1
- -----------------------------------------------------------------------------
2
- --
3
- -- Module : Main
4
- -- Copyright : (c) Phil Freeman 2013-2015
5
- -- License : MIT
6
- --
7
-
8
- -- Stability :
9
- -- Portability :
10
- --
11
- -- |
12
- --
13
- -----------------------------------------------------------------------------
14
-
15
1
{-# LANGUAGE DataKinds #-}
2
+ {-# LANGUAGE DeriveAnyClass #-}
3
+ {-# LANGUAGE DeriveGeneric #-}
16
4
{-# LANGUAGE OverloadedStrings #-}
17
5
{-# LANGUAGE TupleSections #-}
18
6
19
- module Main (
20
- main
21
- ) where
7
+ module Main (main ) where
22
8
23
9
import Control.Monad (unless )
24
10
import Control.Monad.IO.Class (liftIO )
@@ -37,10 +23,12 @@ import qualified Data.Text as T
37
23
import qualified Data.Text.Encoding as T
38
24
import qualified Data.Text.Lazy as TL
39
25
import Data.Traversable (for )
26
+ import GHC.Generics (Generic )
40
27
import qualified Language.PureScript as P
41
28
import qualified Language.PureScript.Bundle as Bundle
42
29
import qualified Language.PureScript.CodeGen.JS as J
43
30
import qualified Language.PureScript.CoreFn as CF
31
+ import qualified Language.PureScript.Errors.JSON as P
44
32
import qualified Language.PureScript.Interactive as I
45
33
import System.Environment (getArgs )
46
34
import System.Exit (exitFailure )
@@ -51,18 +39,25 @@ import System.IO.UTF8 (readUTF8File)
51
39
import Web.Scotty
52
40
import qualified Web.Scotty as Scotty
53
41
54
- type JS = String
42
+ type JS = Text
43
+
44
+ data Error
45
+ = CompilerErrors [P. JSONError ]
46
+ | OtherError Text
47
+ deriving Generic
48
+
49
+ instance A. ToJSON Error
55
50
56
51
server :: TL. Text -> [P. ExternsFile ] -> P. Environment -> Int -> IO ()
57
52
server bundled externs initEnv port = do
58
- let compile :: Text -> IO (Either String JS )
53
+ let compile :: Text -> IO (Either Error JS )
59
54
compile input
60
- | T. length input > 20000 = return $ Left " Please limit your input to 20000 characters"
55
+ | T. length input > 20000 = return ( Left ( OtherError " Please limit your input to 20000 characters" ))
61
56
| otherwise = do
62
57
let printErrors = P. prettyPrintMultipleErrors (P. defaultPPEOptions { P. ppeCodeColor = Nothing })
63
58
case P. parseModuleFromFile (const " <file>" ) (undefined , input) of
64
59
Left parseError ->
65
- return . Left . printErrors . P. MultipleErrors . return . P. toPositionedError $ parseError
60
+ return . Left . CompilerErrors . pure . P. toJSONError False P. Error . P. toPositionedError $ parseError
66
61
Right (_, m) | P. getModuleName m == P. ModuleName [P. ProperName " Main" ] -> do
67
62
(resultMay, _) <- runLogger' . runExceptT . flip runReaderT P. defaultOptions $ do
68
63
((P. Module ss coms moduleName elaborated exps, env), nextVar) <- P. runSupplyT 0 $ do
@@ -75,9 +70,9 @@ server bundled externs initEnv port = do
75
70
unless (null . CF. moduleForeign $ renamed) . throwError . P. errorMessage $ P. MissingFFIModule moduleName
76
71
P. evalSupplyT nextVar $ P. prettyPrintJS <$> J. moduleToJs renamed Nothing
77
72
case resultMay of
78
- Left errs -> return . Left . printErrors $ errs
79
- Right js -> return ( Right js)
80
- Right _ -> return $ Left " The name of the main module should be Main."
73
+ Left errs -> ( return . Left . CompilerErrors . P. toJSONErrors False P. Error ) errs
74
+ Right js -> ( return . Right ) js
75
+ Right _ -> ( return . Left . OtherError ) " The name of the main module should be Main."
81
76
82
77
scotty port $ do
83
78
get " /" $
0 commit comments