Skip to content

Commit 52c81fc

Browse files
thomashoneymanthomashoneyman
authored
Update for PureScript 0.14 (#209)
1 parent a837f01 commit 52c81fc

File tree

4 files changed

+98
-34
lines changed

4 files changed

+98
-34
lines changed

‎server/Main.hs

+89-25
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@ module Main (main) where
77

88
import Control.Monad (unless, foldM)
99
import Control.Monad.Error.Class (throwError)
10+
import Control.Monad.IO.Class (liftIO)
1011
import Control.Monad.Logger (runLogger')
1112
import qualified Control.Monad.State as State
1213
import Control.Monad.Trans (lift)
@@ -15,25 +16,30 @@ import Control.Monad.Trans.Reader (runReaderT)
1516
import Control.Monad.Writer.Strict (runWriterT)
1617
import qualified Data.Aeson as A
1718
import Data.Aeson ((.=))
18-
import Data.Bifunctor (first, second)
19+
import Data.Bifunctor (first, second, bimap)
1920
import qualified Data.ByteString.Lazy as BL
2021
import Data.Default (def)
2122
import Data.Function (on)
23+
import qualified Data.IORef as IORef
2224
import Data.List (nubBy)
2325
import qualified Data.List.NonEmpty as NE
2426
import qualified Data.Map as M
2527
import Data.Text (Text)
2628
import qualified Data.Text as T
2729
import qualified Data.Text.Encoding as T
30+
import Data.Time.Clock (UTCTime)
2831
import GHC.Generics (Generic)
2932
import qualified Language.PureScript as P
3033
import qualified Language.PureScript.CST as CST
3134
import qualified Language.PureScript.CST.Monad as CSTM
3235
import qualified Language.PureScript.CodeGen.JS as J
3336
import qualified Language.PureScript.CodeGen.JS.Printer as P
3437
import qualified Language.PureScript.CoreFn as CF
38+
import qualified Language.PureScript.Docs.Types as Docs
3539
import qualified Language.PureScript.Errors.JSON as P
3640
import qualified Language.PureScript.Interactive as I
41+
import qualified Language.PureScript.Make as Make
42+
import qualified Language.PureScript.Make.Cache as Cache
3743
import qualified Language.PureScript.TypeChecker.TypeSearch as TS
3844
import qualified Network.Wai.Handler.Warp as Warp
3945
import System.Environment (getArgs)
@@ -51,33 +57,90 @@ data Error
5157

5258
instance A.ToJSON Error
5359

60+
toCompilerErrors :: NE.NonEmpty CST.ParserError -> Error
61+
toCompilerErrors = CompilerErrors . toJsonErrors . CST.toMultipleErrors "<file>"
62+
63+
toJsonErrors :: P.MultipleErrors -> [P.JSONError]
64+
toJsonErrors = P.toJSONErrors False P.Error
65+
66+
-- As of PureScript 0.14 we only need the `codegen` part of `MakeActions` to run
67+
-- Try PureScript, because we already know all dependencies are compiled, we're
68+
-- only building one module, we don't allow FFI declarations, and we want to
69+
-- avoid writing to the file system as much as possible.
70+
buildMakeActions :: IORef.IORef (Maybe JS) -> Make.MakeActions Make.Make
71+
buildMakeActions codegenRef =
72+
Make.MakeActions
73+
getInputTimestampsAndHashes
74+
getOutputTimestamp
75+
readExterns
76+
codegen
77+
ffiCodegen
78+
progress
79+
readCacheDb
80+
writeCacheDb
81+
outputPrimDocs
82+
where
83+
getInputTimestampsAndHashes :: P.ModuleName -> Make.Make (Either Make.RebuildPolicy (M.Map FilePath (UTCTime, Make.Make Cache.ContentHash)))
84+
getInputTimestampsAndHashes _ = pure $ Right M.empty
85+
86+
getOutputTimestamp :: P.ModuleName -> Make.Make (Maybe UTCTime)
87+
getOutputTimestamp _ = pure Nothing
88+
89+
readExterns :: P.ModuleName -> Make.Make (FilePath, Maybe P.ExternsFile)
90+
readExterns _ = pure ("<file>", Nothing)
91+
92+
codegen :: CF.Module CF.Ann -> Docs.Module -> P.ExternsFile -> P.SupplyT Make.Make ()
93+
codegen m _ _ = do
94+
rawJs <- J.moduleToJs m Nothing
95+
lift $ liftIO $ IORef.writeIORef codegenRef $ Just $ P.prettyPrintJS rawJs
96+
97+
-- If we ever support FFI implementations in Try PureScript then we will need
98+
-- to implement this function. However, we do not plan to support this feature.
99+
ffiCodegen :: CF.Module CF.Ann -> Make.Make ()
100+
ffiCodegen _ = pure ()
101+
102+
progress :: Make.ProgressMessage -> Make.Make ()
103+
progress _ = pure ()
104+
105+
readCacheDb :: Make.Make Cache.CacheDb
106+
readCacheDb = pure M.empty
107+
108+
writeCacheDb :: Cache.CacheDb -> Make.Make ()
109+
writeCacheDb _ = pure ()
110+
111+
outputPrimDocs :: Make.Make ()
112+
outputPrimDocs = pure ()
113+
54114
server :: [P.ExternsFile] -> P.Env -> P.Environment -> Int -> IO ()
55115
server externs initNamesEnv initEnv port = do
116+
codegenRef <- IORef.newIORef Nothing
117+
let makeActions = buildMakeActions codegenRef
56118
let compile :: Text -> IO (Either Error ([P.JSONError], JS))
57119
compile input
58-
| T.length input > 20000 = return (Left (OtherError "Please limit your input to 20000 characters"))
120+
| T.length input > 20000 = return $ Left $ OtherError "Please limit your input to 20000 characters"
59121
| otherwise = do
60-
case CST.parseModuleFromFile "<file>" input >>= CST.resFull of
61-
Left parseError ->
62-
return . Left . CompilerErrors . P.toJSONErrors False P.Error $ CST.toMultipleErrors "<file>" parseError
63-
Right m | P.getModuleName m == P.ModuleName "Main" -> do
64-
(resultMay, ws) <- runLogger' . runExceptT . flip runReaderT P.defaultOptions $ do
65-
((P.Module ss coms moduleName elaborated exps, env), nextVar) <- P.runSupplyT 0 $ do
66-
desugared <- P.desugar initNamesEnv externs [P.importPrim m] >>= \case
67-
[d] -> pure d
68-
_ -> error "desugaring did not produce one module"
69-
P.runCheck' (P.emptyCheckState initEnv) $ P.typeCheckModule desugared
70-
regrouped <- P.createBindingGroups moduleName . P.collapseBindingGroups $ elaborated
71-
let mod' = P.Module ss coms moduleName regrouped exps
72-
corefn = CF.moduleToCoreFn env mod'
73-
[renamed] = P.renameInModules [corefn]
74-
unless (null . CF.moduleForeign $ renamed) . throwError . P.errorMessage $ P.MissingFFIModule moduleName
75-
P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs renamed Nothing
76-
case resultMay of
77-
Left errs -> (return . Left . CompilerErrors . P.toJSONErrors False P.Error) errs
78-
Right js -> (return . Right) (P.toJSONErrors False P.Error ws, js)
79-
Right _ ->
80-
(return . Left . OtherError) "The name of the main module should be Main."
122+
case CST.parseModuleFromFile "<file>" input of
123+
Left parserErrors ->
124+
return $ Left $ toCompilerErrors parserErrors
125+
126+
Right partialResult -> case CST.resFull partialResult of
127+
(_, Left parserErrors) ->
128+
return $ Left $ toCompilerErrors parserErrors
129+
130+
(parserWarnings, Right m) | P.getModuleName m == P.ModuleName "Main" -> do
131+
(makeResult, warnings) <- Make.runMake P.defaultOptions $ Make.rebuildModule makeActions [] m
132+
codegenResult <- IORef.readIORef codegenRef
133+
return $ case makeResult of
134+
Left errors ->
135+
Left $ CompilerErrors $ toJsonErrors errors
136+
Right _ | Just js <- codegenResult -> do
137+
let ws = warnings <> CST.toMultipleWarnings "<file>" parserWarnings
138+
Right (toJsonErrors ws, js)
139+
Right _ ->
140+
Left $ OtherError "Failed to read the results of codegen."
141+
142+
(_, Right _) ->
143+
return $ Left $ OtherError "The name of the main module should be Main."
81144

82145
scottyOpts (getOpts port) $ do
83146
get "/" $
@@ -102,7 +165,8 @@ server externs initNamesEnv initEnv port = do
102165
search = fst . TS.typeSearch (Just []) initEnv (P.emptyCheckState initEnv)
103166
results = nubBy ((==) `on` fst) $ do
104167
elab <- elabs
105-
let strictMatches = search (replaceTypeVariablesAndDesugar (\nm s -> P.Skolem P.NullSourceAnn nm s (P.SkolemScope 0)) elab)
168+
let mkSkolemType nm s = P.Skolem P.NullSourceAnn nm Nothing s (P.SkolemScope 0)
169+
strictMatches = search (replaceTypeVariablesAndDesugar mkSkolemType elab)
106170
flexMatches = search (replaceTypeVariablesAndDesugar (const (P.TUnknown P.NullSourceAnn)) elab)
107171
take 50 (strictMatches ++ flexMatches)
108172
Scotty.json $ A.object [ "results" .= [ P.showQualified id k
@@ -154,7 +218,7 @@ tryParseType = hush . fmap (CST.convertType "<file>") . runParser CST.parseTypeP
154218

155219
runParser :: CST.Parser a -> Text -> Either String a
156220
runParser p =
157-
first (CST.prettyPrintError . NE.head)
221+
bimap (CST.prettyPrintError . NE.head) snd
158222
. CST.runTokenParser (p <* CSTM.token CST.TokEof)
159223
. CST.lexTopLevel
160224

‎stack.yaml

+7-1
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,13 @@ flags:
88
packages:
99
- '.'
1010
extra-deps:
11-
- purescript-0.13.8
11+
# purescript 0.14.0-rc5
12+
- github: purescript/purescript
13+
commit: 7ecc42669c69682996f2196ba2eef6c4ca827348
14+
subdirs:
15+
- .
16+
- lib/purescript-ast
17+
- lib/purescript-cst
1218
- happy-1.19.9
1319
- language-javascript-0.7.0.0
1420
- network-3.0.1.1

‎stack.yaml.lock

-7
Original file line numberDiff line numberDiff line change
@@ -4,13 +4,6 @@
44
# https://docs.haskellstack.org/en/stable/lock_files
55

66
packages:
7-
- completed:
8-
hackage: purescript-0.13.8@sha256:c2855514c6f7da4b5f5e3b1020597111d2982b69f460d1c33b7e9f6c9ea8159c,57030
9-
pantry-tree:
10-
size: 87513
11-
sha256: cea6e1c20819da05656655fa905cc7c96c9f95bede437db06d237550384655c4
12-
original:
13-
hackage: purescript-0.13.8
147
- completed:
158
hackage: happy-1.19.9@sha256:f8c774230735a390c287b2980cfcd2703d24d8dde85a01ea721b7b4b4c82944f,4667
169
pantry-tree:

‎trypurescript.cabal

+2-1
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,8 @@ executable trypurescript
2121
filepath -any,
2222
Glob -any,
2323
scotty -any,
24-
purescript ==0.13.8,
24+
purescript,
25+
purescript-cst,
2526
containers -any,
2627
http-types >= 0.8.5,
2728
transformers ==0.5.*,

0 commit comments

Comments
 (0)