@@ -18,9 +18,11 @@ import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
1818import Control.Monad.Trans.Reader (runReaderT )
1919import qualified Data.Aeson as A
2020import Data.Aeson ((.=) )
21+ import Data.Bifunctor (first , second )
2122import qualified Data.ByteString.Lazy as BL
2223import Data.Function (on )
2324import Data.List (foldl' , nubBy )
25+ import qualified Data.List.NonEmpty as NE
2426import qualified Data.Map as M
2527import Data.String (fromString )
2628import Data.Text (Text )
@@ -30,6 +32,8 @@ import qualified Data.Text.Lazy as TL
3032import Data.Traversable (for )
3133import GHC.Generics (Generic )
3234import qualified Language.PureScript as P
35+ import qualified Language.PureScript.CST as CST
36+ import qualified Language.PureScript.CST.Monad as CSTM
3337import qualified Language.PureScript.Bundle as Bundle
3438import qualified Language.PureScript.CodeGen.JS as J
3539import qualified Language.PureScript.CodeGen.JS.Printer as P
@@ -63,13 +67,15 @@ server bundled externs initEnv port = do
6367 | T. length input > 20000 = return (Left (OtherError " Please limit your input to 20000 characters" ))
6468 | otherwise = do
6569 let printErrors = P. prettyPrintMultipleErrors (P. defaultPPEOptions { P. ppeCodeColor = Nothing })
66- case P . parseModuleFromFile ( const " <file>" ) ( undefined , input) of
70+ case CST . parseModuleFromFile " <file>" input >>= CST. resFull of
6771 Left parseError ->
68- return . Left . CompilerErrors . pure . P. toJSONError False P. Error . P. toPositionedError $ parseError
69- Right (_, m) | P. getModuleName m == P. ModuleName [P. ProperName " Main" ] -> do
72+ return . Left . CompilerErrors . P. toJSONErrors False P. Error $ CST. toMultipleErrors " <file> " parseError
73+ Right m | P. getModuleName m == P. ModuleName [P. ProperName " Main" ] -> do
7074 (resultMay, ws) <- runLogger' . runExceptT . flip runReaderT P. defaultOptions $ do
7175 ((P. Module ss coms moduleName elaborated exps, env), nextVar) <- P. runSupplyT 0 $ do
72- [desugared] <- P. desugar externs [P. importPrim m]
76+ desugared <- P. desugar externs [P. importPrim m] >>= \ case
77+ [d] -> pure d
78+ _ -> error " desugaring did not produce one module"
7379 P. runCheck' (P. emptyCheckState initEnv) $ P. typeCheckModule desugared
7480 regrouped <- P. createBindingGroups moduleName . P. collapseBindingGroups $ elaborated
7581 let mod' = P. Module ss coms moduleName regrouped exps
@@ -80,7 +86,8 @@ server bundled externs initEnv port = do
8086 case resultMay of
8187 Left errs -> (return . Left . CompilerErrors . P. toJSONErrors False P. Error ) errs
8288 Right js -> (return . Right ) (P. toJSONErrors False P. Error ws, js)
83- Right _ -> (return . Left . OtherError ) " The name of the main module should be Main."
89+ Right _ ->
90+ (return . Left . OtherError ) " The name of the main module should be Main."
8491
8592 scotty port $ do
8693 get " /" $
@@ -147,9 +154,15 @@ replaceTypeVariablesAndDesugar f ty = State.evalState (P.everywhereOnTypesM go t
147154 other -> pure other
148155
149156tryParseType :: Text -> Maybe P. SourceType
150- tryParseType = hush ( P. lex " " ) >=> hush ( P. runTokenParser " " ( P. parsePolyType <* Parsec. eof))
157+ tryParseType = hush . fmap ( CST. convertType " <file> " ) . runParser CST. parseTypeP
151158 where
152- hush f = either (const Nothing ) Just . f
159+ hush = either (const Nothing ) Just
160+
161+ runParser :: CST. Parser a -> Text -> Either String a
162+ runParser p =
163+ first (CST. prettyPrintError . NE. head )
164+ . CST. runTokenParser (p <* CSTM. token CST. TokEof )
165+ . CST. lexTopLevel
153166
154167bundle :: IO (Either Bundle. ErrorMessage String )
155168bundle = runExceptT $ do
@@ -168,7 +181,7 @@ main = do
168181 let onError f = either (Left . f) Right
169182 e <- runExceptT $ do
170183 modules <- ExceptT (fmap (onError Right ) (I. loadAllModules inputFiles))
171- (exts, env) <- ExceptT . fmap (onError Right ) . I. runMake . I. make $ modules
184+ (exts, env) <- ExceptT . fmap (onError Right ) . I. runMake . I. make . map (second CST. pureResult) $ modules
172185 js <- ExceptT (fmap (onError Left ) bundle)
173186 return (fromString js, exts, env)
174187 case e of
0 commit comments