Skip to content

Instantly share code, notes, and snippets.

@ndmitchell
Last active May 25, 2020 15:44
Show Gist options
  • Save ndmitchell/11467985dbf1855e62035fa97248a585 to your computer and use it in GitHub Desktop.
Save ndmitchell/11467985dbf1855e62035fa97248a585 to your computer and use it in GitHub Desktop.
Ghcide benchmark
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE PatternSynonyms #-}
module Benchmark(main) where
import Control.Applicative.Combinators
import Control.Monad
import Language.Haskell.LSP.Test
import Language.Haskell.LSP.Types
import Language.Haskell.LSP.Types.Capabilities
import Control.Monad.IO.Class
import System.Time.Extra
import Data.Maybe
main :: IO ()
main = do
print "starting test"
let dir = "C:/Neil/shake"
let cmd = unwords ["C:/Neil/ghcide/obj/ghcide", "--lsp", "--test", "--cwd", dir, "+RTS", "-N4"]
let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }
-- If you uncomment this you can see all logging
-- which can be quite useful for debugging.
-- { logStdErr = True, logColor = False }
-- If you really want to, you can also see all messages
-- { logMessages = True, logColor = False }
conf = defaultConfig -- { logStdErr = True, logMessages = True}
runSessionWithConfig conf cmd lspTestCaps dir $ do
doc <- openDoc "src/Test.hs" "haskell"
void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
liftIO $ putStrLn "Running getHover tests"
(t, _) <- duration2 $ replicateM_ 100 $ do
(t, res) <- duration2 $ getHover doc $ Position 127 43
when (isNothing res) $ fail "DIDN'T WORK"
liftIO $ putStrLn $ showDuration t
liftIO $ putStrLn $ "TOTAL = " ++ showDuration t
void $ getCodeLenses doc
duration2 :: MonadIO m => m a -> m (Seconds, a)
duration2 x = do
start <- liftIO offsetTime
res <- x
end <- liftIO start
return (end, res)
mkdir obj
REM -prof -fprof-auto -fprof-cafs
ghc -o obj/ghcide -O2 -outputdir obj -XBangPatterns -XDeriveFunctor -XDeriveGeneric -XGeneralizedNewtypeDeriving -XLambdaCase -XNamedFieldPuns -XOverloadedStrings -XRecordWildCards -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XViewPatterns -package=ghc -ignore-package=ghc-lib-parser -DGHC_STABLE -Iinclude -idist/build/autogen -isrc -iexe -iC:/Neil/shake/src -iC:/Neil/shake/dist/build/autogen Main -threaded
ghc -o obj/benchmark -outputdir obj -main-is Benchmark Benchmark
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment