@@ -1,11 +1,14 @@
11-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
22-- SPDX-License-Identifier: Apache-2.0
33
4−module Demo(main) where
4+module Main(main) where
55
6+import Arguments
67import Data.Maybe
8+import Data.List.Extra
9+import System.FilePath
710import Control.Concurrent.Extra
8−import Control.Monad
11+import Control.Monad.Extra
912import Data.Default
1013import System.Time.Extra
1114import Development.IDE.Core.FileStore
@@ -22,7 +25,7 @@ import Development.IDE.Types.Logger
2225import qualified Data.Text.IO as T
2326import Language.Haskell.LSP.Messages
2427import Development.IDE.LSP.LanguageServer
25−import System.Directory
28+import System.Directory.Extra as IO
2629import System.Environment
2730import System.IO
2831import Development.Shake hiding (Env)
@@ -44,36 +47,68 @@ main :: IO ()
4447main = do
4548 -- WARNING: If you write to stdout before runLanguageServer
4649 -- then the language server will not work
47− hPutStrLn stderr "Starting hie-core Demo"
48− args <- getArgs
50+ hPutStrLn stderr "Starting hie-core"
51+ Arguments{..} <- getArguments
52+
4953 -- lock to avoid overlapping output on stdout
5054 lock <- newLock
5155 let logger = makeOneLogger $ withLock lock . T.putStrLn
5256
57+ whenJust argsCwd setCurrentDirectory
58+
5359 dir <- getCurrentDirectory
5460 hPutStrLn stderr dir
5561
56− cradle <- findCradle (dir <> "/")
57−
58− let options = defaultIdeOptions $ liftIO $ newSession' cradle
59−
60− if "--lsp" `elem` args then do
61− hPutStrLn stderr "Starting IDE server"
62+ if argLSP then do
63+ t <- offsetTime
64+ hPutStrLn stderr "Starting LSP server..."
6265 runLanguageServer def def $ \event vfs -> do
63− hPutStrLn stderr "Server started"
66+ t <- t
67+ hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
68+ let options = defaultIdeOptions $ liftIO $ newSession' =<< findCradle (dir <> "/")
6469 initialise (mainRule >> action kick) event logger options vfs
6570 else do
66− let files = map toNormalizedFilePath $ filter (/= "--lsp") args
71+ putStrLn "[1/6] Finding hie-bios cradle"
72+ cradle <- findCradle (dir <> "/")
73+ print cradle
74+
75+ putStrLn "\n[2/6] Converting Cradle to GHC session"
76+ env <- newSession' cradle
77+
78+ putStrLn "\n[3/6] Initialising IDE session"
6779 vfs <- makeVFSHandle
68− ide <- initialise mainRule (showEvent lock) logger options vfs
69− setFilesOfInterest ide $ Set.fromList files
70− runAction ide kick
71− -- shake now writes an async message that it is completed with timing info,
72− -- so we sleep briefly to wait for it to have been written
73− sleep 0.01
80+ ide <- initialise mainRule (showEvent lock) logger (defaultIdeOptions $ return env) vfs
81+
82+ putStrLn "\n[4/6] Finding interesting files"
83+ files <- nubOrd <$> expandFiles (argFiles ++ ["." | null argFiles])
84+ putStrLn $ "Found " ++ show (length files) ++ " files"
85+
86+ putStrLn "\n[5/6] Setting interesting files"
87+ setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files
88+
89+ putStrLn "\n[6/6] Loading interesting files"
90+ results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files
91+ let (worked, failed) = partition fst $ zip (map isJust results) files
92+ putStrLn $ "Files that worked: " ++ show (length worked)
93+ putStrLn $ "Files that failed: " ++ show (length failed)
94+ putStr $ unlines $ map ((++) " * " . snd) failed
95+
7496 putStrLn "Done"
7597
7698
99+expandFiles :: [FilePath] -> IO [FilePath]
100+expandFiles = concatMapM $ \x -> do
101+ b <- IO.doesFileExist x
102+ if b then return [x] else do
103+ let recurse "." = True
104+ recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
105+ recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
106+ files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> listFilesInside (return . recurse) x
107+ when (null files) $
108+ fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
109+ return files
110+
111+
77112kick :: Action ()
78113kick = do
79114 files <- getFilesOfInterest