diff --git a/server/Main.hs b/server/Main.hs index e22a696f..009fb7c0 100644 --- a/server/Main.hs +++ b/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,16 +16,18 @@ 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 @@ -32,8 +35,11 @@ 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 "" + +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 ("", 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 "" input >>= CST.resFull of - Left parseError -> - return . Left . CompilerErrors . P.toJSONErrors False P.Error $ CST.toMultipleErrors "" 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 "" 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 "" 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 "") . 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 diff --git a/stack.yaml b/stack.yaml index da5e2a7c..3854edaa 100644 --- a/stack.yaml +++ b/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 diff --git a/stack.yaml.lock b/stack.yaml.lock index 727cd4ac..9fb35a77 100644 --- a/stack.yaml.lock +++ b/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: diff --git a/trypurescript.cabal b/trypurescript.cabal index 2a7a990e..e2575430 100644 --- a/trypurescript.cabal +++ b/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.*,