Update for PureScript 0.14

server/Main.hs

@@ -7,6 +7,7 @@ module Main (main) where
 
 import           Control.Monad (unless, foldM)
 import           Control.Monad.Error.Class (throwError)
+import           Control.Monad.IO.Class (liftIO)
 import           Control.Monad.Logger (runLogger')
 import qualified Control.Monad.State as State
 import           Control.Monad.Trans (lift)
@@ -15,25 +16,30 @@ import           Control.Monad.Trans.Reader (runReaderT)
 import           Control.Monad.Writer.Strict (runWriterT)
 import qualified Data.Aeson as A
 import           Data.Aeson ((.=))
-import           Data.Bifunctor (first, second)
+import           Data.Bifunctor (first, second, bimap)
 import qualified Data.ByteString.Lazy as BL
 import           Data.Default (def)
 import           Data.Function (on)
+import qualified Data.IORef as IORef
 import           Data.List (nubBy)
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map as M
 import           Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
+import           Data.Time.Clock (UTCTime)
 import           GHC.Generics (Generic)
 import qualified Language.PureScript as P
 import qualified Language.PureScript.CST as CST
 import qualified Language.PureScript.CST.Monad as CSTM
 import qualified Language.PureScript.CodeGen.JS as J
 import qualified Language.PureScript.CodeGen.JS.Printer as P
 import qualified Language.PureScript.CoreFn as CF
+import qualified Language.PureScript.Docs.Types as Docs
 import qualified Language.PureScript.Errors.JSON as P
 import qualified Language.PureScript.Interactive as I
+import qualified Language.PureScript.Make as Make
+import qualified Language.PureScript.Make.Cache as Cache
 import qualified Language.PureScript.TypeChecker.TypeSearch as TS
 import qualified Network.Wai.Handler.Warp as Warp
 import           System.Environment (getArgs)
@@ -51,33 +57,90 @@ data Error
 
 instance A.ToJSON Error
 
+toCompilerErrors :: NE.NonEmpty CST.ParserError -> Error
+toCompilerErrors = CompilerErrors . toJsonErrors . CST.toMultipleErrors "<file>"
+
+toJsonErrors :: P.MultipleErrors -> [P.JSONError]
+toJsonErrors = P.toJSONErrors False P.Error
+
+-- As of PureScript 0.14 we only need the `codegen` part of `MakeActions` to run
+-- Try PureScript, because we already know all dependencies are compiled, we're
+-- only building one module, we don't allow FFI declarations, and we want to
+-- avoid writing to the file system as much as possible.
+buildMakeActions :: IORef.IORef (Maybe JS) -> Make.MakeActions Make.Make
+buildMakeActions codegenRef =
+  Make.MakeActions
+    getInputTimestampsAndHashes
+    getOutputTimestamp
+    readExterns
+    codegen
+    ffiCodegen
+    progress
+    readCacheDb
+    writeCacheDb
+    outputPrimDocs
+  where
+  getInputTimestampsAndHashes :: P.ModuleName -> Make.Make (Either Make.RebuildPolicy (M.Map FilePath (UTCTime, Make.Make Cache.ContentHash)))
+  getInputTimestampsAndHashes _ = pure $ Right M.empty
+
+  getOutputTimestamp :: P.ModuleName -> Make.Make (Maybe UTCTime)
+  getOutputTimestamp _ = pure Nothing
+
+  readExterns :: P.ModuleName -> Make.Make (FilePath, Maybe P.ExternsFile)
+  readExterns _ = pure ("<file>", Nothing)
+
+  codegen :: CF.Module CF.Ann -> Docs.Module -> P.ExternsFile -> P.SupplyT Make.Make ()
+  codegen m _ _ = do
+    rawJs <- J.moduleToJs m Nothing
+    lift $ liftIO $ IORef.writeIORef codegenRef $ Just $ P.prettyPrintJS rawJs
+
+  -- If we ever support FFI implementations in Try PureScript then we will need
+  -- to implement this function. However, we do not plan to support this feature.
+  ffiCodegen :: CF.Module CF.Ann -> Make.Make ()
+  ffiCodegen _ = pure ()
+
+  progress :: Make.ProgressMessage -> Make.Make ()
+  progress _ = pure ()
+
+  readCacheDb :: Make.Make Cache.CacheDb
+  readCacheDb = pure M.empty
+
+  writeCacheDb :: Cache.CacheDb -> Make.Make ()
+  writeCacheDb _ = pure ()
+
+  outputPrimDocs :: Make.Make ()
+  outputPrimDocs = pure ()
+
 server :: [P.ExternsFile] -> P.Env -> P.Environment -> Int -> IO ()
 server externs initNamesEnv initEnv port = do
+  codegenRef <- IORef.newIORef Nothing
+  let makeActions = buildMakeActions codegenRef
   let compile :: Text -> IO (Either Error ([P.JSONError], JS))
       compile input
-        | T.length input > 20000 = return (Left (OtherError "Please limit your input to 20000 characters"))
+        | T.length input > 20000 = return $ Left $ OtherError "Please limit your input to 20000 characters"
         | otherwise = do
-          case CST.parseModuleFromFile "<file>" input >>= CST.resFull of
-            Left parseError ->
-              return . Left . CompilerErrors . P.toJSONErrors False P.Error $ CST.toMultipleErrors "<file>" parseError
-            Right m | P.getModuleName m == P.ModuleName "Main" -> do
-              (resultMay, ws) <- runLogger' . runExceptT . flip runReaderT P.defaultOptions $ do
-                ((P.Module ss coms moduleName elaborated exps, env), nextVar) <- P.runSupplyT 0 $ do
-                  desugared <- P.desugar initNamesEnv externs [P.importPrim m] >>= \case
-                    [d] -> pure d
-                    _ -> error "desugaring did not produce one module"
-                  P.runCheck' (P.emptyCheckState initEnv) $ P.typeCheckModule desugared
-                regrouped <- P.createBindingGroups moduleName . P.collapseBindingGroups $ elaborated
-                let mod' = P.Module ss coms moduleName regrouped exps
-                    corefn = CF.moduleToCoreFn env mod'
-                    [renamed] = P.renameInModules [corefn]
-                unless (null . CF.moduleForeign $ renamed) . throwError . P.errorMessage $ P.MissingFFIModule moduleName
-                P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs renamed Nothing
-              case resultMay of
-                Left errs -> (return . Left . CompilerErrors . P.toJSONErrors False P.Error) errs
-                Right js -> (return . Right) (P.toJSONErrors False P.Error ws, js)
-            Right _ ->
-              (return . Left . OtherError) "The name of the main module should be Main."
+          case CST.parseModuleFromFile "<file>" input of
+            Left parserErrors ->
+              return $ Left $ toCompilerErrors parserErrors
+
+            Right partialResult -> case CST.resFull partialResult of
+              (_, Left parserErrors) ->
+                return $ Left $ toCompilerErrors parserErrors
+
+              (parserWarnings, Right m) | P.getModuleName m == P.ModuleName "Main" -> do
+                (makeResult, warnings) <- Make.runMake P.defaultOptions $ Make.rebuildModule makeActions [] m
+                codegenResult <- IORef.readIORef codegenRef
+                return $ case makeResult of
+                  Left errors ->
+                    Left $ CompilerErrors $ toJsonErrors errors
+                  Right _ | Just js <- codegenResult -> do
+                    let ws = warnings <> CST.toMultipleWarnings "<file>" parserWarnings
+                    Right (toJsonErrors ws, js)
+                  Right _ ->
+                    Left $ OtherError "Failed to read the results of codegen."
+
+              (_, Right _) ->
+                return $ Left $ OtherError "The name of the main module should be Main."
 
   scottyOpts (getOpts port) $ do
     get "/" $
@@ -102,7 +165,8 @@ server externs initNamesEnv initEnv port = do
               search = fst . TS.typeSearch (Just []) initEnv (P.emptyCheckState initEnv)
               results = nubBy ((==) `on` fst) $ do
                 elab <- elabs
-                let strictMatches = search (replaceTypeVariablesAndDesugar (\nm s -> P.Skolem P.NullSourceAnn nm s (P.SkolemScope 0)) elab)
+                let mkSkolemType nm s = P.Skolem P.NullSourceAnn nm Nothing s (P.SkolemScope 0)
+                    strictMatches = search (replaceTypeVariablesAndDesugar mkSkolemType elab)
                     flexMatches = search (replaceTypeVariablesAndDesugar (const (P.TUnknown P.NullSourceAnn)) elab)
                 take 50 (strictMatches ++ flexMatches)
           Scotty.json $ A.object [ "results" .= [ P.showQualified id k
@@ -154,7 +218,7 @@ tryParseType = hush . fmap (CST.convertType "<file>") . runParser CST.parseTypeP
 
     runParser :: CST.Parser a -> Text -> Either String a
     runParser p =
-      first (CST.prettyPrintError . NE.head)
+      bimap (CST.prettyPrintError . NE.head) snd
         . CST.runTokenParser (p <* CSTM.token CST.TokEof)
         . CST.lexTopLevel
 

stack.yaml

@@ -8,7 +8,13 @@ flags:
 packages:
 - '.'
 extra-deps:
-- purescript-0.13.8
+# purescript 0.14.0-rc5
+- github: purescript/purescript
+  commit: 7ecc42669c69682996f2196ba2eef6c4ca827348
+  subdirs:
+    - .
+    - lib/purescript-ast
+    - lib/purescript-cst
 - happy-1.19.9
 - language-javascript-0.7.0.0
 - network-3.0.1.1

stack.yaml.lock

@@ -4,13 +4,6 @@
 #   https://docs.haskellstack.org/en/stable/lock_files
 
 packages:
-- completed:
-    hackage: purescript-0.13.8@sha256:c2855514c6f7da4b5f5e3b1020597111d2982b69f460d1c33b7e9f6c9ea8159c,57030
-    pantry-tree:
-      size: 87513
-      sha256: cea6e1c20819da05656655fa905cc7c96c9f95bede437db06d237550384655c4
-  original:
-    hackage: purescript-0.13.8
 - completed:
     hackage: happy-1.19.9@sha256:f8c774230735a390c287b2980cfcd2703d24d8dde85a01ea721b7b4b4c82944f,4667
     pantry-tree:

trypurescript.cabal

@@ -21,7 +21,8 @@ executable trypurescript
                    filepath -any,
                    Glob -any,
                    scotty -any,
-                   purescript ==0.13.8,
+                   purescript,
+                   purescript-cst,
                    containers -any,
                    http-types >= 0.8.5,
                    transformers ==0.5.*,