Skip to content

Commit fe4a131

Browse files
kritzcreekhdgarrood
kritzcreek
authored and
hdgarrood
committed
Updates for GHC 8.6.4 (purescript#3560)
* Updates for GHC 8.6.4 * updates for the newest "network" version * Enable -XNoMonadFailDesugaring This enables us to remove all references to MonadFail * Update tests to avoid using failable patterns * Revert changes to Interactive and Publish * Revert change to Prelude import in Control.Monad.Logger
1 parent 5b0cf58 commit fe4a131

File tree

10 files changed

+78
-59
lines changed

10 files changed

+78
-59
lines changed

‎app/Command/Ide.hs‎

Lines changed: 25 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -37,43 +37,39 @@ import Language.PureScript.Ide.Util
3737
import Language.PureScript.Ide.Error
3838
import Language.PureScript.Ide.Types
3939
import Language.PureScript.Ide.Watcher
40-
import Network hiding (socketPort, accept)
41-
import Network.BSD (getProtocolNumber)
42-
import Network.Socket hiding (PortNumber, Type,
43-
sClose)
40+
import qualified Network.Socket as Network
4441
import qualified Options.Applicative as Opts
4542
import System.Directory
4643
import System.Info as SysInfo
4744
import System.FilePath
4845
import System.IO hiding (putStrLn, print)
4946
import System.IO.Error (isEOFError)
5047

51-
listenOnLocalhost :: PortNumber -> IO Socket
48+
listenOnLocalhost :: Network.PortNumber -> IO Network.Socket
5249
listenOnLocalhost port = do
53-
proto <- getProtocolNumber "tcp"
54-
localhost <- inet_addr "127.0.0.1"
50+
addr:_ <- Network.getAddrInfo Nothing (Just "127.0.0.1") (Just (show port))
5551
bracketOnError
56-
(socket AF_INET Stream proto)
57-
sClose
52+
(Network.socket (Network.addrFamily addr) (Network.addrSocketType addr) (Network.addrProtocol addr))
53+
Network.close
5854
(\sock -> do
59-
setSocketOption sock ReuseAddr 1
60-
bind sock (SockAddrInet port localhost)
61-
listen sock maxListenQueue
55+
Network.setSocketOption sock Network.ReuseAddr 1
56+
Network.bind sock (Network.addrAddress addr)
57+
Network.listen sock Network.maxListenQueue
6258
pure sock)
6359

6460
data ServerOptions = ServerOptions
6561
{ _serverDirectory :: Maybe FilePath
6662
, _serverGlobs :: [FilePath]
6763
, _serverOutputPath :: FilePath
68-
, _serverPort :: PortNumber
64+
, _serverPort :: Network.PortNumber
6965
, _serverNoWatch :: Bool
7066
, _serverPolling :: Bool
7167
, _serverLoglevel :: IdeLogLevel
7268
, _serverEditorMode :: Bool
7369
} deriving (Show)
7470

7571
data ClientOptions = ClientOptions
76-
{ clientPort :: PortID
72+
{ clientPort :: Network.PortNumber
7773
}
7874

7975
command :: Opts.Parser (IO ())
@@ -96,15 +92,18 @@ command = Opts.helper <*> subcommands where
9692
T.putStrLn ("Couldn't connect to purs ide server on port " <> show clientPort <> ":")
9793
print e
9894
exitFailure
99-
h <- connectTo "127.0.0.1" clientPort `catch` handler
95+
addr:_ <- Network.getAddrInfo Nothing (Just "127.0.0.1") (Just (show clientPort))
96+
sock <- Network.socket (Network.addrFamily addr) (Network.addrSocketType addr) (Network.addrProtocol addr)
97+
Network.connect sock (Network.addrAddress addr) `catch` handler
98+
h <- Network.socketToHandle sock ReadWriteMode
10099
T.hPutStrLn h =<< T.getLine
101100
BS8.putStrLn =<< BS8.hGetLine h
102101
hFlush stdout
103102
hClose h
104103

105104
clientOptions :: Opts.Parser ClientOptions
106-
clientOptions = ClientOptions . PortNumber . fromIntegral <$>
107-
Opts.option Opts.auto (Opts.long "port" <> Opts.short 'p' <> Opts.value (4242 :: Integer))
105+
clientOptions = ClientOptions . fromIntegral <$>
106+
Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer))
108107

109108
server :: ServerOptions -> IO ()
110109
server opts'@(ServerOptions dir globs outputPath port noWatch polling logLevel editorMode) = do
@@ -159,12 +158,12 @@ command = Opts.helper <*> subcommands where
159158
-- #2209 and #2414 for explanations
160159
flipIfWindows = map (if SysInfo.os == "mingw32" then not else identity)
161160

162-
startServer :: PortNumber -> IdeEnvironment -> IO ()
163-
startServer port env = withSocketsDo $ do
161+
startServer :: Network.PortNumber -> IdeEnvironment -> IO ()
162+
startServer port env = Network.withSocketsDo $ do
164163
sock <- listenOnLocalhost port
165164
runLogger (confLogLevel (ideConfiguration env)) (runReaderT (forever (loop sock)) env)
166165
where
167-
loop :: (Ide m, MonadLogger m) => Socket -> m ()
166+
loop :: (Ide m, MonadLogger m) => Network.Socket -> m ()
168167
loop sock = do
169168
accepted <- runExceptT (acceptCommand sock)
170169
case accepted of
@@ -197,8 +196,10 @@ catchGoneHandle =
197196
putText ("[Error] psc-ide-server tried interact with the handle, but the connection was already gone.")
198197
_ -> throwIO e)
199198

200-
acceptCommand :: (MonadIO m, MonadLogger m, MonadError Text m)
201-
=> Socket -> m (Text, Handle)
199+
acceptCommand
200+
:: (MonadIO m, MonadLogger m, MonadError Text m)
201+
=> Network.Socket
202+
-> m (Text, Handle)
202203
acceptCommand sock = do
203204
h <- acceptConnection
204205
$(logDebug) "Accepted a connection"
@@ -216,8 +217,8 @@ acceptCommand sock = do
216217
where
217218
acceptConnection = liftIO $ do
218219
-- Use low level accept to prevent accidental reverse name resolution
219-
(s,_) <- accept sock
220-
h <- socketToHandle s ReadWriteMode
220+
(s,_) <- Network.accept sock
221+
h <- Network.socketToHandle s ReadWriteMode
221222
hSetEncoding h utf8
222223
hSetBuffering h LineBuffering
223224
pure h

‎package.yaml‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -38,7 +38,7 @@ dependencies:
3838
- aeson-better-errors >=0.8
3939
- ansi-terminal >=0.7.1 && <0.9
4040
- array
41-
- base >=4.8 && <4.12
41+
- base >=4.8 && <4.13
4242
- base-compat >=0.6.0
4343
- blaze-html >=0.8.1 && <0.10
4444
- bower-json >=1.0.0.1 && <1.1
@@ -109,6 +109,7 @@ library:
109109
- ScopedTypeVariables
110110
- TupleSections
111111
- ViewPatterns
112+
- NoMonadFailDesugaring
112113

113114
executables:
114115
purs:

‎src/Language/PureScript/Ide/CaseSplit.hs‎

Lines changed: 18 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -45,18 +45,24 @@ explicitAnnotations = WildcardAnnotations True
4545
noAnnotations :: WildcardAnnotations
4646
noAnnotations = WildcardAnnotations False
4747

48-
caseSplit :: (Ide m, MonadError IdeError m) =>
49-
Text -> m [Constructor]
48+
type DataType = ([(Text, Maybe P.SourceKind)], [(P.ProperName 'P.ConstructorName, [P.SourceType])])
49+
50+
caseSplit
51+
:: (Ide m, MonadError IdeError m)
52+
=> Text
53+
-> m [Constructor]
5054
caseSplit q = do
5155
type' <- parseType' q
5256
(tc, args) <- splitTypeConstructor type'
53-
(EDType _ _ (P.DataType typeVars ctors)) <- findTypeDeclaration tc
57+
(typeVars, ctors) <- findTypeDeclaration tc
5458
let applyTypeVars = P.everywhereOnTypes (P.replaceAllTypeVars (zip (map fst typeVars) args))
5559
let appliedCtors = map (second (map applyTypeVars)) ctors
5660
pure appliedCtors
5761

58-
findTypeDeclaration :: (Ide m, MonadError IdeError m) =>
59-
P.ProperName 'P.TypeName -> m ExternsDeclaration
62+
findTypeDeclaration
63+
:: (Ide m, MonadError IdeError m)
64+
=> P.ProperName 'P.TypeName
65+
-> m DataType
6066
findTypeDeclaration q = do
6167
efs <- getExternFiles
6268
efs' <- maybe efs (flip (uncurry M.insert) efs) <$> cachedRebuild
@@ -65,14 +71,15 @@ findTypeDeclaration q = do
6571
Just mn -> pure mn
6672
Nothing -> throwError (GeneralError "Not Found")
6773

68-
findTypeDeclaration' ::
69-
P.ProperName 'P.TypeName
74+
findTypeDeclaration'
75+
:: P.ProperName 'P.TypeName
7076
-> ExternsFile
71-
-> First ExternsDeclaration
77+
-> First DataType
7278
findTypeDeclaration' t ExternsFile{..} =
73-
First $ find (\case
74-
EDType tn _ _ -> tn == t
75-
_ -> False) efDeclarations
79+
First $ head $ mapMaybe (\case
80+
EDType tn _ (P.DataType typeVars ctors)
81+
| tn == t -> Just (typeVars, ctors)
82+
_ -> Nothing) efDeclarations
7683

7784
splitTypeConstructor :: (MonadError IdeError m) =>
7885
P.Type a -> m (P.ProperName 'P.TypeName, [P.Type a])

‎stack.yaml‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
resolver: lts-12.0
1+
resolver: lts-13.12
22
packages:
33
- '.'
44
extra-deps:

‎tests/Language/PureScript/Ide/ImportsSpec.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -49,9 +49,9 @@ syntaxErrorFile =
4949
]
5050

5151
testSliceImportSection :: [Text] -> (P.ModuleName, [Text], [Import], [Text])
52-
testSliceImportSection = fromRight . sliceImportSection
52+
testSliceImportSection = unsafeFromRight . sliceImportSection
5353
where
54-
fromRight = fromJust . rightToMaybe
54+
unsafeFromRight = fromJust . rightToMaybe
5555

5656
withImports :: [Text] -> [Text]
5757
withImports is =

‎tests/TestBundle.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -37,7 +37,8 @@ main = testSpec "bundle" spec
3737

3838
spec :: Spec
3939
spec = do
40-
(supportModules, supportExterns, supportForeigns, [bundleTestCases]) <- runIO $ setUpTests ["bundle"]
40+
(supportModules, supportExterns, supportForeigns) <- runIO $ setupSupportModules
41+
bundleTestCases <- runIO $ getTestFiles "bundle"
4142
outputFile <- runIO $ createOutputFile logfile
4243

4344
context "Bundle examples" $

‎tests/TestCompiler.hs‎

Lines changed: 8 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -51,8 +51,14 @@ main = testSpec "compiler" spec
5151

5252
spec :: Spec
5353
spec = do
54-
(supportModules, supportExterns, supportForeigns, [passingTestCases, warningTestCases, failingTestCases]) <- runIO $ setUpTests ["passing", "warning", "failing"]
55-
outputFile <- runIO $ createOutputFile logfile
54+
(supportModules, supportExterns, supportForeigns) <- runIO $ setupSupportModules
55+
56+
(passingTestCases, warningTestCases, failingTestCases) <- runIO $
57+
(,,) <$> getTestFiles "passing"
58+
<*> getTestFiles "warning"
59+
<*> getTestFiles "failing"
60+
61+
outputFile <- runIO $ createOutputFile logfile
5662

5763
context "Passing examples" $
5864
forM_ passingTestCases $ \testPurs ->

‎tests/TestDocs.hs‎

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -294,8 +294,8 @@ displayAssertionFailure = \case
294294
"in rendered code for " <> decl <> ", bad link location for " <> target <>
295295
": expected " <> T.pack (show expected) <>
296296
" got " <> T.pack (show actual)
297-
WrongOrder _ before after ->
298-
"expected to see " <> before <> " before " <> after
297+
WrongOrder _ before after' ->
298+
"expected to see " <> before <> " before " <> after'
299299

300300
displayTagsAssertionFailure :: TagsAssertionFailure -> Text
301301
displayTagsAssertionFailure = \case
@@ -438,22 +438,22 @@ runAssertion assertion linksCtx Docs.Module{..} =
438438
Nothing ->
439439
Fail (LinkedDeclarationMissing mn decl destTitle)
440440

441-
ShouldComeBefore mn before after ->
441+
ShouldComeBefore mn before after' ->
442442
let
443443
decls = declarationsFor mn
444444

445445
indexOf :: Text -> Maybe Int
446446
indexOf title = findIndex ((==) title . Docs.declTitle) decls
447447
in
448-
case (indexOf before, indexOf after) of
448+
case (indexOf before, indexOf after') of
449449
(Just i, Just j) ->
450450
if i < j
451451
then Pass
452-
else Fail (WrongOrder mn before after)
452+
else Fail (WrongOrder mn before after')
453453
(Nothing, _) ->
454454
Fail (NotDocumented mn before)
455455
(_, Nothing) ->
456-
Fail (NotDocumented mn after)
456+
Fail (NotDocumented mn after')
457457

458458
where
459459
declarationsFor mn =

‎tests/TestPscPublish.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -72,10 +72,10 @@ roundTrip pkg =
7272
in case A.eitherDecode before of
7373
Left err -> ParseFailed err
7474
Right parsed -> do
75-
let after = A.encode (parsed :: UploadedPackage)
76-
if before == after
75+
let after' = A.encode (parsed :: UploadedPackage)
76+
if before == after'
7777
then Pass before
78-
else Mismatch before after
78+
else Mismatch before after'
7979

8080
testRunOptions :: PublishOptions
8181
testRunOptions = defaultPublishOptions

‎tests/TestUtils.hs‎

Lines changed: 11 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -105,11 +105,8 @@ createOutputFile logfileName = do
105105
createDirectoryIfMissing False (tmp </> logpath)
106106
openFile (tmp </> logpath </> logfileName) WriteMode
107107

108-
setUpTests :: [FilePath] -> IO ([P.Module], [P.ExternsFile], M.Map P.ModuleName FilePath, [[[FilePath]]])
109-
setUpTests testDirs = do
110-
cwd <- getCurrentDirectory
111-
let testPaths = map (\p -> cwd </> "tests" </> "purs" </> p) testDirs
112-
testFiles <- mapM (\p -> getTestFiles p <$> testGlob p) testPaths
108+
setupSupportModules :: IO ([P.Module], [P.ExternsFile], M.Map P.ModuleName FilePath)
109+
setupSupportModules = do
113110
ms <- getSupportModuleTuples
114111
let modules = map snd ms
115112
supportExterns <- runExceptT $ do
@@ -118,16 +115,22 @@ setUpTests testDirs = do
118115
return (externs, foreigns)
119116
case supportExterns of
120117
Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)
121-
Right (externs, foreigns) -> return (modules, externs, foreigns, testFiles)
118+
Right (externs, foreigns) -> return (modules, externs, foreigns)
119+
120+
getTestFiles :: FilePath -> IO [[FilePath]]
121+
getTestFiles testDir = do
122+
cwd <- getCurrentDirectory
123+
let dir = cwd </> "tests" </> "purs" </> testDir
124+
getFiles dir <$> testGlob dir
122125
where
123126
-- A glob for all purs and js files within a test directory
124127
testGlob :: FilePath -> IO [FilePath]
125128
testGlob = Glob.globDir1 (Glob.compile "**/*.purs")
126129
-- Groups the test files so that a top-level file can have dependencies in a
127130
-- subdirectory of the same name. The inner tuple contains a list of the
128131
-- .purs files and the .js files for the test case.
129-
getTestFiles :: FilePath -> [FilePath] -> [[FilePath]]
130-
getTestFiles baseDir
132+
getFiles :: FilePath -> [FilePath] -> [[FilePath]]
133+
getFiles baseDir
131134
= map (filter ((== ".purs") . takeExtensions) . map (baseDir </>))
132135
. groupBy ((==) `on` extractPrefix)
133136
. sortBy (compare `on` extractPrefix)

0 commit comments

Comments
 (0)