@@ -0,0 +1,104 @@
1+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
2+-- SPDX-License-Identifier: Apache-2.0
3+
4+module Demo(main) where
5+
6+import Control.Concurrent.Extra
7+import Control.Monad
8+import System.Time.Extra
9+import Development.IDE.State.Service
10+import Development.IDE.State.Rules
11+import Development.IDE.State.Shake
12+import Development.IDE.State.RuleTypes
13+import Development.IDE.Types.Diagnostics
14+import Development.IDE.Types.Options
15+import Development.IDE.Logger
16+import qualified Data.Text.IO as T
17+import System.Environment
18+import Data.List
19+import Data.Maybe
20+import System.FilePath
21+import Data.Tuple.Extra
22+import System.IO.Extra
23+import Development.IDE.Types.LSP
24+import Development.Shake hiding (Env)
25+import qualified Data.Set as Set
26+
27+import CmdLineParser
28+import DynFlags
29+import Panic
30+import GHC
31+import GHC.Paths
32+
33+
34+main :: IO ()
35+main = do
36+ (ghcOptions, files) <- getCmdLine
37+
38+ -- lock to avoid overlapping output on stdout
39+ lock <- newLock
40+
41+ ide <- initialise
42+ mainRule
43+ (Just $ showEvent lock)
44+ (makeOneHandle $ withLock lock . T.putStrLn)
45+ IdeOptions
46+ {optPreprocessor = (,) []
47+ ,optWriteIface = False
48+ ,optGhcSession = liftIO $ newSession ghcOptions
49+ ,optExtensions = ["hs"]
50+ ,optPkgLocationOpts = error "optPkgLocationOpts not implemented yet"
51+ ,optThreads = 0
52+ ,optShakeProfiling = Nothing -- Just "output.html"
53+ }
54+ setFilesOfInterest ide $ Set.fromList files
55+ _ <- runAction ide $ uses_ TypeCheck files
56+ -- shake now writes an async message that it is completed with timing info,
57+ -- so we sleep briefly to wait for it to have been written
58+ sleep 0.01
59+ putStrLn "Done"
60+
61+
62+-- | Print an LSP event.
63+showEvent :: Lock -> Event -> IO ()
64+showEvent _ (EventFileDiagnostics (_, [])) = return ()
65+showEvent lock (EventFileDiagnostics (file, diags)) =
66+ withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,) diags
67+showEvent lock e = withLock lock $ print e
68+
69+
70+-- | Create a GHC session that will be subsequently reused.
71+newSession :: [String] -> IO HscEnv
72+newSession flags = runGhc (Just libdir) $ do
73+ damlDFlags <- getSessionDynFlags
74+ (dflags', leftover, warns) <- parseDynamicFlagsCmdLine damlDFlags $ map noLoc flags
75+
76+ let leftoverError = CmdLineError $
77+ (unlines . ("Unable to parse custom flags:":) . map unLoc) leftover
78+ unless (null leftover) $ liftIO $ throwGhcExceptionIO leftoverError
79+
80+ unless (null warns) $
81+ liftIO $ putStrLn $ unlines $ "Warnings:" : map (unLoc . warnMsg) warns
82+
83+ _ <- setSessionDynFlags dflags'
84+ getSession
85+
86+
87+-- | Convert the command line into GHC options and files to load.
88+getCmdLine :: IO ([String], [FilePath])
89+getCmdLine = do
90+ args <- getArgs
91+ args <- return $ if null args then [".ghci"] else args
92+ let (flags, files) = partition ("-" `isPrefixOf`) args
93+ let (ghci, hs) = partition ((==) ".ghci" . takeExtension) files
94+ (flags, files) <- both concat . unzip . ((flags,hs):) <$> mapM readGhci ghci
95+ when (null files) $
96+ fail "Expected some files to load, but didn't find any"
97+ return (flags, files)
98+
99+readGhci :: FilePath -> IO ([String], [FilePath])
100+readGhci file = do
101+ xs <- lines <$> readFileUTF8' file
102+ let flags = concatMap words $ mapMaybe (stripPrefix ":set ") xs
103+ let files = concatMap words $ mapMaybe (stripPrefix ":load ") xs
104+ return (flags, files)