-
Notifications
You must be signed in to change notification settings - Fork 258
/
Evaluate.hs
1635 lines (1413 loc) · 59.9 KB
/
Evaluate.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{-# LANGUAGE NoOverloadedStrings, NoImplicitPrelude, TypeSynonymInstances, GADTs, CPP #-}
{- | Description : Wrapper around GHC API, exposing a single `evaluate` interface that runs
a statement, declaration, import, or directive.
This module exports all functions used for evaluation of IHaskell input.
-}
module IHaskell.Eval.Evaluate (
interpret,
testInterpret,
testEvaluate,
evaluate,
flushWidgetMessages,
Interpreter,
liftIO,
typeCleaner,
formatType,
capturedIO,
) where
import IHaskellPrelude
import Control.Concurrent (forkIO, threadDelay)
import Data.Foldable (foldMap)
import Prelude (head, tail, last, init)
import qualified Data.Set as Set
import Data.Char as Char
import Data.Dynamic
import qualified Data.Binary as Binary
import System.Directory
import System.Posix.IO (fdToHandle)
import System.IO (hGetChar, hSetEncoding, utf8)
import System.Random (getStdGen, randomRs)
import System.Process
import System.Exit
import System.Environment (getEnv)
#if MIN_VERSION_ghc(9,4,0)
import qualified GHC.Runtime.Debugger as Debugger
import GHC.Runtime.Eval
import GHC.Driver.Session
import GHC.Unit.State
import Control.Monad.Catch as MC
import GHC.Utils.Outputable hiding ((<>))
import GHC.Data.Bag
import GHC.Driver.Backend
import GHC.Driver.Env
import GHC.Driver.Ppr
import GHC.Runtime.Context
import GHC.Types.Error
import GHC.Types.SourceError
import GHC.Unit.Types (UnitId)
import qualified GHC.Utils.Error as ErrUtils
#elif MIN_VERSION_ghc(9,2,0)
import qualified GHC.Runtime.Debugger as Debugger
import GHC.Runtime.Eval
import GHC.Driver.Session
import GHC.Unit.State
import Control.Monad.Catch as MC
import GHC.Utils.Outputable hiding ((<>))
import GHC.Data.Bag
import GHC.Driver.Backend
import GHC.Driver.Ppr
import GHC.Runtime.Context
import GHC.Types.SourceError
import GHC.Unit.Types (UnitId)
import qualified GHC.Utils.Error as ErrUtils
#elif MIN_VERSION_ghc(9,0,0)
import qualified GHC.Runtime.Debugger as Debugger
import GHC.Runtime.Eval
import GHC.Driver.Session
import GHC.Driver.Types
import GHC.Unit.State
import Control.Monad.Catch as MC
import GHC.Utils.Outputable hiding ((<>))
import GHC.Data.Bag
import GHC.Unit.Types (UnitId)
import qualified GHC.Utils.Error as ErrUtils
#else
import qualified Debugger
import Bag
import DynFlags
import HscTypes
import InteractiveEval
import Exception hiding (evaluate)
import GhcMonad (liftIO)
import Outputable hiding ((<>))
import Packages
import qualified ErrUtils
#endif
import qualified GHC.Paths
import GHC hiding (Stmt, TypeSig)
import IHaskell.CSS (ihaskellCSS)
import IHaskell.Types
import IHaskell.IPython
import IHaskell.Eval.Parser
import IHaskell.Display
import qualified IHaskell.Eval.Hoogle as Hoogle
import IHaskell.Eval.Util
import IHaskell.BrokenPackages
import StringUtils (replace, split, strip, rstrip)
#ifdef USE_HLINT
import IHaskell.Eval.Lint
#endif
#if MIN_VERSION_ghc(8,4,0)
import qualified Data.Text as Text
import IHaskell.Eval.Evaluate.HTML (htmlify)
#endif
#if MIN_VERSION_ghc(9,0,0)
import GHC.Data.FastString
#elif MIN_VERSION_ghc(8,2,0)
import FastString (unpackFS)
#else
import Paths_ihaskell (version)
import Data.Version (versionBranch)
#endif
#if MIN_VERSION_ghc(9,2,0)
showSDocUnqual :: DynFlags -> SDoc -> String
showSDocUnqual = showSDoc
#endif
#if MIN_VERSION_ghc(9,0,0)
gcatch :: Ghc a -> (SomeException -> Ghc a) -> Ghc a
gcatch = MC.catch
gtry :: IO a -> IO (Either SomeException a)
gtry = MC.try
gfinally :: Ghc a -> Ghc b -> Ghc a
gfinally = MC.finally
ghandle :: (MonadCatch m, Exception e) => (e -> m a) -> m a -> m a
ghandle = MC.handle
throw :: SomeException -> Ghc a
throw = MC.throwM
#endif
-- | Set GHC's verbosity for debugging
ghcVerbosity :: Maybe Int
ghcVerbosity = Nothing -- Just 5
ignoreTypePrefixes :: [String]
ignoreTypePrefixes = [ "GHC.Types"
, "GHC.Base"
, "GHC.Show"
, "System.IO"
, "GHC.Float"
, ":Interactive"
, "GHC.Num"
, "GHC.IO"
, "GHC.Integer.Type"
]
typeCleaner :: String -> String
typeCleaner = useStringType . foldl' (.) id (map (`replace` "") fullPrefixes)
where
fullPrefixes = map (++ ".") ignoreTypePrefixes
useStringType = replace "[Char]" "String"
-- MonadIO constraint necessary for GHC 7.6
write :: (MonadIO m, GhcMonad m) => KernelState -> String -> m ()
write state x = when (kernelDebug state) $ liftIO $ hPutStrLn stderr $ "DEBUG: " ++ x
type Interpreter = Ghc
requiredGlobalImports :: [String]
requiredGlobalImports =
[ "import qualified Prelude as IHaskellPrelude"
, "import qualified System.Directory as IHaskellDirectory"
, "import qualified System.Posix.IO as IHaskellIO"
, "import qualified System.IO as IHaskellSysIO"
, "import qualified Language.Haskell.TH as IHaskellTH"
]
ihaskellGlobalImports :: [String]
ihaskellGlobalImports =
[ "import IHaskell.Display()"
, "import qualified IHaskell.Display"
, "import qualified IHaskell.IPython.Stdin"
, "import qualified IHaskell.Eval.Widgets"
]
hiddenPackageNames :: Set.Set String
hiddenPackageNames = Set.fromList ["ghc-lib", "ghc-lib-parser"]
-- | Interpreting function for testing.
testInterpret :: Interpreter a -> IO a
testInterpret v = interpret GHC.Paths.libdir False False (const v)
-- | Evaluation function for testing.
testEvaluate :: String -> IO ()
testEvaluate str = void $ testInterpret $
evaluate defaultKernelState str (\_ _ -> return ()) (\state _ -> return state)
-- | Run an interpreting action. This is effectively runGhc with initialization
-- and importing. The `allowedStdin` argument indicates whether `stdin` is
-- handled specially, which cannot be done in a testing environment. The
-- `needsSupportLibraries` argument indicates whether we want support libraries
-- to be imported, which is not the case during testing. The argument passed to
-- the action indicates whether the IHaskell library is available.
interpret :: String -> Bool -> Bool -> (Bool -> Interpreter a) -> IO a
interpret libdir allowedStdin needsSupportLibraries action = runGhc (Just libdir) $ do
-- If we're in a sandbox, add the relevant package database
sandboxPackages <- liftIO getSandboxPackageConf
initGhci sandboxPackages
case ghcVerbosity of
Just verb -> do
dflags <- getSessionDynFlags
void $ setSessionDynFlags $ dflags { verbosity = verb }
Nothing -> return ()
hasSupportLibraries <- initializeImports needsSupportLibraries
-- Close stdin so it can't be used. Otherwise it'll block the kernel forever.
dir <- liftIO getIHaskellDir
let cmd = printf "IHaskell.IPython.Stdin.fixStdin \"%s\"" dir
when (allowedStdin && hasSupportLibraries) $ void $
execStmt cmd execOptions
initializeItVariable
-- Run the rest of the interpreter
action hasSupportLibraries
#if MIN_VERSION_ghc(9,4,0)
packageIdString' :: Logger -> DynFlags -> HscEnv -> UnitInfo -> IO String
packageIdString' logger dflags hsc_env pkg_cfg = do
(_, unitState, _, _) <- initUnits logger dflags Nothing (hsc_all_home_unit_ids hsc_env)
case (lookupUnit unitState $ mkUnit pkg_cfg) of
Nothing -> pure "(unknown)"
Just cfg -> let
PackageName name = unitPackageName cfg
in pure $ unpackFS name
#elif MIN_VERSION_ghc(9,2,0)
packageIdString' :: Logger -> DynFlags -> UnitInfo -> IO String
packageIdString' logger dflags pkg_cfg = do
(_, unitState, _, _) <- initUnits logger dflags Nothing
case (lookupUnit unitState $ mkUnit pkg_cfg) of
Nothing -> pure "(unknown)"
Just cfg -> let
PackageName name = unitPackageName cfg
in pure $ unpackFS name
#elif MIN_VERSION_ghc(9,0,0)
packageIdString' :: DynFlags -> UnitInfo -> String
packageIdString' dflags pkg_cfg =
case (lookupUnit (unitState dflags) $ mkUnit pkg_cfg) of
Nothing -> "(unknown)"
Just cfg -> let
PackageName name = unitPackageName cfg
in unpackFS name
#elif MIN_VERSION_ghc(8,2,0)
packageIdString' :: DynFlags -> PackageConfig -> String
packageIdString' dflags pkg_cfg =
case (lookupPackage dflags $ packageConfigId pkg_cfg) of
Nothing -> "(unknown)"
Just cfg -> let
PackageName name = packageName cfg
in unpackFS name
#else
packageIdString' :: DynFlags -> PackageConfig -> String
packageIdString' dflags pkg_cfg =
fromMaybe "(unknown)" (unitIdPackageIdString dflags $ packageConfigId pkg_cfg)
#endif
#if MIN_VERSION_ghc(9,4,0)
getPackageConfigs :: Logger -> DynFlags -> HscEnv -> IO [GenUnitInfo UnitId]
getPackageConfigs logger dflags hsc_env = do
(pkgDb, _, _, _) <- initUnits logger dflags Nothing (hsc_all_home_unit_ids hsc_env)
pure $ foldMap unitDatabaseUnits pkgDb
#elif MIN_VERSION_ghc(9,2,0)
getPackageConfigs :: Logger -> DynFlags -> IO [GenUnitInfo UnitId]
getPackageConfigs logger dflags = do
(pkgDb, _, _, _) <- initUnits logger dflags Nothing
pure $ foldMap unitDatabaseUnits pkgDb
#elif MIN_VERSION_ghc(9,0,0)
getPackageConfigs :: DynFlags -> [GenUnitInfo UnitId]
getPackageConfigs dflags =
foldMap unitDatabaseUnits pkgDb
where
Just pkgDb = unitDatabases dflags
#else
getPackageConfigs :: DynFlags -> [PackageConfig]
getPackageConfigs dflags =
foldMap snd pkgDb
where
Just pkgDb = pkgDatabase dflags
#endif
-- | Initialize our GHC session with imports and a value for 'it'. Return whether the IHaskell
-- library is available.
initializeImports :: Bool -> Interpreter Bool
initializeImports importSupportLibraries = do
-- Load packages that start with ihaskell-*, aren't just IHaskell, and depend directly on the right
-- version of the ihaskell library. Also verify that the packages we load are not broken.
dflags <- getSessionDynFlags
broken <- liftIO getBrokenPackages
#if MIN_VERSION_ghc(9,2,0)
let dflgs = dflags
#elif MIN_VERSION_ghc(9,0,0)
dflgs <- liftIO $ initUnits dflags
#else
(dflgs, _) <- liftIO $ initPackages dflags
#endif
#if MIN_VERSION_ghc(9,4,0)
logger <- getLogger
hsc_env <- getSession
db <- liftIO $ getPackageConfigs logger dflgs hsc_env
packageNames <- liftIO $ mapM (packageIdString' logger dflgs hsc_env) db
let hiddenPackages = Set.intersection hiddenPackageNames (Set.fromList packageNames)
hiddenFlags = fmap HidePackage $ Set.toList hiddenPackages
initStr = "ihaskell-"
#elif MIN_VERSION_ghc(9,2,0)
logger <- getLogger
db <- liftIO $ getPackageConfigs logger dflgs
packageNames <- liftIO $ mapM (packageIdString' logger dflgs) db
let hiddenPackages = Set.intersection hiddenPackageNames (Set.fromList packageNames)
hiddenFlags = fmap HidePackage $ Set.toList hiddenPackages
initStr = "ihaskell-"
#else
let db = getPackageConfigs dflgs
packageNames = map (packageIdString' dflgs) db
hiddenPackages = Set.intersection hiddenPackageNames (Set.fromList packageNames)
hiddenFlags = fmap HidePackage $ Set.toList hiddenPackages
initStr = "ihaskell-"
#endif
#if MIN_VERSION_ghc(8,2,0)
-- Name of the ihaskell package, i.e. "ihaskell"
iHaskellPkgName = "ihaskell"
#else
-- Name of the ihaskell package, e.g. "ihaskell-1.2.3.4"
iHaskellPkgName = initStr ++ intercalate "." (map show (versionBranch version))
#endif
displayPkgs = [ pkgName
| pkgName <- packageNames
, Just (x:_) <- [stripPrefix initStr pkgName]
, pkgName `notElem` broken
, isAlpha x ]
hasIHaskellPackage = not $ null $ filter (== iHaskellPkgName) packageNames
-- Generate import statements all Display modules.
let capitalize :: String -> String
capitalize [] = []
capitalize (first:rest) = Char.toUpper first : rest
importFmt = "import IHaskell.Display.%s"
#if MIN_VERSION_ghc(8,2,0)
toImportStmt :: String -> String
toImportStmt = printf importFmt . concatMap capitalize . drop 1 . split "-"
#else
dropFirstAndLast :: [a] -> [a]
dropFirstAndLast = reverse . drop 1 . reverse . drop 1
toImportStmt :: String -> String
toImportStmt = printf importFmt . concatMap capitalize . dropFirstAndLast . split "-"
#endif
displayImports = map toImportStmt displayPkgs
void $ setSessionDynFlags $ dflgs { packageFlags = packageFlags dflgs ++ hiddenFlags }
#if MIN_VERSION_ghc(9,6,0)
-- Import implicit prelude.
importDecl <- parseImportDecl "import Prelude"
let implicitPrelude = importDecl { ideclExt = (ideclExt importDecl) { ideclImplicit = True } }
#else
-- Import implicit prelude.
importDecl <- parseImportDecl "import Prelude"
let implicitPrelude = importDecl { ideclImplicit = True }
#endif
displayImports' = if importSupportLibraries then displayImports else []
-- Import modules.
imports <- mapM parseImportDecl $ requiredGlobalImports ++ if hasIHaskellPackage
then ihaskellGlobalImports ++ displayImports'
else []
setContext $ map IIDecl $ implicitPrelude : imports
return hasIHaskellPackage
-- | Give a value for the `it` variable.
initializeItVariable :: Interpreter ()
initializeItVariable =
-- This is required due to the way we handle `it` in the wrapper statements - if it doesn't exist,
-- the first statement will fail.
void $ execStmt "let it = ()" execOptions
-- | Publisher for IHaskell outputs. The first argument indicates whether this output is final
-- (true) or intermediate (false). The second argument indicates whether the evaluation
-- completed successfully (Success) or an error occurred (Failure).
type Publisher = (EvaluationResult -> ErrorOccurred -> IO ())
-- | Output of a command evaluation.
data EvalOut =
EvalOut
{ evalStatus :: ErrorOccurred
, evalResult :: Display
, evalState :: KernelState
, evalPager :: [DisplayData]
, evalMsgs :: [WidgetMsg]
}
cleanString :: String -> String
cleanString istr = if allBrackets
then clean
else istr
where
str = strip istr
l = lines str
allBrackets = all (fAny [isPrefixOf ">", null]) l
fAny fs x = any ($ x) fs
clean = unlines $ map removeBracket l
removeBracket ('>':xs) = xs
removeBracket [] = []
-- should never happen:
removeBracket other = error $ "Expected bracket as first char, but got string: " ++ other
-- | Evaluate some IPython input code.
evaluate :: KernelState -- ^ The kernel state.
-> String -- ^ Haskell code or other interpreter commands.
-> Publisher -- ^ Function used to publish data outputs.
-> (KernelState -> [WidgetMsg] -> IO KernelState) -- ^ Function to handle widget messages
-> Interpreter (KernelState, ErrorOccurred)
evaluate kernelState code output widgetHandler = do
cmds <- parseString (cleanString code)
let execCount = getExecutionCounter kernelState
-- Extract all parse errors.
let justError x@ParseError{} = Just x
justError _ = Nothing
errs = mapMaybe (justError . unloc) cmds
(updated, errorOccurred) <- case errs of
-- Only run things if there are no parse errors.
[] -> do
#ifdef USE_HLINT
when (getLintStatus kernelState /= LintOff) $ liftIO $ do
lintSuggestions <- lint code cmds
unless (noResults lintSuggestions) $
output (FinalResult lintSuggestions [] []) Success
#endif
runUntilFailure kernelState (map unloc cmds ++ [storeItCommand execCount])
-- Print all parse errors.
_ -> do
forM_ errs $ \err -> do
out <- evalCommand output err kernelState
liftIO $ output
(FinalResult (evalResult out) [] [])
(evalStatus out)
return (kernelState, Failure)
return (updated { getExecutionCounter = execCount + 1 }, errorOccurred)
where
noResults (Display res) = null res
noResults (ManyDisplay res) = all noResults res
runUntilFailure :: KernelState -> [CodeBlock] -> Interpreter (KernelState, ErrorOccurred)
runUntilFailure state [] = return (state, Success)
runUntilFailure state (cmd:rest) = do
evalOut <- evalCommand output cmd state
-- Get displayed channel outputs. Merge them with normal display outputs.
dispsMay <- if supportLibrariesAvailable state
then do
getEncodedDisplays <- extractValue "IHaskell.Display.displayFromChanEncoded"
case getEncodedDisplays of
Left err -> error $ "Deserialization error (Evaluate.hs): " ++ err
Right displaysIO -> do
result <- liftIO displaysIO
case Binary.decodeOrFail result of
Left (_, _, err) -> error $ "Deserialization error (Evaluate.hs): " ++ err
Right (_, _, res) -> return res
else return Nothing
let result =
case dispsMay of
Nothing -> evalResult evalOut
Just disps -> evalResult evalOut <> disps
-- Output things only if they are non-empty.
unless (noResults result && null (evalPager evalOut)) $
liftIO $ output
(FinalResult result (evalPager evalOut) [])
(evalStatus evalOut)
let tempMsgs = evalMsgs evalOut
tempState = evalState evalOut { evalMsgs = [] }
-- Handle the widget messages
newState <- if supportLibrariesAvailable state
then flushWidgetMessages tempState tempMsgs widgetHandler
else return tempState
case evalStatus evalOut of
Success -> runUntilFailure newState rest
Failure -> return (newState, Failure)
storeItCommand execCount = Statement $ printf "let it%d = it" execCount
-- | Compile a string and extract a value from it. Effectively extract the result of an expression
-- from inside the notebook environment.
extractValue :: Typeable a => String -> Interpreter (Either String a)
extractValue expr = do
#if MIN_VERSION_ghc(9,0,0)
compiled <- gcatch (Right <$> dynCompileExpr expr) (\exc -> return (Left (show exc)))
case compiled of
Left exc -> return (Left exc)
Right dyn -> case fromDynamic dyn of
Nothing -> return (Left multipleIHaskells)
Just result -> return (Right result)
#else
compiled <- dynCompileExpr expr
case fromDynamic compiled of
Nothing -> return (Left multipleIHaskells)
Just result -> return (Right result)
#endif
where
multipleIHaskells =
concat
[ "The installed IHaskell support libraries do not match"
, " the instance of IHaskell you are running.\n"
, "This *may* cause problems with functioning of widgets or rich media displays.\n"
, "This is most often caused by multiple copies of IHaskell"
, " being installed simultaneously in your environment.\n"
, "To resolve this issue, clear out your environment and reinstall IHaskell.\n"
, "If you are installing support libraries, make sure you only do so once:\n"
, " # Run this without first running `stack install ihaskell`\n"
, " stack install ihaskell-diagrams\n"
, "If you continue to have problems, please file an issue on Github."
]
flushWidgetMessages :: KernelState
-> [WidgetMsg]
-> (KernelState -> [WidgetMsg] -> IO KernelState)
-> Interpreter KernelState
flushWidgetMessages state evalmsgs widgetHandler = do
-- Capture all widget messages queued during code execution
extracted <- extractValue "IHaskell.Eval.Widgets.relayWidgetMessages"
liftIO $
case extracted of
Left err -> do
hPutStrLn stderr "Disabling IHaskell widget support due to an encountered error:"
hPutStrLn stderr err
return state
Right messagesIO -> do
messages <- messagesIO
-- Handle all the widget messages
let commMessages = evalmsgs ++ messages
widgetHandler state commMessages
#if MIN_VERSION_ghc(9,6,0)
getErrMsgDoc :: ErrUtils.Diagnostic e => ErrUtils.MsgEnvelope e -> SDoc
getErrMsgDoc = ErrUtils.pprLocMsgEnvelopeDefault
#elif MIN_VERSION_ghc(9,4,0)
getErrMsgDoc :: ErrUtils.Diagnostic e => ErrUtils.MsgEnvelope e -> SDoc
getErrMsgDoc = ErrUtils.pprLocMsgEnvelope
#elif MIN_VERSION_ghc(9,2,0)
getErrMsgDoc :: ErrUtils.WarnMsg -> SDoc
getErrMsgDoc = ErrUtils.pprLocMsgEnvelope
#else
getErrMsgDoc :: ErrUtils.ErrMsg -> SDoc
getErrMsgDoc = ErrUtils.pprLocErrMsg
#endif
safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut
safely state = ghandle handler . ghandle sourceErrorHandler
where
handler :: SomeException -> Interpreter EvalOut
handler exception =
return
EvalOut
{ evalStatus = Failure
, evalResult = displayError $ show exception
, evalState = state
, evalPager = []
, evalMsgs = []
}
sourceErrorHandler :: SourceError -> Interpreter EvalOut
sourceErrorHandler srcerr = do
#if MIN_VERSION_ghc(9,4,0)
let msgs = bagToList . getMessages $ srcErrorMessages srcerr
#else
let msgs = bagToList $ srcErrorMessages srcerr
#endif
errStrs <- forM msgs $ doc . getErrMsgDoc
let fullErr = unlines errStrs
return
EvalOut
{ evalStatus = Failure
, evalResult = displayError fullErr
, evalState = state
, evalPager = []
, evalMsgs = []
}
wrapExecution :: KernelState
-> Interpreter Display
-> Interpreter EvalOut
wrapExecution state exec = safely state $
exec >>= \res ->
return
EvalOut
{ evalStatus = Success
, evalResult = res
, evalState = state
, evalPager = []
, evalMsgs = []
}
-- | Return the display data for this command, as well as whether it resulted in an error.
evalCommand :: Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut
evalCommand _ (Import importStr) state = wrapExecution state $ do
write state $ "Import: " ++ importStr
evalImport importStr
return mempty
evalCommand _ (Module contents) state = wrapExecution state $ do
write state $ "Module:\n" ++ contents
-- Write the module contents to a temporary file in our work directory
namePieces <- getModuleName contents
let directory = "./" ++ intercalate "/" (init namePieces) ++ "/"
filename = last namePieces ++ ".hs"
liftIO $ do
createDirectoryIfMissing True directory
writeFile (directory ++ filename) contents
-- Clear old modules of this name
let modName = intercalate "." namePieces
removeTarget $ TargetModule $ mkModuleName modName
removeTarget $ TargetFile filename Nothing
-- Remember which modules we've loaded before.
importedModules <- getContext
let
-- Get the dot-delimited pieces of the module name.
moduleNameOf :: InteractiveImport -> [String]
moduleNameOf (IIDecl decl) = split "." . moduleNameString . unLoc . ideclName $ decl
moduleNameOf (IIModule imp) = split "." . moduleNameString $ imp
-- Return whether this module prevents the loading of the one we're trying to load. If a module B
-- exist, we cannot load A.B. All modules must have unique last names (where A.B has last name B).
-- However, we *can* just reload a module.
preventsLoading md =
let pieces = moduleNameOf md
in last namePieces == last pieces && namePieces /= pieces
-- If we've loaded anything with the same last name, we can't use this. Otherwise, GHC tries to load
-- the original *.hs fails and then fails.
case find preventsLoading importedModules of
-- If something prevents loading this module, return an error.
Just previous -> do
let prevLoaded = intercalate "." (moduleNameOf previous)
return $ displayError $
printf "Can't load module %s because already loaded %s" modName prevLoaded
-- Since nothing prevents loading the module, compile and load it.
Nothing -> doLoadModule modName modName
-- | Directives set via `:set`.
evalCommand _output (Directive SetDynFlag flagsStr) state = safely state $ do
write state $ "All Flags: " ++ flagsStr
-- Find which flags are IHaskell flags, and which are GHC flags
let flags = words flagsStr
-- Get the kernel state updater for any IHaskell flag; Nothing for things that aren't IHaskell
-- flags.
ihaskellFlagUpdater :: String -> Maybe (KernelState -> KernelState)
ihaskellFlagUpdater flag = getUpdateKernelState <$> find (elem flag . getSetName) kernelOpts
(ihaskellFlags, ghcFlags) = partition (isJust . ihaskellFlagUpdater) flags
write state $ "IHaskell Flags: " ++ unwords ihaskellFlags
write state $ "GHC Flags: " ++ unwords ghcFlags
if null flags
then do
flgs <- getSessionDynFlags
return
EvalOut
{ evalStatus = Success
, evalResult = Display
[ plain $ showSDoc flgs $ vcat
[ pprDynFlags False flgs
, pprLanguages False flgs
]
]
, evalState = state
, evalPager = []
, evalMsgs = []
}
else do
-- Apply all IHaskell flag updaters to the state to get the new state
let state' = foldl' (.) id (mapMaybe ihaskellFlagUpdater ihaskellFlags) state
errs <- setFlags ghcFlags
let disp =
case errs of
[] -> mempty
_ -> displayError $ intercalate "\n" errs
-- For -XNoImplicitPrelude, remove the Prelude import. For -XImplicitPrelude, add it back in.
if "-XNoImplicitPrelude" `elem` flags
then evalImport "import qualified Prelude as Prelude"
else when ("-XImplicitPrelude" `elem` flags) $ do
importDecl <- parseImportDecl "import Prelude"
#if MIN_VERSION_ghc(9,6,0)
let implicitPrelude = importDecl { ideclExt = (ideclExt importDecl) { ideclImplicit = True } }
#else
let implicitPrelude = importDecl { ideclImplicit = True }
#endif
imports <- getContext
setContext $ IIDecl implicitPrelude : imports
return
EvalOut
{ evalStatus = Success
, evalResult = disp
, evalState = state'
, evalPager = []
, evalMsgs = []
}
evalCommand output (Directive SetExtension opts) state = do
write state $ "Extension: " ++ opts
let set = concatMap (" -X" ++) $ words opts
evalCommand output (Directive SetDynFlag set) state
evalCommand _output (Directive LoadModule mods) state = wrapExecution state $ do
write state $ "Load Module: " ++ mods
let stripped@(firstChar:remainder) = mods
(modules, removeModule) =
case firstChar of
'+' -> (words remainder, False)
'-' -> (words remainder, True)
_ -> (words stripped, False)
forM_ modules $ \modl -> if removeModule
then removeImport modl
else evalImport $ "import " ++ modl
return mempty
evalCommand _output (Directive SetOption opts) state = do
write state $ "Option: " ++ opts
let nonExisting = filter (not . optionExists) $ words opts
if not $ null nonExisting
then let err = "No such options: " ++ intercalate ", " nonExisting
in return
EvalOut
{ evalStatus = Failure
, evalResult = displayError err
, evalState = state
, evalPager = []
, evalMsgs = []
}
else let options = mapMaybe findOption $ words opts
updater = foldl' (.) id $ map getUpdateKernelState options
in return
EvalOut
{ evalStatus = Success
, evalResult = mempty
, evalState = updater state
, evalPager = []
, evalMsgs = []
}
where
optionExists = isJust . findOption
findOption opt =
find (elem opt . getOptionName) kernelOpts
evalCommand _ (Directive GetType expr) state = wrapExecution state $ do
write state $ "Type: " ++ expr
formatType <$> ((expr ++ " :: ") ++) <$> getType expr
evalCommand _ (Directive GetKind expr) state = wrapExecution state $ do
write state $ "Kind: " ++ expr
(_, kind) <- GHC.typeKind False expr
flags <- getSessionDynFlags
let typeStr = showSDocUnqual flags $ ppr kind
return $ formatType $ expr ++ " :: " ++ typeStr
evalCommand _ (Directive GetKindBang expr) state = wrapExecution state $ do
write state $ "Kind!: " ++ expr
(typ, kind) <- GHC.typeKind True expr
flags <- getSessionDynFlags
let kindStr = text expr <+> dcolon <+> ppr kind
let typeStr = equals <+> ppr typ
let finalStr = showSDocUnqual flags $ vcat [kindStr, typeStr]
return $ formatType finalStr
evalCommand _ (Directive LoadFile names) state = wrapExecution state $ do
write state $ "Load: " ++ names
displays <- forM (words names) $ \name -> do
let filename = if ".hs" `isSuffixOf` name
then name
else name ++ ".hs"
contents <- liftIO $ readFile filename
modName <- intercalate "." <$> getModuleName contents
doLoadModule filename modName
return (ManyDisplay displays)
evalCommand _ (Directive Reload _) state = wrapExecution state doReload
evalCommand publish (Directive ShellCmd cmd) state = wrapExecution state $
-- Assume the first character of 'cmd' is '!'.
case words $ drop 1 cmd of
"cd":dirs -> do
-- Get home so we can replace '~` with it.
homeEither <- liftIO (try $ getEnv "HOME" :: IO (Either SomeException String))
let home =
case homeEither of
Left _ -> "~"
Right v -> v
let directory = replace "~" home $ unwords dirs
exists <- liftIO $ doesDirectoryExist directory
if exists
then do
-- Set the directory in IHaskell native code, for future shell commands. This doesn't set it for
-- user code, though.
liftIO $ setCurrentDirectory directory
-- Set the directory for user code.
let cmd1 = printf "IHaskellDirectory.setCurrentDirectory \"%s\"" $
replace " " "\\ " $
replace "\"" "\\\"" directory
_ <- execStmt cmd1 execOptions
return mempty
else return $ displayError $ printf "No such directory: '%s'" directory
cmd1 -> liftIO $ do
(pipe, hdl) <- createPipe
let initProcSpec = shell $ unwords cmd1
procSpec = initProcSpec
{ std_in = Inherit
, std_out = UseHandle hdl
, std_err = UseHandle hdl
}
(_, _, _, process) <- createProcess procSpec
-- Accumulate output from the process.
outputAccum <- liftIO $ newMVar ""
-- Start a loop to publish intermediate results.
let
-- Compute how long to wait between reading pieces of the output. `threadDelay` takes an
-- argument of microseconds.
ms = 1000
delay = 100 * ms
-- Maximum size of the output (after which we truncate).
maxSize = 100 * 1000
incSize = 200
output str = publish $ IntermediateResult $ Display [plain str]
loop = do
-- Wait and then check if the computation is done.
threadDelay delay
-- Read next chunk and append to accumulator.
nextChunk <- readChars pipe "\n" incSize
modifyMVar_ outputAccum (return . (++ nextChunk))
-- Check if we're done.
mExitCode <- getProcessExitCode process
case mExitCode of
Nothing -> do
-- Write to frontend and repeat.
readMVar outputAccum >>= flip output Success
loop
Just exitCode -> do
next <- readChars pipe "" maxSize
modifyMVar_ outputAccum (return . (++ next))
out <- readMVar outputAccum
case exitCode of
ExitSuccess -> return $ Display [plain out]
ExitFailure code -> do
let errMsg = "Process exited with error code " ++ show code
return $ Display [plain $ out ++ "\n" ++ errMsg]
loop
-- This is taken largely from GHCi's info section in InteractiveUI.
evalCommand _ (Directive GetHelp _) state = do
write state "Help via :help or :?."
return
EvalOut
{ evalStatus = Success
, evalResult = Display [out]
, evalState = state
, evalPager = []
, evalMsgs = []
}
where
out = plain $ intercalate "\n"
[ "The following commands are available:"
, " :extension <Extension> - Enable a GHC extension."
, " :extension No<Extension> - Disable a GHC extension."
, " :type <expression> - Print expression type."
, " :info <name> - Print all info for a name."
, " :hoogle <query> - Search for a query on Hoogle."
, " :doc <ident> - Get documentation for an identifier via Hoogle."
, " :set -XFlag -Wall - Set an option (like ghci)."
, " :option <opt> - Set an option."
, " :option no-<opt> - Unset an option."
, " :?, :help - Show this help text."
, " :sprint <value> - Print a value without forcing evaluation."
, ""
, "Any prefix of the commands will also suffice, e.g. use :ty for :type."
, ""
, "Options:"
, " lint – enable or disable linting."
, " svg – use svg output (cannot be resized)."
, " show-types – show types of all bound names"
, " show-errors – display Show instance missing errors normally."
, " pager – use the pager to display results of :info, :doc, :hoogle, etc."
]
-- This is taken largely from GHCi's info section in InteractiveUI.
evalCommand _ (Directive GetInfo str) state = safely state $ do
write state $ "Info: " ++ str
-- Get all the info for all the names we're given.
strings <- unlines <$> getDescription str
return
EvalOut
{ evalStatus = Success
, evalResult = Display [
plain strings
#if MIN_VERSION_ghc(8,4,0)
, htmlify (Text.pack <$> htmlCodeWrapperClass state)
(Text.pack $ htmlCodeTokenPrefix state)
strings
#endif
]
, evalState = state
, evalPager = []
, evalMsgs = []
}
evalCommand _ (Directive SearchHoogle query) state = safely state $ do
results <- liftIO $ Hoogle.search query
return $ hoogleResults state results
evalCommand _ (Directive GetDoc query) state = safely state $ do
results <- liftIO $ Hoogle.document query
return $ hoogleResults state results
evalCommand _ (Directive SPrint binding) state = wrapExecution state $ do
flags <- getSessionDynFlags
contents <- liftIO $ newIORef []
#if MIN_VERSION_ghc(9,4,0)
let action = \_lflags _msgclass _srcspan msg -> modifyIORef' contents (showSDoc flags msg :)
#elif MIN_VERSION_ghc(9,0,0)
let action = \_dflags _warn _sev _srcspan msg -> modifyIORef' contents (showSDoc flags msg :)
#else
let action = \_dflags _sev _srcspan _ppr _style msg -> modifyIORef' contents (showSDoc flags msg :)
#endif
#if MIN_VERSION_ghc(9,2,0)
pushLogHookM (const action)
#else
let flags' = flags { log_action = action }
_ <- setSessionDynFlags flags'
#endif
Debugger.pprintClosureCommand False False binding
#if MIN_VERSION_ghc(9,2,0)
popLogHookM
#endif
_ <- setSessionDynFlags flags
sprint <- liftIO $ readIORef contents
return $ formatType (unlines sprint)
evalCommand output (Statement stmt) state = wrapExecution state $ evalStatementOrIO output state
(CapturedStmt stmt)
evalCommand output (Expression expr) state = do
write state $ "Expression:\n" ++ expr