Commit 7ba7c4d1 authored by Andrew Gibiansky's avatar Andrew Gibiansky

Merge pull request #444 from gibiansky/enforce-proper-formatting

Enforce proper formatting
parents be10d383 dadd074f
...@@ -16,3 +16,6 @@ todo ...@@ -16,3 +16,6 @@ todo
profile/profile.tar profile/profile.tar
.cabal-sandbox .cabal-sandbox
cabal.sandbox.config cabal.sandbox.config
.tmp1
.tmp2
.tmp3
...@@ -14,6 +14,7 @@ before_install: ...@@ -14,6 +14,7 @@ before_install:
- travis_retry sudo apt-get update - travis_retry sudo apt-get update
- travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex
- travis_retry sudo apt-get install libmagic-dev - travis_retry sudo apt-get install libmagic-dev
- travis_retry sudo apt-get install python3
- travis_retry git clone http://www.github.com/zeromq/zeromq4-x.git libzmq - travis_retry git clone http://www.github.com/zeromq/zeromq4-x.git libzmq
- export OLDPWD=$(pwd) && cd libzmq && travis_retry ./autogen.sh && travis_retry ./configure && make && travis_retry sudo make install && travis_retry sudo ldconfig && cd $OLDPWD - export OLDPWD=$(pwd) && cd libzmq && travis_retry ./autogen.sh && travis_retry ./configure && make && travis_retry sudo make install && travis_retry sudo ldconfig && cd $OLDPWD
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.cabal/bin:$PATH - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.cabal/bin:$PATH
...@@ -34,6 +35,8 @@ install: ...@@ -34,6 +35,8 @@ install:
- | - |
if [ ${GHCVER%.*} = "7.8" ]; then if [ ${GHCVER%.*} = "7.8" ]; then
travis_retry cabal install arithmoi==0.4.* -fllvm travis_retry cabal install arithmoi==0.4.* -fllvm
travis_retry git clone http://www.github.com/gibiansky/hindent
cd hindent && cabal install && cd ..
fi fi
# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail. # Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.
...@@ -47,7 +50,10 @@ script: ...@@ -47,7 +50,10 @@ script:
# Build and run the test suite # Build and run the test suite
- travis_retry cabal configure --enable-tests - travis_retry cabal configure --enable-tests
- travis_retry cabal test --show-details=always - travis_retry cabal test --show-details=always
- |
if [ ${GHCVER%.*} = "7.8" ]; then
./verify_formatting.py
fi
- cabal sdist - cabal sdist
# The following scriptlet checks that the resulting source distribution can be built & installed # The following scriptlet checks that the resulting source distribution can be built & installed
......
{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-} {-# LANGUAGE OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-}
module IHaskell.BrokenPackages (getBrokenPackages) where module IHaskell.BrokenPackages (getBrokenPackages) where
import ClassyPrelude hiding ((<|>)) import ClassyPrelude hiding ((<|>))
import Text.Parsec import Text.Parsec
import Text.Parsec.String import Text.Parsec.String
import Control.Applicative hiding ((<|>), many) import Control.Applicative hiding ((<|>), many)
import Data.String.Utils (startswith) import Data.String.Utils (startswith)
import Shelly import Shelly
data BrokenPackage = BrokenPackage { data BrokenPackage = BrokenPackage { packageID :: String, brokenDeps :: [String] }
packageID :: String,
brokenDeps :: [String]
}
instance Show BrokenPackage where instance Show BrokenPackage where
show = packageID show = packageID
-- | Get a list of broken packages. -- | Get a list of broken packages. This function internally shells out to `ghc-pkg`, and parses the
-- This function internally shells out to `ghc-pkg`, and parses the output -- output in order to determine what packages are broken.
-- in order to determine what packages are broken.
getBrokenPackages :: IO [String] getBrokenPackages :: IO [String]
getBrokenPackages = shelly $ do getBrokenPackages = shelly $ do
silently $ errExit False $ run "ghc-pkg" ["check"] silently $ errExit False $ run "ghc-pkg" ["check"]
checkOut <- lastStderr checkOut <- lastStderr
-- Get rid of extraneous things -- Get rid of extraneous things
let rightStart str = startswith "There are problems" str || let rightStart str = startswith "There are problems" str ||
startswith " dependency" str startswith " dependency" str
ghcPkgOutput = unlines . filter rightStart . lines $ unpack checkOut ghcPkgOutput = unlines . filter rightStart . lines $ unpack checkOut
return $ case parse (many check) "ghc-pkg output" ghcPkgOutput of return $
Left err -> [] case parse (many check) "ghc-pkg output" ghcPkgOutput of
Right pkgs -> map show pkgs Left err -> []
Right pkgs -> map show pkgs
check :: Parser BrokenPackage check :: Parser BrokenPackage
check = string "There are problems in package " check = string "There are problems in package "
......
-- | Description : mostly reversible conversion between ipynb and lhs -- | Description : mostly reversible conversion between ipynb and lhs
module IHaskell.Convert (convert) where module IHaskell.Convert (convert) where
import Control.Monad.Identity (Identity(Identity), unless, when)
import IHaskell.Convert.Args (ConvertSpec(ConvertSpec, convertInput, convertLhsStyle, convertOutput, convertOverwriteFiles, convertToIpynb), fromJustConvertSpec, toConvertSpec) import Control.Monad.Identity (Identity(Identity), unless, when)
import IHaskell.Convert.IpynbToLhs (ipynbToLhs) import IHaskell.Convert.Args (ConvertSpec(..), fromJustConvertSpec, toConvertSpec)
import IHaskell.Convert.LhsToIpynb (lhsToIpynb) import IHaskell.Convert.IpynbToLhs (ipynbToLhs)
import IHaskell.Flags (Argument) import IHaskell.Convert.LhsToIpynb (lhsToIpynb)
import System.Directory (doesFileExist) import IHaskell.Flags (Argument)
import Text.Printf (printf) import System.Directory (doesFileExist)
import Text.Printf (printf)
-- | used by @IHaskell convert@ -- | used by @IHaskell convert@
convert :: [Argument] -> IO () convert :: [Argument] -> IO ()
convert args = case fromJustConvertSpec (toConvertSpec args) of convert args =
ConvertSpec { convertToIpynb = Identity toIpynb, case fromJustConvertSpec (toConvertSpec args) of
convertInput = Identity inputFile, ConvertSpec
convertOutput = Identity outputFile, { convertToIpynb = Identity toIpynb
convertLhsStyle = Identity lhsStyle, , convertInput = Identity inputFile
convertOverwriteFiles = force } , convertOutput = Identity outputFile
, convertLhsStyle = Identity lhsStyle
, convertOverwriteFiles = force
}
| toIpynb -> do | toIpynb -> do
unless force (failIfExists outputFile) unless force (failIfExists outputFile)
lhsToIpynb lhsStyle inputFile outputFile lhsToIpynb lhsStyle inputFile outputFile
| otherwise -> do | otherwise -> do
unless force (failIfExists outputFile) unless force (failIfExists outputFile)
ipynbToLhs lhsStyle inputFile outputFile ipynbToLhs lhsStyle inputFile outputFile
-- | Call fail when the named file already exists. -- | Call fail when the named file already exists.
failIfExists :: FilePath -> IO () failIfExists :: FilePath -> IO ()
...@@ -29,5 +33,3 @@ failIfExists file = do ...@@ -29,5 +33,3 @@ failIfExists file = do
exists <- doesFileExist file exists <- doesFileExist file
when exists $ fail $ when exists $ fail $
printf "File %s already exists. To force supply --force." file printf "File %s already exists. To force supply --force." file
-- | Description: interpret flags parsed by "IHaskell.Flags" -- | Description: interpret flags parsed by "IHaskell.Flags"
module IHaskell.Convert.Args module IHaskell.Convert.Args (ConvertSpec(..), fromJustConvertSpec, toConvertSpec) where
(ConvertSpec(..),
fromJustConvertSpec,
toConvertSpec,
) where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad.Identity (Identity(Identity)) import Control.Monad.Identity (Identity(Identity))
import Data.Char (toLower) import Data.Char (toLower)
import Data.List (partition) import Data.List (partition)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import qualified Data.Text.Lazy as T (pack, Text) import qualified Data.Text.Lazy as T (pack, Text)
import IHaskell.Flags (Argument(..), LhsStyle, lhsStyleBird, NotebookFormat(..)) import IHaskell.Flags (Argument(..), LhsStyle, lhsStyleBird, NotebookFormat(..))
import System.FilePath ((<.>), dropExtension, takeExtension) import System.FilePath ((<.>), dropExtension, takeExtension)
import Text.Printf (printf) import Text.Printf (printf)
-- | ConvertSpec is the accumulator for command line arguments -- | ConvertSpec is the accumulator for command line arguments
data ConvertSpec f = ConvertSpec data ConvertSpec f =
{ convertToIpynb :: f Bool, ConvertSpec
convertInput :: f FilePath, { convertToIpynb :: f Bool
convertOutput :: f FilePath, , convertInput :: f FilePath
convertLhsStyle :: f (LhsStyle T.Text), , convertOutput :: f FilePath
convertOverwriteFiles :: Bool , convertLhsStyle :: f (LhsStyle T.Text)
} , convertOverwriteFiles :: Bool
}
-- | Convert a possibly-incomplete specification for what to convert -- | Convert a possibly-incomplete specification for what to convert into one which can be executed.
-- into one which can be executed. Calls error when data is missing. -- Calls error when data is missing.
fromJustConvertSpec :: ConvertSpec Maybe -> ConvertSpec Identity fromJustConvertSpec :: ConvertSpec Maybe -> ConvertSpec Identity
fromJustConvertSpec convertSpec = convertSpec { fromJustConvertSpec convertSpec = convertSpec
convertToIpynb = Identity toIpynb, { convertToIpynb = Identity toIpynb
convertInput = Identity inputFile, , convertInput = Identity inputFile
convertOutput = Identity outputFile, , convertOutput = Identity outputFile
convertLhsStyle = Identity $ fromMaybe , convertLhsStyle = Identity $ fromMaybe (T.pack <$> lhsStyleBird) (convertLhsStyle convertSpec)
(T.pack <$> lhsStyleBird) }
(convertLhsStyle convertSpec)
}
where where
toIpynb = fromMaybe (error "Error: direction for conversion unknown") toIpynb = fromMaybe (error "Error: direction for conversion unknown")
(convertToIpynb convertSpec) (convertToIpynb convertSpec)
(inputFile, outputFile) = case (convertInput convertSpec, convertOutput convertSpec) of (inputFile, outputFile) =
case (convertInput convertSpec, convertOutput convertSpec) of
(Nothing, Nothing) -> error "Error: no files specified for conversion" (Nothing, Nothing) -> error "Error: no files specified for conversion"
(Just i, Nothing) | toIpynb -> (i, dropExtension i <.> "ipynb") (Just i, Nothing)
| otherwise -> (i, dropExtension i <.> "lhs") | toIpynb -> (i, dropExtension i <.> "ipynb")
(Nothing, Just o) | toIpynb -> (dropExtension o <.> "lhs", o) | otherwise -> (i, dropExtension i <.> "lhs")
| otherwise -> (dropExtension o <.> "ipynb", o) (Nothing, Just o)
| toIpynb -> (dropExtension o <.> "lhs", o)
| otherwise -> (dropExtension o <.> "ipynb", o)
(Just i, Just o) -> (i, o) (Just i, Just o) -> (i, o)
-- | Does this @Argument@ explicitly request a file format? -- | Does this @Argument@ explicitly request a file format?
isFormatSpec :: Argument -> Bool isFormatSpec :: Argument -> Bool
isFormatSpec (ConvertToFormat _) = True isFormatSpec (ConvertToFormat _) = True
isFormatSpec (ConvertFromFormat _) = True isFormatSpec (ConvertFromFormat _) = True
isFormatSpec _ = False isFormatSpec _ = False
toConvertSpec :: [Argument] -> ConvertSpec Maybe toConvertSpec :: [Argument] -> ConvertSpec Maybe
toConvertSpec args = mergeArgs otherArgs toConvertSpec args = mergeArgs otherArgs (mergeArgs formatSpecArgs initialConvertSpec)
(mergeArgs formatSpecArgs initialConvertSpec)
where where
(formatSpecArgs, otherArgs) = partition isFormatSpec args (formatSpecArgs, otherArgs) = partition isFormatSpec args
initialConvertSpec = ConvertSpec Nothing Nothing Nothing Nothing False initialConvertSpec = ConvertSpec Nothing Nothing Nothing Nothing False
mergeArgs :: [Argument] -> ConvertSpec Maybe -> ConvertSpec Maybe mergeArgs :: [Argument] -> ConvertSpec Maybe -> ConvertSpec Maybe
mergeArgs args initialConvertSpec = foldr mergeArg initialConvertSpec args mergeArgs args initialConvertSpec = foldr mergeArg initialConvertSpec args
mergeArg :: Argument -> ConvertSpec Maybe -> ConvertSpec Maybe mergeArg :: Argument -> ConvertSpec Maybe -> ConvertSpec Maybe
mergeArg OverwriteFiles convertSpec = convertSpec { convertOverwriteFiles = True } mergeArg OverwriteFiles convertSpec = convertSpec { convertOverwriteFiles = True }
mergeArg (ConvertLhsStyle lhsStyle) convertSpec mergeArg (ConvertLhsStyle lhsStyle) convertSpec
| Just previousLhsStyle <- convertLhsStyle convertSpec, | Just previousLhsStyle <- convertLhsStyle convertSpec,
previousLhsStyle /= fmap T.pack lhsStyle = error $ printf previousLhsStyle /= fmap T.pack lhsStyle
"Conflicting lhs styles requested: <%s> and <%s>" = error $ printf "Conflicting lhs styles requested: <%s> and <%s>" (show lhsStyle)
(show lhsStyle) (show previousLhsStyle) (show previousLhsStyle)
| otherwise = convertSpec { convertLhsStyle = Just (T.pack <$> lhsStyle) } | otherwise = convertSpec { convertLhsStyle = Just (T.pack <$> lhsStyle) }
mergeArg (ConvertFrom inputFile) convertSpec mergeArg (ConvertFrom inputFile) convertSpec
| Just previousInputFile <- convertInput convertSpec, | Just previousInputFile <- convertInput convertSpec,
previousInputFile /= inputFile = error $ printf "Multiple input files specified: <%s> and <%s>" previousInputFile /= inputFile
inputFile previousInputFile = error $ printf "Multiple input files specified: <%s> and <%s>" inputFile previousInputFile
| otherwise = convertSpec { | otherwise = convertSpec
convertInput = Just inputFile, { convertInput = Just inputFile
convertToIpynb = case (convertToIpynb convertSpec, fromExt inputFile) of , convertToIpynb = case (convertToIpynb convertSpec, fromExt inputFile) of
(prev, Nothing) -> prev (prev, Nothing) -> prev
(prev @ (Just _), _) -> prev (prev@(Just _), _) -> prev
(Nothing, format) -> fmap (== LhsMarkdown) format (Nothing, format) -> fmap (== LhsMarkdown) format
} }
mergeArg (ConvertTo outputFile) convertSpec mergeArg (ConvertTo outputFile) convertSpec
| Just previousOutputFile <- convertOutput convertSpec, | Just previousOutputFile <- convertOutput convertSpec,
previousOutputFile /= outputFile = error $ printf "Multiple output files specified: <%s> and <%s>" previousOutputFile /= outputFile
outputFile previousOutputFile = error $ printf "Multiple output files specified: <%s> and <%s>" outputFile previousOutputFile
| otherwise = convertSpec { | otherwise = convertSpec
convertOutput = Just outputFile, { convertOutput = Just outputFile
convertToIpynb = case (convertToIpynb convertSpec, fromExt outputFile) of , convertToIpynb = case (convertToIpynb convertSpec, fromExt outputFile) of
(prev, Nothing) -> prev (prev, Nothing) -> prev
(prev @ (Just _), _) -> prev (prev@(Just _), _) -> prev
(Nothing, format) -> fmap (== IpynbFile) format (Nothing, format) -> fmap (== IpynbFile) format
} }
mergeArg unexpectedArg _ = error $ "IHaskell.Convert.mergeArg: impossible argument: " mergeArg unexpectedArg _ = error $ "IHaskell.Convert.mergeArg: impossible argument: "
++ show unexpectedArg ++ show unexpectedArg
-- | Guess the format based on the file extension. -- | Guess the format based on the file extension.
fromExt :: FilePath -> Maybe NotebookFormat fromExt :: FilePath -> Maybe NotebookFormat
fromExt s = case map toLower (takeExtension s) of fromExt s =
".lhs" -> Just LhsMarkdown case map toLower (takeExtension s) of
".ipynb" -> Just IpynbFile ".lhs" -> Just LhsMarkdown
_ -> Nothing ".ipynb" -> Just IpynbFile
_ -> Nothing
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module IHaskell.Convert.IpynbToLhs (ipynbToLhs) where module IHaskell.Convert.IpynbToLhs (ipynbToLhs) where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Data.Aeson (decode, Object, Value(Array, Object, String)) import Data.Aeson (decode, Object, Value(Array, Object, String))
import qualified Data.ByteString.Lazy as L (readFile) import qualified Data.ByteString.Lazy as L (readFile)
import qualified Data.HashMap.Strict as M (lookup) import qualified Data.HashMap.Strict as M (lookup)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), Monoid(mempty)) import Data.Monoid ((<>), Monoid(mempty))
import qualified Data.Text.Lazy as T (concat, fromStrict, Text, unlines) import qualified Data.Text.Lazy as T (concat, fromStrict, Text, unlines)
import qualified Data.Text.Lazy.IO as T (writeFile) import qualified Data.Text.Lazy.IO as T (writeFile)
import Data.Vector (Vector) import Data.Vector (Vector)
import qualified Data.Vector as V (map, mapM, toList) import qualified Data.Vector as V (map, mapM, toList)
import IHaskell.Flags (LhsStyle(lhsBeginCode, lhsBeginOutput, lhsCodePrefix, lhsEndCode, lhsEndOutput, lhsOutputPrefix)) import IHaskell.Flags (LhsStyle(..))
ipynbToLhs :: LhsStyle T.Text ipynbToLhs :: LhsStyle T.Text
-> FilePath -- ^ the filename of an ipython notebook -> FilePath -- ^ the filename of an ipython notebook
-> FilePath -- ^ the filename of the literate haskell to write -> FilePath -- ^ the filename of the literate haskell to write
-> IO () -> IO ()
ipynbToLhs sty from to = do ipynbToLhs sty from to = do
Just (js :: Object) <- decode <$> L.readFile from Just (js :: Object) <- decode <$> L.readFile from
case M.lookup "cells" js of case M.lookup "cells" js of
Just (Array cells) -> Just (Array cells) ->
T.writeFile to $ T.unlines $ V.toList T.writeFile to $ T.unlines $ V.toList $ V.map (\(Object y) -> convCell sty y) cells
$ V.map (\(Object y) -> convCell sty y) cells
_ -> error "IHaskell.Convert.ipynbTolhs: json does not follow expected schema" _ -> error "IHaskell.Convert.ipynbTolhs: json does not follow expected schema"
concatWithPrefix :: T.Text -- ^ the prefix to add to every line concatWithPrefix :: T.Text -- ^ the prefix to add to every line
-> Vector Value -- ^ a json array of text lines -> Vector Value -- ^ a json array of text lines
-> Maybe T.Text -> Maybe T.Text
concatWithPrefix p arr = T.concat . map (p <>) . V.toList <$> V.mapM toStr arr concatWithPrefix p arr = T.concat . map (p <>) . V.toList <$> V.mapM toStr arr
toStr :: Value -> Maybe T.Text toStr :: Value -> Maybe T.Text
toStr (String x) = Just (T.fromStrict x) toStr (String x) = Just (T.fromStrict x)
toStr _ = Nothing toStr _ = Nothing
-- | @convCell sty cell@ converts a single cell in JSON into text suitable -- | @convCell sty cell@ converts a single cell in JSON into text suitable for the type of lhs file
-- for the type of lhs file described by the @sty@ -- described by the @sty@
convCell :: LhsStyle T.Text -> Object -> T.Text convCell :: LhsStyle T.Text -> Object -> T.Text
convCell _sty object convCell _sty object
| Just (String "markdown") <- M.lookup "cell_type" object, | Just (String "markdown") <- M.lookup "cell_type" object,
Just (Array xs) <- M.lookup "source" object, Just (Array xs) <- M.lookup "source" object,
~ (Just s) <- concatWithPrefix "" xs = s ~(Just s) <- concatWithPrefix "" xs
= s
convCell sty object convCell sty object
| Just (String "code") <- M.lookup "cell_type" object, | Just (String "code") <- M.lookup "cell_type" object,
Just (Array i) <- M.lookup "source" object, Just (Array i) <- M.lookup "source" object,
Just (Array o) <- M.lookup "outputs" object, Just (Array o) <- M.lookup "outputs" object,
~ (Just i) <- concatWithPrefix (lhsCodePrefix sty) i, ~(Just i) <- concatWithPrefix (lhsCodePrefix sty) i,
o <- fromMaybe mempty (convOutputs sty o) = "\n" <> o <- fromMaybe mempty (convOutputs sty o)
lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o <> "\n" = "\n" <>
lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o <> "\n"
convCell _ _ = "IHaskell.Convert.convCell: unknown cell" convCell _ _ = "IHaskell.Convert.convCell: unknown cell"
convOutputs :: LhsStyle T.Text convOutputs :: LhsStyle T.Text
-> Vector Value -- ^ JSON array of output lines containing text or markup -> Vector Value -- ^ JSON array of output lines containing text or markup
-> Maybe T.Text -> Maybe T.Text
convOutputs sty array = do convOutputs sty array = do
outputLines <- V.mapM (getTexts (lhsOutputPrefix sty)) array outputLines <- V.mapM (getTexts (lhsOutputPrefix sty)) array
return $ lhsBeginOutput sty <> T.concat (V.toList outputLines) <> lhsEndOutput sty return $ lhsBeginOutput sty <> T.concat (V.toList outputLines) <> lhsEndOutput sty
getTexts :: T.Text -> Value -> Maybe T.Text getTexts :: T.Text -> Value -> Maybe T.Text
getTexts p (Object object) getTexts p (Object object)
| Just (Array text) <- M.lookup "text" object = concatWithPrefix p text | Just (Array text) <- M.lookup "text" object = concatWithPrefix p text
getTexts _ _ = Nothing getTexts _ _ = Nothing
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module IHaskell.Convert.LhsToIpynb (lhsToIpynb) where module IHaskell.Convert.LhsToIpynb (lhsToIpynb) where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad (mplus) import Control.Monad (mplus)
import Data.Aeson ((.=), encode, object, Value(Array, Bool, Number, String, Null)) import Data.Aeson ((.=), encode, object, Value(Array, Bool, Number, String, Null))
import qualified Data.ByteString.Lazy as L (writeFile) import qualified Data.ByteString.Lazy as L (writeFile)
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.Monoid (Monoid(mempty)) import Data.Monoid (Monoid(mempty))
import qualified Data.Text as TS (Text) import qualified Data.Text as TS (Text)
import qualified Data.Text.Lazy as T (dropWhile, lines, stripPrefix, Text, toStrict, snoc, strip) import qualified Data.Text.Lazy as T (dropWhile, lines, stripPrefix, Text, toStrict, snoc, strip)
import qualified Data.Text.Lazy.IO as T (readFile) import qualified Data.Text.Lazy.IO as T (readFile)
import qualified Data.Vector as V (fromList, singleton) import qualified Data.Vector as V (fromList, singleton)
import IHaskell.Flags (LhsStyle(LhsStyle)) import IHaskell.Flags (LhsStyle(LhsStyle))
lhsToIpynb :: LhsStyle T.Text -> FilePath -> FilePath -> IO () lhsToIpynb :: LhsStyle T.Text -> FilePath -> FilePath -> IO ()
lhsToIpynb sty from to = do lhsToIpynb sty from to = do
classed <- classifyLines sty . T.lines <$> T.readFile from classed <- classifyLines sty . T.lines <$> T.readFile from
L.writeFile to . encode . encodeCells $ groupClassified classed L.writeFile to . encode . encodeCells $ groupClassified classed
data CellLine a = CodeLine a | OutputLine a | MarkdownLine a data CellLine a = CodeLine a
deriving Show | OutputLine a
| MarkdownLine a
deriving Show
isCode :: CellLine t -> Bool isCode :: CellLine t -> Bool
isCode (CodeLine _) = True isCode (CodeLine _) = True
isCode _ = False isCode _ = False
isOutput :: CellLine t -> Bool isOutput :: CellLine t -> Bool
isOutput (OutputLine _) = True isOutput (OutputLine _) = True
isOutput _ = False isOutput _ = False
isMD :: CellLine t -> Bool isMD :: CellLine t -> Bool
isMD (MarkdownLine _) = True isMD (MarkdownLine _) = True
isMD _ = False isMD _ = False
isEmptyMD :: (Eq a, Monoid a) => CellLine a -> Bool isEmptyMD :: (Eq a, Monoid a) => CellLine a -> Bool
isEmptyMD (MarkdownLine a) = a == mempty isEmptyMD (MarkdownLine a) = a == mempty
isEmptyMD _ = False isEmptyMD _ = False
untag :: CellLine t -> t
untag :: CellLine t -> t
untag (CodeLine a) = a untag (CodeLine a) = a
untag (OutputLine a) = a untag (OutputLine a) = a
untag (MarkdownLine a) = a untag (MarkdownLine a) = a
data Cell a = Code a a | Markdown a data Cell a = Code a a
deriving (Show) | Markdown a
deriving Show
encodeCells :: [Cell [T.Text]] -> Value encodeCells :: [Cell [T.Text]] -> Value
encodeCells xs = object $ encodeCells xs = object $
[ "cells" .= Array (V.fromList (map cellToVal xs)) ] ["cells" .= Array (V.fromList (map cellToVal xs))]
++ boilerplate ++ boilerplate
cellToVal :: Cell [T.Text] -> Value cellToVal :: Cell [T.Text] -> Value
cellToVal (Code i o) = object $ cellToVal (Code i o) = object $
[ "cell_type" .= String "code", [ "cell_type" .= String "code"
"execution_count" .= Null, , "execution_count" .= Null
"metadata" .= object [ "collapsed" .= Bool False ], , "metadata" .= object ["collapsed" .= Bool False]
"source" .= arrayFromTxt i, , "source" .= arrayFromTxt i
"outputs" .= Array , "outputs" .= Array
(V.fromList ( (V.fromList
[ object ["text" .= arrayFromTxt o, ([object
"metadata" .= object [], [ "text" .= arrayFromTxt o
"output_type" .= String "display_data" ] , "metadata" .= object []
| _ <- take 1 o])) ] , "output_type" .= String "display_data"
] | _ <- take 1 o]))
]
cellToVal (Markdown txt) = object $ cellToVal (Markdown txt) = object $
[ "cell_type" .= String "markdown", [ "cell_type" .= String "markdown"
"metadata" .= object [ "hidden" .= Bool False ], , "metadata" .= object ["hidden" .= Bool False]
"source" .= arrayFromTxt txt ] , "source" .= arrayFromTxt txt
]
-- | arrayFromTxt makes a JSON array of string s -- | arrayFromTxt makes a JSON array of string s
arrayFromTxt :: [T.Text] -> Value arrayFromTxt :: [T.Text] -> Value
arrayFromTxt i = Array (V.fromList $ map stringify i) arrayFromTxt i = Array (V.fromList $ map stringify i)
where where
stringify = String . T.toStrict . flip T.snoc '\n' stringify = String . T.toStrict . flip T.snoc '\n'
-- | ihaskell needs this boilerplate at the upper level to interpret the -- | ihaskell needs this boilerplate at the upper level to interpret the json describing cells and
-- json describing cells and output correctly. -- output correctly.
boilerplate :: [(TS.Text, Value)] boilerplate :: [(TS.Text, Value)]
boilerplate = boilerplate =
[ "metadata" .= object [ kernelspec, lang ] ["metadata" .= object [kernelspec, lang], "nbformat" .= Number 4, "nbformat_minor" .= Number 0]
, "nbformat" .= Number 4
, "nbformat_minor" .= Number 0
]
where where
kernelspec = "kernelspec" .= object [ kernelspec = "kernelspec" .= object
"display_name" .= String "Haskell" [ "display_name" .= String "Haskell"
, "language" .= String "haskell" , "language" .= String "haskell"
, "name" .= String "haskell" , "name" .= String "haskell"
] ]
lang = "language_info" .= object [ lang = "language_info" .= object ["name" .= String "haskell", "version" .= String VERSION_ghc]
"name" .= String "haskell"
, "version" .= String VERSION_ghc
]
groupClassified :: [CellLine T.Text] -> [Cell [T.Text]] groupClassified :: [CellLine T.Text] -> [Cell [T.Text]]
groupClassified (CodeLine a : x) groupClassified (CodeLine a:x)
| (c,x) <- span isCode x, | (c, x) <- span isCode x,
(_,x) <- span isEmptyMD x, (_, x) <- span isEmptyMD x,
(o,x) <- span isOutput x = Code (a : map untag c) (map untag o) : groupClassified x (o, x) <- span isOutput x
groupClassified (MarkdownLine a : x) = Code (a : map untag c) (map untag o) : groupClassified x
| (m,x) <- span isMD x = Markdown (a: map untag m) : groupClassified x groupClassified (MarkdownLine a:x)
groupClassified (OutputLine a : x ) = Markdown [a] : groupClassified x | (m, x) <- span isMD x = Markdown (a : map untag m) : groupClassified x
groupClassified (OutputLine a:x) = Markdown [a] : groupClassified x
groupClassified [] = [] groupClassified [] = []
classifyLines :: LhsStyle T.Text -> [T.Text] -> [CellLine T.Text] classifyLines :: LhsStyle T.Text -> [T.Text] -> [CellLine T.Text]
classifyLines sty@(LhsStyle c o _ _ _ _) (l:ls) = case (sp c, sp o) of classifyLines sty@(LhsStyle c o _ _ _ _) (l:ls) =
(Just a, Nothing) -> CodeLine a : classifyLines sty ls case (sp c, sp o) of
(Nothing, Just a) -> OutputLine a : classifyLines sty ls (Just a, Nothing) -> CodeLine a : classifyLines sty ls
(Nothing,Nothing) -> MarkdownLine l : classifyLines sty ls (Nothing, Just a) -> OutputLine a : classifyLines sty ls
_ -> error "IHaskell.Convert.classifyLines" (Nothing, Nothing) -> MarkdownLine l : classifyLines sty ls
_ -> error "IHaskell.Convert.classifyLines"
where where
sp x = T.stripPrefix (dropSpace x) (dropSpace l) `mplus` blankCodeLine x sp x = T.stripPrefix (dropSpace x) (dropSpace l) `mplus` blankCodeLine x
blankCodeLine x = if T.strip x == T.strip l then Just "" else Nothing blankCodeLine x = if T.strip x == T.strip l
then Just ""
else Nothing
dropSpace = T.dropWhile isSpace dropSpace = T.dropWhile isSpace
classifyLines _ [] = [] classifyLines _ [] = []
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleInstances #-}
-- | If you are interested in the IHaskell library for the purpose of -- | If you are interested in the IHaskell library for the purpose of augmenting the IHaskell
-- augmenting the IHaskell notebook or writing your own display mechanisms -- notebook or writing your own display mechanisms and widgets, this module contains all functions
-- and widgets, this module contains all functions you need. -- you need.
-- --
-- In order to create a display mechanism for a particular data type, write -- In order to create a display mechanism for a particular data type, write a module named (for
-- a module named (for example) @IHaskell.Display.YourThing@ in a package named @ihaskell-yourThing@. -- example) @IHaskell.Display.YourThing@ in a package named @ihaskell-yourThing@. (Note the
-- (Note the capitalization - it's important!) Then, in that module, add an -- capitalization - it's important!) Then, in that module, add an instance of @IHaskellDisplay@ for
-- instance of @IHaskellDisplay@ for your data type. Similarly, to create -- your data type. Similarly, to create a widget, add an instance of @IHaskellWidget@.
-- a widget, add an instance of @IHaskellWidget@.
-- --
-- An example of creating a display is provided in the <http://gibiansky.github.io/IHaskell/demo.html demo notebook>. -- An example of creating a display is provided in the
-- <http://gibiansky.github.io/IHaskell/demo.html demo notebook>.
-- --
module IHaskell.Display ( module IHaskell.Display (
-- * Rich display and interactive display typeclasses and types -- * Rich display and interactive display typeclasses and types
IHaskellDisplay(..), IHaskellDisplay(..),
Display(..), Display(..),
DisplayData(..), DisplayData(..),
IHaskellWidget(..), IHaskellWidget(..),
-- ** Interactive use functions -- ** Interactive use functions
printDisplay, printDisplay,
-- * Constructors for displays -- * Constructors for displays
plain, html, png, jpg, svg, latex, javascript, many, plain,
html,
-- ** Image and data encoding functions png,
Width, Height, Base64(..), jpg,
encode64, base64, svg,
latex,
-- ** Utilities javascript,
switchToTmpDir, many,
-- * Internal only use -- ** Image and data encoding functions
displayFromChan, Width,
serializeDisplay, Height,
Widget(..), Base64(..),
) where encode64,
base64,
import ClassyPrelude
import Data.Serialize as Serialize -- ** Utilities
import Data.ByteString hiding (map, pack) switchToTmpDir,
import Data.String.Utils (rstrip)
-- * Internal only use
displayFromChan,
serializeDisplay,
Widget(..),
) where
import ClassyPrelude
import Data.Serialize as Serialize
import Data.ByteString hiding (map, pack)
import Data.String.Utils (rstrip)
import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Char8 as Char import qualified Data.ByteString.Char8 as Char
import Data.Aeson (Value) import Data.Aeson (Value)
import System.Directory(getTemporaryDirectory, setCurrentDirectory) import System.Directory (getTemporaryDirectory, setCurrentDirectory)
import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TChan
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import IHaskell.Types import IHaskell.Types
type Base64 = Text type Base64 = Text
...@@ -61,8 +71,7 @@ type Base64 = Text ...@@ -61,8 +71,7 @@ type Base64 = Text
-- > IO [Display] -- > IO [Display]
-- > IO (IO Display) -- > IO (IO Display)
-- --
-- be run the IO and get rendered (if the frontend allows it) in the pretty -- be run the IO and get rendered (if the frontend allows it) in the pretty form.
-- form.
instance IHaskellDisplay a => IHaskellDisplay (IO a) where instance IHaskellDisplay a => IHaskellDisplay (IO a) where
display = (display =<<) display = (display =<<)
...@@ -101,15 +110,15 @@ latex = DisplayData MimeLatex . pack ...@@ -101,15 +110,15 @@ latex = DisplayData MimeLatex . pack
javascript :: String -> DisplayData javascript :: String -> DisplayData
javascript = DisplayData MimeJavascript . pack javascript = DisplayData MimeJavascript . pack
-- | Generate a PNG display of the given width and height. Data must be -- | Generate a PNG display of the given width and height. Data must be provided in a Base64 encoded
-- provided in a Base64 encoded manner, suitable for embedding into HTML. -- manner, suitable for embedding into HTML. The @base64@ function may be used to encode data into
-- The @base64@ function may be used to encode data into this format. -- this format.
png :: Width -> Height -> Base64 -> DisplayData png :: Width -> Height -> Base64 -> DisplayData
png width height = DisplayData (MimePng width height) png width height = DisplayData (MimePng width height)
-- | Generate a JPG display of the given width and height. Data must be -- | Generate a JPG display of the given width and height. Data must be provided in a Base64 encoded
-- provided in a Base64 encoded manner, suitable for embedding into HTML. -- manner, suitable for embedding into HTML. The @base64@ function may be used to encode data into
-- The @base64@ function may be used to encode data into this format. -- this format.
jpg :: Width -> Height -> Base64 -> DisplayData jpg :: Width -> Height -> Base64 -> DisplayData
jpg width height = DisplayData (MimeJpg width height) jpg width height = DisplayData (MimeJpg width height)
...@@ -121,42 +130,37 @@ encode64 str = base64 $ Char.pack str ...@@ -121,42 +130,37 @@ encode64 str = base64 $ Char.pack str
base64 :: ByteString -> Base64 base64 :: ByteString -> Base64
base64 = decodeUtf8 . Base64.encode base64 = decodeUtf8 . Base64.encode
-- | For internal use within IHaskell. -- | For internal use within IHaskell. Serialize displays to a ByteString.
-- Serialize displays to a ByteString.
serializeDisplay :: Display -> ByteString serializeDisplay :: Display -> ByteString
serializeDisplay = Serialize.encode serializeDisplay = Serialize.encode
-- | Items written to this chan will be included in the output sent -- | Items written to this chan will be included in the output sent to the frontend (ultimately the
-- to the frontend (ultimately the browser), the next time IHaskell -- browser), the next time IHaskell has an item to display.
-- has an item to display.
{-# NOINLINE displayChan #-} {-# NOINLINE displayChan #-}
displayChan :: TChan Display displayChan :: TChan Display
displayChan = unsafePerformIO newTChanIO displayChan = unsafePerformIO newTChanIO
-- | Take everything that was put into the 'displayChan' at that point -- | Take everything that was put into the 'displayChan' at that point out, and make a 'Display' out
-- out, and make a 'Display' out of it. -- of it.
displayFromChan :: IO (Maybe Display) displayFromChan :: IO (Maybe Display)
displayFromChan = displayFromChan =
Just . many <$> unfoldM (atomically $ tryReadTChan displayChan) Just . many <$> unfoldM (atomically $ tryReadTChan displayChan)
-- | This is unfoldM from monad-loops. It repeatedly runs an IO action -- | This is unfoldM from monad-loops. It repeatedly runs an IO action until it return Nothing, and
-- until it return Nothing, and puts all the Justs in a list. -- puts all the Justs in a list. If you find yourself using more functionality from monad-loops,
-- If you find yourself using more functionality from monad-loops, just add -- just add the package dependency instead of copying more code from it.
-- the package dependency instead of copying more code from it.
unfoldM :: IO (Maybe a) -> IO [a] unfoldM :: IO (Maybe a) -> IO [a]
unfoldM f = maybe (return []) (\r -> (r:) <$> unfoldM f) =<< f unfoldM f = maybe (return []) (\r -> (r :) <$> unfoldM f) =<< f
-- | Write to the display channel. The contents will be displayed in the -- | Write to the display channel. The contents will be displayed in the notebook once the current
-- notebook once the current execution call ends. -- execution call ends.
printDisplay :: IHaskellDisplay a => a -> IO () printDisplay :: IHaskellDisplay a => a -> IO ()
printDisplay disp = display disp >>= atomically . writeTChan displayChan printDisplay disp = display disp >>= atomically . writeTChan displayChan
-- | Convenience function for client libraries. Switch to a temporary -- | Convenience function for client libraries. Switch to a temporary directory so that any files we
-- directory so that any files we create aren't visible. On Unix, this is -- create aren't visible. On Unix, this is usually /tmp.
-- usually /tmp.
switchToTmpDir = void (try switchDir :: IO (Either SomeException ())) switchToTmpDir = void (try switchDir :: IO (Either SomeException ()))
where where
switchDir = switchDir =
getTemporaryDirectory >>= getTemporaryDirectory >>=
setCurrentDirectory setCurrentDirectory
{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-} {-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts #-} {-# LANGUAGE TypeFamilies, FlexibleContexts #-}
{- | {- |
Description: Generates tab completion options. Description: Generates tab completion options.
...@@ -12,64 +13,66 @@ This has a limited amount of context sensitivity. It distinguishes between four ...@@ -12,64 +13,66 @@ This has a limited amount of context sensitivity. It distinguishes between four
-} -}
module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where
import ClassyPrelude hiding (init, last, head, liftIO) import ClassyPrelude hiding (init, last, head, liftIO)
--import Prelude
import Control.Applicative ((<$>))
import Control.Applicative ((<$>)) import Data.ByteString.UTF8 hiding (drop, take, lines, length)
import Data.ByteString.UTF8 hiding (drop, take, lines, length) import Data.Char
import Data.Char import Data.List (nub, init, last, head, elemIndex)
import Data.List (nub, init, last, head, elemIndex) import Data.List.Split
import Data.List.Split import Data.List.Split.Internals
import Data.List.Split.Internals import Data.Maybe (fromJust)
import Data.Maybe (fromJust) import Data.String.Utils (strip, startswith, endswith, replace)
import Data.String.Utils (strip, startswith, endswith, replace)
import qualified Data.String.Utils as StringUtils import qualified Data.String.Utils as StringUtils
import System.Environment (getEnv) import System.Environment (getEnv)
import GHC hiding (Qualified) import GHC hiding (Qualified)
#if MIN_VERSION_ghc(7,10,0) #if MIN_VERSION_ghc(7,10,0)
import GHC.PackageDb (ExposedModule(exposedName)) import GHC.PackageDb (ExposedModule(exposedName))
#endif #endif
import DynFlags import DynFlags
import GhcMonad import GhcMonad
import PackageConfig import PackageConfig
import Outputable (showPpr) import Outputable (showPpr)
import System.Directory import System.Directory
import System.FilePath import System.FilePath
import MonadUtils (MonadIO) import MonadUtils (MonadIO)
import System.Console.Haskeline.Completion import System.Console.Haskeline.Completion
import IHaskell.Types import IHaskell.Types
import IHaskell.Eval.Evaluate (Interpreter) import IHaskell.Eval.Evaluate (Interpreter)
import IHaskell.Eval.ParseShell (parseShell) import IHaskell.Eval.ParseShell (parseShell)
data CompletionType = Empty
data CompletionType | Identifier String
= Empty | DynFlag String
| Identifier String | Qualified String String
| DynFlag String | ModuleName String String
| Qualified String String | HsFilePath String String
| ModuleName String String | FilePath String String
| HsFilePath String String | KernelOption String
| FilePath String String | Extension String
| KernelOption String deriving (Show, Eq)
| Extension String #if MIN_VERSION_ghc(7,10,0)
deriving (Show, Eq) extName (FlagSpec { flagSpecName = name }) = name
#else
extName (name, _, _) = name
exposedName = id
#endif
complete :: String -> Int -> Interpreter (String, [String]) complete :: String -> Int -> Interpreter (String, [String])
complete code posOffset = do complete code posOffset = do
-- Get the line of code which is being completed and offset within that line -- Get the line of code which is being completed and offset within that line
let findLine offset (first:rest) = let findLine offset (first:rest) =
if offset <= length first if offset <= length first
then (offset, first) then (offset, first)
else findLine (offset - length first - 1) rest else findLine (offset - length first - 1) rest
findLine _ [] = error $ "Could not find line: " ++ show (map length $ lines code, posOffset) findLine _ [] = error $ "Could not find line: " ++ show (map length $ lines code, posOffset)
(pos, line) = findLine posOffset (lines code) (pos, line) = findLine posOffset (lines code)
flags <- getSessionDynFlags flags <- getSessionDynFlags
rdrNames <- map (showPpr flags) <$> getRdrNamesInScope rdrNames <- map (showPpr flags) <$> getRdrNamesInScope
...@@ -78,10 +81,6 @@ complete code posOffset = do ...@@ -78,10 +81,6 @@ complete code posOffset = do
unqualNames = nub $ filter (not . isQualified) rdrNames unqualNames = nub $ filter (not . isQualified) rdrNames
qualNames = nub $ scopeNames ++ filter isQualified rdrNames qualNames = nub $ scopeNames ++ filter isQualified rdrNames
#if !MIN_VERSION_ghc(7,10,0)
let exposedName = id
#endif
let Just db = pkgDatabase flags let Just db = pkgDatabase flags
getNames = map (moduleNameString . exposedName) . exposedModules getNames = map (moduleNameString . exposedName) . exposedModules
moduleNames = nub $ concatMap getNames db moduleNames = nub $ concatMap getNames db
...@@ -89,69 +88,63 @@ complete code posOffset = do ...@@ -89,69 +88,63 @@ complete code posOffset = do
let target = completionTarget line pos let target = completionTarget line pos
completion = completionType line pos target completion = completionType line pos target
let matchedText = case completion of let matchedText =
HsFilePath _ match -> match
FilePath _ match -> match
otherwise -> intercalate "." target
#if MIN_VERSION_ghc(7,10,0)
let extName (FlagSpec {flagSpecName=name}) = name
#else
let extName (name, _, _) = name
#endif
options <-
case completion of case completion of
Empty -> return [] HsFilePath _ match -> match
FilePath _ match -> match
otherwise -> intercalate "." target
options <- case completion of
Empty -> return []
Identifier candidate -> Identifier candidate ->
return $ filter (candidate `isPrefixOf`) unqualNames return $ filter (candidate `isPrefixOf`) unqualNames
Qualified moduleName candidate -> do Qualified moduleName candidate -> do
trueName <- getTrueModuleName moduleName trueName <- getTrueModuleName moduleName
let prefix = intercalate "." [trueName, candidate] let prefix = intercalate "." [trueName, candidate]
completions = filter (prefix `isPrefixOf`) qualNames completions = filter (prefix `isPrefixOf`) qualNames
falsifyName = replace trueName moduleName falsifyName = replace trueName moduleName
return $ map falsifyName completions return $ map falsifyName completions
ModuleName previous candidate -> do ModuleName previous candidate -> do
let prefix = if null previous let prefix = if null previous
then candidate then candidate
else intercalate "." [previous, candidate] else intercalate "." [previous, candidate]
return $ filter (prefix `isPrefixOf`) moduleNames return $ filter (prefix `isPrefixOf`) moduleNames
DynFlag ext -> do DynFlag ext -> do
-- Possibly leave out the fLangFlags? The -- Possibly leave out the fLangFlags? The -XUndecidableInstances vs. obsolete
-- -XUndecidableInstances vs. obsolete -- -fallow-undecidable-instances.
-- -fallow-undecidable-instances. let kernelOptNames = concatMap getSetName kernelOpts
let kernelOptNames = concatMap getSetName kernelOpts otherNames = ["-package", "-Wall", "-w"]
otherNames = ["-package","-Wall","-w"]
fNames = map extName fFlags ++ fNames = map extName fFlags ++
map extName fWarningFlags ++ map extName fWarningFlags ++
map extName fLangFlags map extName fLangFlags
fNoNames = map ("no"++) fNames fNoNames = map ("no" ++) fNames
fAllNames = map ("-f"++) (fNames ++ fNoNames) fAllNames = map ("-f" ++) (fNames ++ fNoNames)
xNames = map extName xFlags xNames = map extName xFlags
xNoNames = map ("No" ++) xNames xNoNames = map ("No" ++) xNames
xAllNames = map ("-X"++) (xNames ++ xNoNames) xAllNames = map ("-X" ++) (xNames ++ xNoNames)
allNames = xAllNames ++ otherNames ++ fAllNames allNames = xAllNames ++ otherNames ++ fAllNames
return $ filter (ext `isPrefixOf`) allNames return $ filter (ext `isPrefixOf`) allNames
Extension ext -> do Extension ext -> do
let xNames = map extName xFlags let xNames = map extName xFlags
xNoNames = map ("No" ++) xNames xNoNames = map ("No" ++) xNames
return $ filter (ext `isPrefixOf`) $ xNames ++ xNoNames return $ filter (ext `isPrefixOf`) $ xNames ++ xNoNames
HsFilePath lineUpToCursor match -> completePathWithExtensions [".hs", ".lhs"] lineUpToCursor HsFilePath lineUpToCursor match -> completePathWithExtensions [".hs", ".lhs"]
lineUpToCursor
FilePath lineUpToCursor match -> completePath lineUpToCursor FilePath lineUpToCursor match -> completePath lineUpToCursor
KernelOption str -> return $ KernelOption str -> return $
filter (str `isPrefixOf`) (concatMap getOptionName kernelOpts) filter (str `isPrefixOf`) (concatMap getOptionName kernelOpts)
return (matchedText, options) return (matchedText, options)
...@@ -164,116 +157,118 @@ getTrueModuleName name = do ...@@ -164,116 +157,118 @@ getTrueModuleName name = do
-- Get all imports that we use. -- Get all imports that we use.
imports <- ClassyPrelude.catMaybes <$> map onlyImportDecl <$> getContext imports <- ClassyPrelude.catMaybes <$> map onlyImportDecl <$> getContext
-- Find the ones that have a qualified name attached. -- Find the ones that have a qualified name attached. If this name isn't one of them, it already is
-- If this name isn't one of them, it already is the true name. -- the true name.
flags <- getSessionDynFlags flags <- getSessionDynFlags
let qualifiedImports = filter (isJust . ideclAs) imports let qualifiedImports = filter (isJust . ideclAs) imports
hasName imp = name == (showPpr flags . fromJust . ideclAs) imp hasName imp = name == (showPpr flags . fromJust . ideclAs) imp
case find hasName qualifiedImports of case find hasName qualifiedImports of
Nothing -> return name Nothing -> return name
Just trueImp -> return $ showPpr flags $ unLoc $ ideclName trueImp Just trueImp -> return $ showPpr flags $ unLoc $ ideclName trueImp
-- | Get which type of completion this is from the surrounding context. -- | Get which type of completion this is from the surrounding context.
completionType :: String -- ^ The line on which the completion is being done. completionType :: String -- ^ The line on which the completion is being done.
-> Int -- ^ Location of the cursor in the line. -> Int -- ^ Location of the cursor in the line.
-> [String] -- ^ The identifier being completed (pieces separated by dots). -> [String] -- ^ The identifier being completed (pieces separated by dots).
-> CompletionType -> CompletionType
completionType line loc target completionType line loc target
-- File and directory completions are special -- File and directory completions are special
| startswith ":!" stripped | startswith ":!" stripped =
= fileComplete FilePath fileComplete FilePath
| startswith ":l" stripped | startswith ":l" stripped =
= fileComplete HsFilePath fileComplete HsFilePath
-- Complete :set, :opt, and :ext -- Complete :set, :opt, and :ext
| startswith ":s" stripped | startswith ":s" stripped =
= DynFlag candidate DynFlag candidate
| startswith ":o" stripped | startswith ":o" stripped =
= KernelOption candidate KernelOption candidate
| startswith ":e" stripped | startswith ":e" stripped =
= Extension candidate Extension candidate
-- Use target for other completions. -- Use target for other completions. If it's empty, no completion.
-- If it's empty, no completion. | null target =
| null target Empty
= Empty
-- When in a string, complete filenames. -- When in a string, complete filenames.
| cursorInString line loc | cursorInString line loc =
= FilePath (getStringTarget lineUpToCursor) (getStringTarget lineUpToCursor) FilePath (getStringTarget lineUpToCursor) (getStringTarget lineUpToCursor)
-- Complete module names in imports and elsewhere. -- Complete module names in imports and elsewhere.
| startswith "import" stripped && isModName | startswith "import" stripped && isModName =
= ModuleName dotted candidate ModuleName dotted candidate
| isModName && (not . null . init) target | isModName && (not . null . init) target =
= Qualified dotted candidate Qualified dotted candidate
-- Default to completing identifiers. -- Default to completing identifiers.
| otherwise | otherwise =
= Identifier candidate Identifier candidate
where stripped = strip line where
dotted = dots target stripped = strip line
candidate | null target = "" dotted = dots target
| otherwise = last target candidate
dots = intercalate "." . init | null target = ""
isModName = all isCapitalized (init target) | otherwise = last target
dots = intercalate "." . init
isCapitalized [] = False isModName = all isCapitalized (init target)
isCapitalized (x:_) = isUpper x
isCapitalized [] = False
lineUpToCursor = take loc line isCapitalized (x:_) = isUpper x
fileComplete filePath = case parseShell lineUpToCursor of
Right xs -> filePath lineUpToCursor $ lineUpToCursor = take loc line
if endswith (last xs) lineUpToCursor fileComplete filePath =
then last xs case parseShell lineUpToCursor of
else [] Right xs -> filePath lineUpToCursor $
Left _ -> Empty if endswith (last xs) lineUpToCursor
then last xs
cursorInString str loc = nquotes (take loc str) `mod` 2 /= 0 else []
Left _ -> Empty
nquotes ('\\':'"':xs) = nquotes xs
nquotes ('"':xs) = 1 + nquotes xs cursorInString str loc = nquotes (take loc str) `mod` 2 /= 0
nquotes (_:xs) = nquotes xs
nquotes [] = 0 nquotes ('\\':'"':xs) = nquotes xs
nquotes ('"':xs) = 1 + nquotes xs
-- Get the bit of a string that might be a filename completion. nquotes (_:xs) = nquotes xs
-- Logic is a bit convoluted, but basically go backwards from the nquotes [] = 0
-- end, stopping at any quote or space, unless they are escaped.
getStringTarget :: String -> String -- Get the bit of a string that might be a filename completion. Logic is a bit convoluted, but
getStringTarget = go "" . reverse -- basically go backwards from the end, stopping at any quote or space, unless they are escaped.
where getStringTarget :: String -> String
go acc rest = case rest of getStringTarget = go "" . reverse
'"':'\\':rem -> go ('"':acc) rem where
'"':rem -> acc go acc rest =
' ':'\\':rem -> go (' ':acc) rem case rest of
' ':rem -> acc '"':'\\':rem -> go ('"' : acc) rem
x:rem -> go (x:acc) rem '"':rem -> acc
[] -> acc ' ':'\\':rem -> go (' ' : acc) rem
' ':rem -> acc
x:rem -> go (x : acc) rem
[] -> acc
-- | Get the word under a given cursor location. -- | Get the word under a given cursor location.
completionTarget :: String -> Int -> [String] completionTarget :: String -> Int -> [String]
completionTarget code cursor = expandCompletionPiece pieceToComplete completionTarget code cursor = expandCompletionPiece pieceToComplete
where where
pieceToComplete = map fst <$> find (elem cursor . map snd) pieces pieceToComplete = map fst <$> find (elem cursor . map snd) pieces
pieces = splitAlongCursor $ split splitter $ zip code [1 .. ] pieces = splitAlongCursor $ split splitter $ zip code [1 ..]
splitter = defaultSplitter { splitter = defaultSplitter
-- Split using only the characters, which are the first elements of {
-- the (char, index) tuple -- Split using only the characters, which are the first elements of the (char, index) tuple
delimiter = Delimiter [uncurry isDelim], delimiter = Delimiter [uncurry isDelim]
-- Condense multiple delimiters into one and then drop them. -- Condense multiple delimiters into one and then drop them.
condensePolicy = Condense, , condensePolicy = Condense
delimPolicy = Drop , delimPolicy = Drop
} }
isDelim :: Char -> Int -> Bool isDelim :: Char -> Int -> Bool
isDelim char idx = char `elem` neverIdent || isSymbol char isDelim char idx = char `elem` neverIdent || isSymbol char
splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]] splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]]
splitAlongCursor [] = [] splitAlongCursor [] = []
splitAlongCursor (x:xs) = splitAlongCursor (x:xs) =
case elemIndex cursor $ map snd x of case elemIndex cursor $ map snd x of
Nothing -> x:splitAlongCursor xs Nothing -> x : splitAlongCursor xs
Just idx -> take (idx + 1) x:drop (idx + 1) x:splitAlongCursor xs Just idx -> take (idx + 1) x : drop (idx + 1) x : splitAlongCursor xs
-- These are never part of an identifier. -- These are never part of an identifier.
neverIdent :: String neverIdent :: String
...@@ -284,10 +279,11 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete ...@@ -284,10 +279,11 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete
getHome :: IO String getHome :: IO String
getHome = do getHome = do
homeEither <- try $ getEnv "HOME" :: IO (Either SomeException String) homeEither <- try $ getEnv "HOME" :: IO (Either SomeException String)
return $ case homeEither of return $
Left _ -> "~" case homeEither of
Right home -> home Left _ -> "~"
Right home -> home
dirExpand :: String -> IO String dirExpand :: String -> IO String
dirExpand str = do dirExpand str = do
...@@ -301,7 +297,8 @@ unDirExpand str = do ...@@ -301,7 +297,8 @@ unDirExpand str = do
completePath :: String -> Interpreter [String] completePath :: String -> Interpreter [String]
completePath line = completePathFilter acceptAll acceptAll line "" completePath line = completePathFilter acceptAll acceptAll line ""
where acceptAll = const True where
acceptAll = const True
completePathWithExtensions :: [String] -> String -> Interpreter [String] completePathWithExtensions :: [String] -> String -> Interpreter [String]
completePathWithExtensions extensions line = completePathWithExtensions extensions line =
...@@ -309,7 +306,8 @@ completePathWithExtensions extensions line = ...@@ -309,7 +306,8 @@ completePathWithExtensions extensions line =
where where
acceptAll = const True acceptAll = const True
extensionIsOneOf exts str = any correctEnding exts extensionIsOneOf exts str = any correctEnding exts
where correctEnding ext = endswith ext str where
correctEnding ext = endswith ext str
completePathFilter :: (String -> Bool) -- ^ File filter: test whether to include this file. completePathFilter :: (String -> Bool) -- ^ File filter: test whether to include this file.
-> (String -> Bool) -- ^ Directory filter: test whether to include this directory. -> (String -> Bool) -- ^ Directory filter: test whether to include this directory.
...@@ -321,21 +319,19 @@ completePathFilter includeFile includeDirectory left right = liftIO $ do ...@@ -321,21 +319,19 @@ completePathFilter includeFile includeDirectory left right = liftIO $ do
expanded <- dirExpand left expanded <- dirExpand left
completions <- map replacement <$> snd <$> completeFilename (reverse expanded, right) completions <- map replacement <$> snd <$> completeFilename (reverse expanded, right)
-- Split up into files and directories. -- Split up into files and directories. Filter out ones we don't want.
-- Filter out ones we don't want.
areDirs <- mapM doesDirectoryExist completions areDirs <- mapM doesDirectoryExist completions
let dirs = filter includeDirectory $ map fst $ filter snd $ zip completions areDirs let dirs = filter includeDirectory $ map fst $ filter snd $ zip completions areDirs
files = filter includeFile $ map fst $ filter (not . snd) $ zip completions areDirs files = filter includeFile $ map fst $ filter (not . snd) $ zip completions areDirs
-- Return directories before files. However, stick everything that starts -- Return directories before files. However, stick everything that starts with a dot after
-- with a dot after everything else. If we wanted to keep original -- everything else. If we wanted to keep original order, we could instead use
-- order, we could instead use
-- filter (`elem` (dirs ++ files)) completions -- filter (`elem` (dirs ++ files)) completions
suggestions <- mapM unDirExpand $ dirs ++ files suggestions <- mapM unDirExpand $ dirs ++ files
let isHidden str = startswith "." . last . StringUtils.split "/" $ let isHidden str = startswith "." . last . StringUtils.split "/" $
if endswith "/" str if endswith "/" str
then init str then init str
else str else str
visible = filter (not . isHidden) suggestions visible = filter (not . isHidden) suggestions
hidden = filter isHidden suggestions hidden = filter isHidden suggestions
return $ visible ++ hidden return $ visible ++ hidden
...@@ -6,87 +6,101 @@ ...@@ -6,87 +6,101 @@
This module exports all functions used for evaluation of IHaskell input. This module exports all functions used for evaluation of IHaskell input.
-} -}
module IHaskell.Eval.Evaluate ( module IHaskell.Eval.Evaluate (
interpret, evaluate, Interpreter, liftIO, typeCleaner, globalImports interpret,
) where evaluate,
Interpreter,
import ClassyPrelude hiding (init, last, liftIO, head, hGetContents, tail, try) liftIO,
import Control.Concurrent (forkIO, threadDelay) typeCleaner,
import Prelude (putChar, head, tail, last, init, (!!)) globalImports,
import Data.List.Utils ) where
import Data.List (findIndex, and, foldl1)
import Data.String.Utils import ClassyPrelude hiding (init, last, liftIO, head, hGetContents, tail, try)
import Text.Printf import Control.Concurrent (forkIO, threadDelay)
import Data.Char as Char import Prelude (putChar, head, tail, last, init, (!!))
import Data.Dynamic import Data.List.Utils
import Data.Typeable import Data.List (findIndex, and, foldl1)
import Data.String.Utils
import Text.Printf
import Data.Char as Char
import Data.Dynamic
import Data.Typeable
import qualified Data.Serialize as Serialize import qualified Data.Serialize as Serialize
import System.Directory import System.Directory
import Filesystem.Path.CurrentOS (encodeString) import Filesystem.Path.CurrentOS (encodeString)
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import System.Posix.IO (createPipe) import System.Posix.IO (createPipe)
#endif #endif
import System.Posix.IO (fdToHandle) import System.Posix.IO (fdToHandle)
import System.IO (hGetChar, hFlush) import System.IO (hGetChar, hFlush)
import System.Random (getStdGen, randomRs) import System.Random (getStdGen, randomRs)
import Unsafe.Coerce import Unsafe.Coerce
import Control.Monad (guard) import Control.Monad (guard)
import System.Process import System.Process
import System.Exit import System.Exit
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import qualified Control.Monad.IO.Class as MonadIO (MonadIO, liftIO) import qualified Control.Monad.IO.Class as MonadIO (MonadIO, liftIO)
import qualified MonadUtils (MonadIO, liftIO) import qualified MonadUtils (MonadIO, liftIO)
import System.Environment (getEnv) import System.Environment (getEnv)
import qualified Data.Map as Map import qualified Data.Map as Map
import NameSet import NameSet
import Name import Name
import PprTyThing import PprTyThing
import InteractiveEval import InteractiveEval
import DynFlags import DynFlags
import Type import Type
import Exception (gtry) import Exception (gtry)
import HscTypes import HscTypes
import HscMain import HscMain
import qualified Linker import qualified Linker
import TcType import TcType
import Unify import Unify
import InstEnv import InstEnv
import GhcMonad (liftIO, withSession) import GhcMonad (liftIO, withSession)
import GHC hiding (Stmt, TypeSig) import GHC hiding (Stmt, TypeSig)
import Exception hiding (evaluate) import Exception hiding (evaluate)
import Outputable hiding ((<>)) import Outputable hiding ((<>))
import Packages import Packages
import Module hiding (Module) import Module hiding (Module)
import qualified Pretty import qualified Pretty
import FastString import FastString
import Bag import Bag
import ErrUtils (errMsgShortDoc, errMsgExtraInfo) import ErrUtils (errMsgShortDoc, errMsgExtraInfo)
import qualified System.IO.Strict as StrictIO import qualified System.IO.Strict as StrictIO
import IHaskell.Types import IHaskell.Types
import IHaskell.IPython import IHaskell.IPython
import IHaskell.Eval.Parser import IHaskell.Eval.Parser
import IHaskell.Eval.Lint import IHaskell.Eval.Lint
import IHaskell.Display import IHaskell.Display
import qualified IHaskell.Eval.Hoogle as Hoogle import qualified IHaskell.Eval.Hoogle as Hoogle
import IHaskell.Eval.Util import IHaskell.Eval.Util
import IHaskell.BrokenPackages import IHaskell.BrokenPackages
import qualified IHaskell.IPython.Message.UUID as UUID import qualified IHaskell.IPython.Message.UUID as UUID
import Paths_ihaskell (version) import Paths_ihaskell (version)
import Data.Version (versionBranch) import Data.Version (versionBranch)
data ErrorOccurred = Success | Failure deriving (Show, Eq) data ErrorOccurred = Success
| Failure
deriving (Show, Eq)
-- | Set GHC's verbosity for debugging -- | Set GHC's verbosity for debugging
ghcVerbosity :: Maybe Int ghcVerbosity :: Maybe Int
ghcVerbosity = Nothing -- Just 5 ghcVerbosity = Nothing -- Just 5
ignoreTypePrefixes :: [String] ignoreTypePrefixes :: [String]
ignoreTypePrefixes = ["GHC.Types", "GHC.Base", "GHC.Show", "System.IO", ignoreTypePrefixes = [ "GHC.Types"
"GHC.Float", ":Interactive", "GHC.Num", "GHC.IO", , "GHC.Base"
"GHC.Integer.Type"] , "GHC.Show"
, "System.IO"
, "GHC.Float"
, ":Interactive"
, "GHC.Num"
, "GHC.IO"
, "GHC.Integer.Type"
]
typeCleaner :: String -> String typeCleaner :: String -> String
typeCleaner = useStringType . foldl' (.) id (map (`replace` "") fullPrefixes) typeCleaner = useStringType . foldl' (.) id (map (`replace` "") fullPrefixes)
...@@ -98,14 +112,12 @@ write :: GhcMonad m => KernelState -> String -> m () ...@@ -98,14 +112,12 @@ write :: GhcMonad m => KernelState -> String -> m ()
write state x = when (kernelDebug state) $ liftIO $ hPutStrLn stderr $ "DEBUG: " ++ x write state x = when (kernelDebug state) $ liftIO $ hPutStrLn stderr $ "DEBUG: " ++ x
type Interpreter = Ghc type Interpreter = Ghc
#if MIN_VERSION_ghc(7, 8, 0) #if MIN_VERSION_ghc(7, 8, 0)
-- GHC 7.8 exports a MonadIO instance for Ghc -- GHC 7.8 exports a MonadIO instance for Ghc
#else #else
instance MonadIO.MonadIO Interpreter where instance MonadIO.MonadIO Interpreter where
liftIO = MonadUtils.liftIO liftIO = MonadUtils.liftIO
#endif #endif
globalImports :: [String] globalImports :: [String]
globalImports = globalImports =
[ "import IHaskell.Display()" [ "import IHaskell.Display()"
...@@ -118,23 +130,23 @@ globalImports = ...@@ -118,23 +130,23 @@ globalImports =
, "import qualified Language.Haskell.TH as IHaskellTH" , "import qualified Language.Haskell.TH as IHaskellTH"
] ]
-- | Run an interpreting action. This is effectively runGhc with -- | Run an interpreting action. This is effectively runGhc with initialization and importing. First
-- initialization and importing. First argument indicates whether `stdin` -- argument indicates whether `stdin` is handled specially, which cannot be done in a testing
-- is handled specially, which cannot be done in a testing environment. -- environment.
interpret :: String -> Bool -> Interpreter a -> IO a interpret :: String -> Bool -> Interpreter a -> IO a
interpret libdir allowedStdin action = runGhc (Just libdir) $ do interpret libdir allowedStdin action = runGhc (Just libdir) $ do
-- If we're in a sandbox, add the relevant package database -- If we're in a sandbox, add the relevant package database
sandboxPackages <- liftIO getSandboxPackageConf sandboxPackages <- liftIO getSandboxPackageConf
initGhci sandboxPackages initGhci sandboxPackages
case ghcVerbosity of case ghcVerbosity of
Just verb -> do dflags <- getSessionDynFlags Just verb -> do
void $ setSessionDynFlags $ dflags { verbosity = verb } dflags <- getSessionDynFlags
Nothing -> return () void $ setSessionDynFlags $ dflags { verbosity = verb }
Nothing -> return ()
initializeImports initializeImports
-- Close stdin so it can't be used. -- Close stdin so it can't be used. Otherwise it'll block the kernel forever.
-- Otherwise it'll block the kernel forever.
dir <- liftIO getIHaskellDir dir <- liftIO getIHaskellDir
let cmd = printf "IHaskell.IPython.Stdin.fixStdin \"%s\"" dir let cmd = printf "IHaskell.IPython.Stdin.fixStdin \"%s\"" dir
when allowedStdin $ void $ when allowedStdin $ void $
...@@ -144,50 +156,53 @@ interpret libdir allowedStdin action = runGhc (Just libdir) $ do ...@@ -144,50 +156,53 @@ interpret libdir allowedStdin action = runGhc (Just libdir) $ do
-- Run the rest of the interpreter -- Run the rest of the interpreter
action action
#if MIN_VERSION_ghc(7,10,0)
packageIdString' dflags = packageKeyPackageIdString dflags
#else
packageIdString' dflags = packageIdString
#endif
-- | Initialize our GHC session with imports and a value for 'it'. -- | Initialize our GHC session with imports and a value for 'it'.
initializeImports :: Interpreter () initializeImports :: Interpreter ()
initializeImports = do initializeImports = do
-- Load packages that start with ihaskell-*, aren't just IHaskell, -- Load packages that start with ihaskell-*, aren't just IHaskell, and depend directly on the right
-- and depend directly on the right version of the ihaskell library. -- version of the ihaskell library. Also verify that the packages we load are not broken.
-- Also verify that the packages we load are not broken.
dflags <- getSessionDynFlags dflags <- getSessionDynFlags
broken <- liftIO getBrokenPackages broken <- liftIO getBrokenPackages
displayPackages <- liftIO $ do displayPackages <- liftIO $ do
(dflags, _) <- initPackages dflags (dflags, _) <- initPackages dflags
let Just db = pkgDatabase dflags let Just db = pkgDatabase dflags
#if MIN_VERSION_ghc(7,10,0) packageNames = map (packageIdString' dflags . packageConfigId) db
packageIdString = packageKeyPackageIdString dflags
#endif initStr = "ihaskell-"
packageNames = map (packageIdString . packageConfigId) db
-- Name of the ihaskell package, e.g. "ihaskell-1.2.3.4"
initStr = "ihaskell-" iHaskellPkgName = initStr ++ intercalate "."
(map show (versionBranch version))
-- Name of the ihaskell package, e.g. "ihaskell-1.2.3.4"
iHaskellPkgName = initStr ++ intercalate "." (map show (versionBranch version)) dependsOnRight pkg = not $ null $ do
pkg <- db
dependsOnRight pkg = not $ null $ do depId <- depends pkg
pkg <- db dep <- filter ((== depId) . installedPackageId) db
depId <- depends pkg guard
dep <- filter ((== depId) . installedPackageId) db (iHaskellPkgName `isPrefixOf` packageIdString (packageConfigId dep))
guard (iHaskellPkgName `isPrefixOf` packageIdString (packageConfigId dep))
-- ideally the Paths_ihaskell module could provide a way to get the hash too
-- ideally the Paths_ihaskell module could provide a way to get the -- (ihaskell-0.2.0.5-f2bce922fa881611f72dfc4a854353b9), for now. Things will end badly if you also
-- hash too (ihaskell-0.2.0.5-f2bce922fa881611f72dfc4a854353b9), -- happen to have an ihaskell-0.2.0.5-ce34eadc18cf2b28c8d338d0f3755502 installed.
-- for now. Things will end badly if you also happen to have an iHaskellPkg =
-- ihaskell-0.2.0.5-ce34eadc18cf2b28c8d338d0f3755502 installed. case filter (== iHaskellPkgName) packageNames of
iHaskellPkg = case filter (== iHaskellPkgName) packageNames of [x] -> x
[x] -> x [] -> error
[] -> error ("cannot find required haskell library: " ++ iHaskellPkgName) ("cannot find required haskell library: " ++ iHaskellPkgName)
_ -> error ("multiple haskell packages " ++ iHaskellPkgName ++ " found") _ -> error
("multiple haskell packages " ++ iHaskellPkgName ++ " found")
displayPkgs = [ pkgName
| pkgName <- packageNames, displayPkgs = [pkgName | pkgName <- packageNames
Just (x:_) <- [stripPrefix initStr pkgName], , Just (x:_) <- [stripPrefix initStr pkgName]
pkgName `notElem` broken, , pkgName `notElem` broken
isAlpha x] , isAlpha x]
return displayPkgs return displayPkgs
-- Generate import statements all Display modules. -- Generate import statements all Display modules.
let capitalize :: String -> String let capitalize :: String -> String
...@@ -214,25 +229,28 @@ initializeImports = do ...@@ -214,25 +229,28 @@ initializeImports = do
-- | Give a value for the `it` variable. -- | Give a value for the `it` variable.
initializeItVariable :: Interpreter () initializeItVariable :: Interpreter ()
initializeItVariable = do initializeItVariable = do
-- This is required due to the way we handle `it` in the wrapper -- This is required due to the way we handle `it` in the wrapper statements - if it doesn't exist,
-- statements - if it doesn't exist, the first statement will fail. -- the first statement will fail.
void $ runStmt "let it = ()" RunToCompletion void $ runStmt "let it = ()" RunToCompletion
-- | Publisher for IHaskell outputs. The first argument indicates whether -- | Publisher for IHaskell outputs. The first argument indicates whether this output is final
-- this output is final (true) or intermediate (false). -- (true) or intermediate (false).
type Publisher = (EvaluationResult -> IO ()) type Publisher = (EvaluationResult -> IO ())
-- | Output of a command evaluation. -- | Output of a command evaluation.
data EvalOut = EvalOut { data EvalOut =
evalStatus :: ErrorOccurred, EvalOut
evalResult :: Display, { evalStatus :: ErrorOccurred
evalState :: KernelState, , evalResult :: Display
evalPager :: String, , evalState :: KernelState
evalComms :: [CommInfo] , evalPager :: String
} , evalComms :: [CommInfo]
}
cleanString :: String -> String cleanString :: String -> String
cleanString x = if allBrackets then clean else str cleanString x = if allBrackets
then clean
else str
where where
str = strip x str = strip x
l = lines str l = lines str
...@@ -242,7 +260,7 @@ cleanString x = if allBrackets then clean else str ...@@ -242,7 +260,7 @@ cleanString x = if allBrackets then clean else str
removeBracket ('>':xs) = xs removeBracket ('>':xs) = xs
removeBracket [] = [] removeBracket [] = []
-- should never happen: -- should never happen:
removeBracket other = error $ "Expected bracket as first char, but got string: " ++ other removeBracket other = error $ "Expected bracket as first char, but got string: " ++ other
-- | Evaluate some IPython input code. -- | Evaluate some IPython input code.
evaluate :: KernelState -- ^ The kernel state. evaluate :: KernelState -- ^ The kernel state.
...@@ -259,24 +277,23 @@ evaluate kernelState code output = do ...@@ -259,24 +277,23 @@ evaluate kernelState code output = do
errs = mapMaybe (justError . unloc) cmds errs = mapMaybe (justError . unloc) cmds
updated <- case errs of updated <- case errs of
-- Only run things if there are no parse errors. -- Only run things if there are no parse errors.
[] -> do [] -> do
when (getLintStatus kernelState /= LintOff) $ liftIO $ do when (getLintStatus kernelState /= LintOff) $ liftIO $ do
lintSuggestions <- lint cmds lintSuggestions <- lint cmds
unless (noResults lintSuggestions) $ unless (noResults lintSuggestions) $
output $ FinalResult lintSuggestions "" [] output $ FinalResult lintSuggestions "" []
runUntilFailure kernelState (map unloc cmds ++ [storeItCommand execCount]) runUntilFailure kernelState (map unloc cmds ++ [storeItCommand execCount])
-- Print all parse errors. -- Print all parse errors.
errs -> do errs -> do
forM_ errs $ \err -> do forM_ errs $ \err -> do
out <- evalCommand output err kernelState out <- evalCommand output err kernelState
liftIO $ output $ FinalResult (evalResult out) "" [] liftIO $ output $ FinalResult (evalResult out) "" []
return kernelState return kernelState
return updated { return updated { getExecutionCounter = execCount + 1 }
getExecutionCounter = execCount + 1
}
where where
noResults (Display res) = null res noResults (Display res) = null res
noResults (ManyDisplay res) = all noResults res noResults (ManyDisplay res) = all noResults res
...@@ -286,13 +303,12 @@ evaluate kernelState code output = do ...@@ -286,13 +303,12 @@ evaluate kernelState code output = do
runUntilFailure state (cmd:rest) = do runUntilFailure state (cmd:rest) = do
evalOut <- evalCommand output cmd state evalOut <- evalCommand output cmd state
-- Get displayed channel outputs. -- Get displayed channel outputs. Merge them with normal display outputs.
-- Merge them with normal display outputs.
dispsIO <- extractValue "IHaskell.Display.displayFromChan" dispsIO <- extractValue "IHaskell.Display.displayFromChan"
dispsMay <- liftIO dispsIO dispsMay <- liftIO dispsIO
let result = let result =
case dispsMay of case dispsMay of
Nothing -> evalResult evalOut Nothing -> evalResult evalOut
Just disps -> evalResult evalOut <> disps Just disps -> evalResult evalOut <> disps
helpStr = evalPager evalOut helpStr = evalPager evalOut
...@@ -314,7 +330,7 @@ evaluate kernelState code output = do ...@@ -314,7 +330,7 @@ evaluate kernelState code output = do
extractValue expr = do extractValue expr = do
compiled <- dynCompileExpr expr compiled <- dynCompileExpr expr
case fromDynamic compiled of case fromDynamic compiled of
Nothing -> error "Expecting value!" Nothing -> error "Expecting value!"
Just result -> return result Just result -> return result
safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut
...@@ -322,46 +338,49 @@ safely state = ghandle handler . ghandle sourceErrorHandler ...@@ -322,46 +338,49 @@ safely state = ghandle handler . ghandle sourceErrorHandler
where where
handler :: SomeException -> Interpreter EvalOut handler :: SomeException -> Interpreter EvalOut
handler exception = handler exception =
return EvalOut { return
evalStatus = Failure, EvalOut
evalResult = displayError $ show exception, { evalStatus = Failure
evalState = state, , evalResult = displayError $ show exception
evalPager = "", , evalState = state
evalComms = [] , evalPager = ""
} , evalComms = []
}
sourceErrorHandler :: SourceError -> Interpreter EvalOut sourceErrorHandler :: SourceError -> Interpreter EvalOut
sourceErrorHandler srcerr = do sourceErrorHandler srcerr = do
let msgs = bagToList $ srcErrorMessages srcerr let msgs = bagToList $ srcErrorMessages srcerr
errStrs <- forM msgs $ \msg -> do errStrs <- forM msgs $ \msg -> do
shortStr <- doc $ errMsgShortDoc msg shortStr <- doc $ errMsgShortDoc msg
contextStr <- doc $ errMsgExtraInfo msg contextStr <- doc $ errMsgExtraInfo msg
return $ unlines [shortStr, contextStr] return $ unlines [shortStr, contextStr]
let fullErr = unlines errStrs let fullErr = unlines errStrs
return EvalOut { return
evalStatus = Failure, EvalOut
evalResult = displayError fullErr, { evalStatus = Failure
evalState = state, , evalResult = displayError fullErr
evalPager = "", , evalState = state
evalComms = [] , evalPager = ""
} , evalComms = []
}
wrapExecution :: KernelState wrapExecution :: KernelState
-> Interpreter Display -> Interpreter Display
-> Interpreter EvalOut -> Interpreter EvalOut
wrapExecution state exec = safely state $ exec >>= \res -> wrapExecution state exec = safely state $
return EvalOut { exec >>= \res ->
evalStatus = Success, return
evalResult = res, EvalOut
evalState = state, { evalStatus = Success
evalPager = "", , evalResult = res
evalComms = [] , evalState = state
} , evalPager = ""
, evalComms = []
-- | Return the display data for this command, as well as whether it }
-- resulted in an error.
-- | Return the display data for this command, as well as whether it resulted in an error.
evalCommand :: Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut evalCommand :: Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut
evalCommand _ (Import importStr) state = wrapExecution state $ do evalCommand _ (Import importStr) state = wrapExecution state $ do
write state $ "Import: " ++ importStr write state $ "Import: " ++ importStr
...@@ -369,9 +388,9 @@ evalCommand _ (Import importStr) state = wrapExecution state $ do ...@@ -369,9 +388,9 @@ evalCommand _ (Import importStr) state = wrapExecution state $ do
-- Warn about `it` variable. -- Warn about `it` variable.
return $ if "Test.Hspec" `isInfixOf` importStr return $ if "Test.Hspec" `isInfixOf` importStr
then displayError $ "Warning: Hspec is unusable in IHaskell until the resolution of GHC bug #8639." ++ then displayError $ "Warning: Hspec is unusable in IHaskell until the resolution of GHC bug #8639." ++
"\nThe variable `it` is shadowed and cannot be accessed, even in qualified form." "\nThe variable `it` is shadowed and cannot be accessed, even in qualified form."
else mempty else mempty
evalCommand _ (Module contents) state = wrapExecution state $ do evalCommand _ (Module contents) state = wrapExecution state $ do
write state $ "Module:\n" ++ contents write state $ "Module:\n" ++ contents
...@@ -393,21 +412,21 @@ evalCommand _ (Module contents) state = wrapExecution state $ do ...@@ -393,21 +412,21 @@ evalCommand _ (Module contents) state = wrapExecution state $ do
-- Remember which modules we've loaded before. -- Remember which modules we've loaded before.
importedModules <- getContext importedModules <- getContext
let -- Get the dot-delimited pieces of the module name. let
-- Get the dot-delimited pieces of the module name.
moduleNameOf :: InteractiveImport -> [String] moduleNameOf :: InteractiveImport -> [String]
moduleNameOf (IIDecl decl) = split "." . moduleNameString . unLoc . ideclName $ decl moduleNameOf (IIDecl decl) = split "." . moduleNameString . unLoc . ideclName $ decl
moduleNameOf (IIModule imp) = split "." . moduleNameString $ imp moduleNameOf (IIModule imp) = split "." . moduleNameString $ imp
-- Return whether this module prevents the loading of the one we're -- Return whether this module prevents the loading of the one we're trying to load. If a module B
-- trying to load. If a module B exist, we cannot load A.B. All -- exist, we cannot load A.B. All modules must have unique last names (where A.B has last name B).
-- modules must have unique last names (where A.B has last name B).
-- However, we *can* just reload a module. -- However, we *can* just reload a module.
preventsLoading mod = preventsLoading mod =
let pieces = moduleNameOf mod in let pieces = moduleNameOf mod
last namePieces == last pieces && namePieces /= pieces in last namePieces == last pieces && namePieces /= pieces
-- If we've loaded anything with the same last name, we can't use this. -- If we've loaded anything with the same last name, we can't use this. Otherwise, GHC tries to load
-- Otherwise, GHC tries to load the original *.hs fails and then fails. -- the original *.hs fails and then fails.
case find preventsLoading importedModules of case find preventsLoading importedModules of
-- If something prevents loading this module, return an error. -- If something prevents loading this module, return an error.
Just previous -> do Just previous -> do
...@@ -425,7 +444,8 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do ...@@ -425,7 +444,8 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do
-- Find which flags are IHaskell flags, and which are GHC flags -- Find which flags are IHaskell flags, and which are GHC flags
let flags = words flagsStr let flags = words flagsStr
-- Get the kernel state updater for any IHaskell flag; Nothing for things that aren't IHaskell flags. -- Get the kernel state updater for any IHaskell flag; Nothing for things that aren't IHaskell
-- flags.
ihaskellFlagUpdater :: String -> Maybe (KernelState -> KernelState) ihaskellFlagUpdater :: String -> Maybe (KernelState -> KernelState)
ihaskellFlagUpdater flag = getUpdateKernelState <$> find (elem flag . getSetName) kernelOpts ihaskellFlagUpdater flag = getUpdateKernelState <$> find (elem flag . getSetName) kernelOpts
...@@ -435,41 +455,47 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do ...@@ -435,41 +455,47 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do
write state $ "GHC Flags: " ++ unwords ghcFlags write state $ "GHC Flags: " ++ unwords ghcFlags
if null flags if null flags
then do then do
flags <- getSessionDynFlags flags <- getSessionDynFlags
return EvalOut { return
evalStatus = Success, EvalOut
evalResult = Display [plain $ showSDoc flags $ vcat [pprDynFlags False flags, pprLanguages False flags]], { evalStatus = Success
evalState = state, , evalResult = Display
evalPager = "", [ plain $ showSDoc flags $ vcat
evalComms = [] [ pprDynFlags False flags
} , pprLanguages False flags
else do ]
-- Apply all IHaskell flag updaters to the state to get the new state ]
let state' = (foldl' (.) id (map (fromJust . ihaskellFlagUpdater) ihaskellFlags)) state , evalState = state
errs <- setFlags ghcFlags , evalPager = ""
let display = case errs of , evalComms = []
[] -> mempty }
_ -> displayError $ intercalate "\n" errs else do
-- Apply all IHaskell flag updaters to the state to get the new state
-- For -XNoImplicitPrelude, remove the Prelude import. let state' = (foldl' (.) id (map (fromJust . ihaskellFlagUpdater) ihaskellFlags)) state
-- For -XImplicitPrelude, add it back in. errs <- setFlags ghcFlags
if "-XNoImplicitPrelude" `elem` flags let display =
then evalImport "import qualified Prelude as Prelude" case errs of
else [] -> mempty
when ("-XImplicitPrelude" `elem` flags) $ do _ -> displayError $ intercalate "\n" errs
importDecl <- parseImportDecl "import Prelude"
let implicitPrelude = importDecl { ideclImplicit = True } -- For -XNoImplicitPrelude, remove the Prelude import. For -XImplicitPrelude, add it back in.
imports <- getContext if "-XNoImplicitPrelude" `elem` flags
setContext $ IIDecl implicitPrelude : imports then evalImport "import qualified Prelude as Prelude"
else when ("-XImplicitPrelude" `elem` flags) $ do
return EvalOut { importDecl <- parseImportDecl "import Prelude"
evalStatus = Success, let implicitPrelude = importDecl { ideclImplicit = True }
evalResult = display, imports <- getContext
evalState = state', setContext $ IIDecl implicitPrelude : imports
evalPager = "",
evalComms = [] return
} EvalOut
{ evalStatus = Success
, evalResult = display
, evalState = state'
, evalPager = ""
, evalComms = []
}
evalCommand output (Directive SetExtension opts) state = do evalCommand output (Directive SetExtension opts) state = do
write state $ "Extension: " ++ opts write state $ "Extension: " ++ opts
...@@ -483,12 +509,11 @@ evalCommand output (Directive LoadModule mods) state = wrapExecution state $ do ...@@ -483,12 +509,11 @@ evalCommand output (Directive LoadModule mods) state = wrapExecution state $ do
case firstChar of case firstChar of
'+' -> (words remainder, False) '+' -> (words remainder, False)
'-' -> (words remainder, True) '-' -> (words remainder, True)
_ -> (words stripped, False) _ -> (words stripped, False)
forM_ modules $ \modl -> forM_ modules $ \modl -> if removeModule
if removeModule then removeImport modl
then removeImport modl else evalImport $ "import " ++ modl
else evalImport $ "import " ++ modl
return mempty return mempty
...@@ -496,25 +521,26 @@ evalCommand a (Directive SetOption opts) state = do ...@@ -496,25 +521,26 @@ evalCommand a (Directive SetOption opts) state = do
write state $ "Option: " ++ opts write state $ "Option: " ++ opts
let (existing, nonExisting) = partition optionExists $ words opts let (existing, nonExisting) = partition optionExists $ words opts
if not $ null nonExisting if not $ null nonExisting
then then let err = "No such options: " ++ intercalate ", " nonExisting
let err = "No such options: " ++ intercalate ", " nonExisting in in return
return EvalOut { EvalOut
evalStatus = Failure, { evalStatus = Failure
evalResult = displayError err, , evalResult = displayError err
evalState = state, , evalState = state
evalPager = "", , evalPager = ""
evalComms = [] , evalComms = []
} }
else else let options = mapMaybe findOption $ words opts
let options = mapMaybe findOption $ words opts updater = foldl' (.) id $ map getUpdateKernelState options
updater = foldl' (.) id $ map getUpdateKernelState options in in return
return EvalOut { EvalOut
evalStatus = Success, { evalStatus = Success
evalResult = mempty, , evalResult = mempty
evalState = updater state, , evalState = updater state
evalPager = "", , evalPager = ""
evalComms = [] , evalComms = []
} }
where where
optionExists = isJust . findOption optionExists = isJust . findOption
findOption opt = findOption opt =
...@@ -522,7 +548,7 @@ evalCommand a (Directive SetOption opts) state = do ...@@ -522,7 +548,7 @@ evalCommand a (Directive SetOption opts) state = do
evalCommand _ (Directive GetType expr) state = wrapExecution state $ do evalCommand _ (Directive GetType expr) state = wrapExecution state $ do
write state $ "Type: " ++ expr write state $ "Type: " ++ expr
formatType <$> ((expr ++ " :: ") ++ ) <$> getType expr formatType <$> ((expr ++ " :: ") ++) <$> getType expr
evalCommand _ (Directive GetKind expr) state = wrapExecution state $ do evalCommand _ (Directive GetKind expr) state = wrapExecution state $ do
write state $ "Kind: " ++ expr write state $ "Kind: " ++ expr
...@@ -535,8 +561,8 @@ evalCommand _ (Directive LoadFile name) state = wrapExecution state $ do ...@@ -535,8 +561,8 @@ evalCommand _ (Directive LoadFile name) state = wrapExecution state $ do
write state $ "Load: " ++ name write state $ "Load: " ++ name
let filename = if endswith ".hs" name let filename = if endswith ".hs" name
then name then name
else name ++ ".hs" else name ++ ".hs"
contents <- readFile $ fpFromString filename contents <- readFile $ fpFromString filename
modName <- intercalate "." <$> getModuleName contents modName <- intercalate "." <$> getModuleName contents
doLoadModule filename modName doLoadModule filename modName
...@@ -546,123 +572,130 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $ ...@@ -546,123 +572,130 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
"cd":dirs -> do "cd":dirs -> do
-- Get home so we can replace '~` with it. -- Get home so we can replace '~` with it.
homeEither <- liftIO (try $ getEnv "HOME" :: IO (Either SomeException String)) homeEither <- liftIO (try $ getEnv "HOME" :: IO (Either SomeException String))
let home = case homeEither of let home =
Left _ -> "~" case homeEither of
Right val -> val Left _ -> "~"
Right val -> val
let directory = replace "~" home $ unwords dirs let directory = replace "~" home $ unwords dirs
exists <- liftIO $ doesDirectoryExist directory exists <- liftIO $ doesDirectoryExist directory
if exists if exists
then do then do
-- Set the directory in IHaskell native code, for future shell -- Set the directory in IHaskell native code, for future shell commands. This doesn't set it for
-- commands. This doesn't set it for user code, though. -- user code, though.
liftIO $ setCurrentDirectory directory liftIO $ setCurrentDirectory directory
-- Set the directory for user code. -- Set the directory for user code.
let cmd = printf "IHaskellDirectory.setCurrentDirectory \"%s\"" $ let cmd = printf "IHaskellDirectory.setCurrentDirectory \"%s\"" $
replace " " "\\ " $ replace " " "\\ " $
replace "\"" "\\\"" directory replace "\"" "\\\"" directory
runStmt cmd RunToCompletion runStmt cmd RunToCompletion
return mempty return mempty
else else return $ displayError $ printf "No such directory: '%s'" directory
return $ displayError $ printf "No such directory: '%s'" directory
cmd -> liftIO $ do cmd -> liftIO $ do
#if MIN_VERSION_base(4,8,0) (pipe, handle) <- createPipe'
(pipe, handle) <- createPipe
#else
(readEnd, writeEnd) <- createPipe
handle <- fdToHandle writeEnd
pipe <- fdToHandle readEnd
#endif
let initProcSpec = shell $ unwords cmd let initProcSpec = shell $ unwords cmd
procSpec = initProcSpec { procSpec = initProcSpec
std_in = Inherit, { std_in = Inherit
std_out = UseHandle handle, , std_out = UseHandle handle
std_err = UseHandle handle , std_err = UseHandle handle
} }
(_, _, _, process) <- createProcess procSpec (_, _, _, process) <- createProcess procSpec
-- Accumulate output from the process. -- Accumulate output from the process.
outputAccum <- liftIO $ newMVar "" outputAccum <- liftIO $ newMVar ""
-- Start a loop to publish intermediate results. -- Start a loop to publish intermediate results.
let let
-- Compute how long to wait between reading pieces of the output. -- Compute how long to wait between reading pieces of the output. `threadDelay` takes an
-- `threadDelay` takes an argument of microseconds. -- argument of microseconds.
ms = 1000 ms = 1000
delay = 100 * ms delay = 100 * ms
-- Maximum size of the output (after which we truncate). -- Maximum size of the output (after which we truncate).
maxSize = 100 * 1000 maxSize = 100 * 1000
incSize = 200 incSize = 200
output str = publish $ IntermediateResult $ Display [plain str] output str = publish $ IntermediateResult $ Display [plain str]
loop = do loop = do
-- Wait and then check if the computation is done. -- Wait and then check if the computation is done.
threadDelay delay threadDelay delay
-- Read next chunk and append to accumulator. -- Read next chunk and append to accumulator.
nextChunk <- readChars pipe "\n" incSize nextChunk <- readChars pipe "\n" incSize
modifyMVar_ outputAccum (return . (++ nextChunk))
-- Check if we're done.
exitCode <- getProcessExitCode process
let computationDone = isJust exitCode
when computationDone $ do
nextChunk <- readChars pipe "" maxSize
modifyMVar_ outputAccum (return . (++ nextChunk)) modifyMVar_ outputAccum (return . (++ nextChunk))
if not computationDone -- Check if we're done.
then do exitCode <- getProcessExitCode process
-- Write to frontend and repeat. let computationDone = isJust exitCode
readMVar outputAccum >>= output
loop when computationDone $ do
else do nextChunk <- readChars pipe "" maxSize
out <- readMVar outputAccum modifyMVar_ outputAccum (return . (++ nextChunk))
case fromJust exitCode of
ExitSuccess -> return $ Display [plain out] if not computationDone
ExitFailure code -> do then do
let errMsg = "Process exited with error code " ++ show code -- Write to frontend and repeat.
htmlErr = printf "<span class='err-msg'>%s</span>" errMsg readMVar outputAccum >>= output
return $ Display [plain $ out ++ "\n" ++ errMsg, loop
html $ printf "<span class='mono'>%s</span>" out ++ htmlErr] else do
out <- readMVar outputAccum
case fromJust exitCode of
ExitSuccess -> return $ Display [plain out]
ExitFailure code -> do
let errMsg = "Process exited with error code " ++ show code
htmlErr = printf "<span class='err-msg'>%s</span>" errMsg
return $ Display
[ plain $ out ++ "\n" ++ errMsg
, html $ printf "<span class='mono'>%s</span>" out ++ htmlErr
]
loop loop
where
#if MIN_VERSION_base(4,8,0)
createPipe' = createPipe
#else
createPipe' = do
(readEnd, writeEnd) <- createPipe
handle <- fdToHandle writeEnd
pipe <- fdToHandle readEnd
return (pipe, handle)
#endif
-- This is taken largely from GHCi's info section in InteractiveUI. -- This is taken largely from GHCi's info section in InteractiveUI.
evalCommand _ (Directive GetHelp _) state = do evalCommand _ (Directive GetHelp _) state = do
write state "Help via :help or :?." write state "Help via :help or :?."
return EvalOut { return
evalStatus = Success, EvalOut
evalResult = Display [out], { evalStatus = Success
evalState = state, , evalResult = Display [out]
evalPager = "", , evalState = state
evalComms = [] , evalPager = ""
} , evalComms = []
where out = plain $ intercalate "\n" }
["The following commands are available:"
," :extension <Extension> - Enable a GHC extension." where
," :extension No<Extension> - Disable a GHC extension." out = plain $ intercalate "\n"
," :type <expression> - Print expression type." [ "The following commands are available:"
," :info <name> - Print all info for a name." , " :extension <Extension> - Enable a GHC extension."
," :hoogle <query> - Search for a query on Hoogle." , " :extension No<Extension> - Disable a GHC extension."
," :doc <ident> - Get documentation for an identifier via Hogole." , " :type <expression> - Print expression type."
," :set -XFlag -Wall - Set an option (like ghci)." , " :info <name> - Print all info for a name."
," :option <opt> - Set an option." , " :hoogle <query> - Search for a query on Hoogle."
," :option no-<opt> - Unset an option." , " :doc <ident> - Get documentation for an identifier via Hogole."
," :?, :help - Show this help text." , " :set -XFlag -Wall - Set an option (like ghci)."
,"" , " :option <opt> - Set an option."
,"Any prefix of the commands will also suffice, e.g. use :ty for :type." , " :option no-<opt> - Unset an option."
,"" , " :?, :help - Show this help text."
,"Options:" , ""
," lint – enable or disable linting." , "Any prefix of the commands will also suffice, e.g. use :ty for :type."
," svg – use svg output (cannot be resized)." , ""
," show-types – show types of all bound names" , "Options:"
," show-errors – display Show instance missing errors normally." , " lint – enable or disable linting."
," pager – use the pager to display results of :info, :doc, :hoogle, etc." , " 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. -- This is taken largely from GHCi's info section in InteractiveUI.
evalCommand _ (Directive GetInfo str) state = safely state $ do evalCommand _ (Directive GetInfo str) state = safely state $ do
...@@ -673,18 +706,21 @@ evalCommand _ (Directive GetInfo str) state = safely state $ do ...@@ -673,18 +706,21 @@ evalCommand _ (Directive GetInfo str) state = safely state $ do
-- TODO: Make pager work without html by porting to newer architecture -- TODO: Make pager work without html by porting to newer architecture
let output = unlines (map htmlify strings) let output = unlines (map htmlify strings)
htmlify str = htmlify str =
printf "<div style='background: rgb(247, 247, 247);'><form><textarea id='code'>%s</textarea></form></div>" str printf
"<div style='background: rgb(247, 247, 247);'><form><textarea id='code'>%s</textarea></form></div>"
str
++ script ++ script
script = script =
"<script>CodeMirror.fromTextArea(document.getElementById('code'), {mode: 'haskell', readOnly: 'nocursor'});</script>" "<script>CodeMirror.fromTextArea(document.getElementById('code'), {mode: 'haskell', readOnly: 'nocursor'});</script>"
return EvalOut { return
evalStatus = Success, EvalOut
evalResult = mempty, { evalStatus = Success
evalState = state, , evalResult = mempty
evalPager = output, , evalState = state
evalComms = [] , evalPager = output
} , evalComms = []
}
evalCommand _ (Directive SearchHoogle query) state = safely state $ do evalCommand _ (Directive SearchHoogle query) state = safely state $ do
results <- liftIO $ Hoogle.search query results <- liftIO $ Hoogle.search query
...@@ -711,27 +747,24 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do ...@@ -711,27 +747,24 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do
write state $ "Names: " ++ show allNames write state $ "Names: " ++ show allNames
-- Display the types of all bound names if the option is on. -- Display the types of all bound names if the option is on. This is similar to GHCi :set +t.
-- This is similar to GHCi :set +t.
if not $ useShowTypes state if not $ useShowTypes state
then return $ Display output then return $ Display output
else do else do
-- Get all the type strings. -- Get all the type strings.
types <- forM nonItNames $ \name -> do types <- forM nonItNames $ \name -> do
theType <- showSDocUnqual dflags . ppr <$> exprType name theType <- showSDocUnqual dflags . ppr <$> exprType name
return $ name ++ " :: " ++ theType return $ name ++ " :: " ++ theType
let joined = unlines types let joined = unlines types
htmled = unlines $ map formatGetType types htmled = unlines $ map formatGetType types
return $ case extractPlain output of return $
"" -> Display [html htmled] case extractPlain output of
"" -> Display [html htmled]
-- Return plain and html versions. -- Return plain and html versions. Previously there was only a plain version.
-- Previously there was only a plain version. text -> Display [plain $ joined ++ "\n" ++ text, html $ htmled ++ mono text]
text -> Display
[plain $ joined ++ "\n" ++ text,
html $ htmled ++ mono text]
RunException exception -> throw exception RunException exception -> throw exception
RunBreak{} -> error "Should not break." RunBreak{} -> error "Should not break."
...@@ -739,10 +772,9 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do ...@@ -739,10 +772,9 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do
evalCommand output (Expression expr) state = do evalCommand output (Expression expr) state = do
write state $ "Expression:\n" ++ expr write state $ "Expression:\n" ++ expr
-- Try to use `display` to convert our type into the output -- Try to use `display` to convert our type into the output Dislay If typechecking fails and there
-- Dislay If typechecking fails and there is no appropriate -- is no appropriate typeclass instance, this will throw an exception and thus `attempt` will return
-- typeclass instance, this will throw an exception and thus `attempt` will -- False, and we just resort to plaintext.
-- return False, and we just resort to plaintext.
let displayExpr = printf "(IHaskell.Display.display (%s))" expr :: String let displayExpr = printf "(IHaskell.Display.display (%s))" expr :: String
canRunDisplay <- attempt $ exprType displayExpr canRunDisplay <- attempt $ exprType displayExpr
...@@ -751,68 +783,71 @@ evalCommand output (Expression expr) state = do ...@@ -751,68 +783,71 @@ evalCommand output (Expression expr) state = do
isWidget <- attempt $ exprType widgetExpr isWidget <- attempt $ exprType widgetExpr
-- Check if this is a template haskell declaration -- Check if this is a template haskell declaration
let declExpr = printf "((id :: IHaskellTH.DecsQ -> IHaskellTH.DecsQ) (%s))" expr::String let declExpr = printf "((id :: IHaskellTH.DecsQ -> IHaskellTH.DecsQ) (%s))" expr :: String
let anyExpr = printf "((id :: IHaskellPrelude.Int -> IHaskellPrelude.Int) (%s))" expr :: String let anyExpr = printf "((id :: IHaskellPrelude.Int -> IHaskellPrelude.Int) (%s))" expr :: String
isTHDeclaration <- liftM2 (&&) (attempt $ exprType declExpr) (not <$> attempt (exprType anyExpr)) isTHDeclaration <- liftM2 (&&) (attempt $ exprType declExpr) (not <$> attempt (exprType anyExpr))
write state $ "Can Display: " ++ show canRunDisplay write state $ "Can Display: " ++ show canRunDisplay
write state $ "Is Widget: " ++ show isWidget write state $ "Is Widget: " ++ show isWidget
write state $ "Is Declaration: " ++ show isTHDeclaration write state $ "Is Declaration: " ++ show isTHDeclaration
if isTHDeclaration if isTHDeclaration
-- If it typechecks as a DecsQ, we do not want to display the DecsQ, then
-- we just want the declaration made. -- If it typechecks as a DecsQ, we do not want to display the DecsQ, we just want the
then do -- declaration made.
write state $ "Suppressing display for template haskell declaration" do
GHC.runDecls expr write state $ "Suppressing display for template haskell declaration"
return EvalOut { GHC.runDecls expr
evalStatus = Success, return
evalResult = mempty, EvalOut
evalState = state, { evalStatus = Success
evalPager = "", , evalResult = mempty
evalComms = [] , evalState = state
} , evalPager = ""
else do , evalComms = []
}
else do
if canRunDisplay if canRunDisplay
then do then do
-- Use the display. As a result, `it` is set to the output. -- Use the display. As a result, `it` is set to the output.
out <- useDisplay displayExpr out <- useDisplay displayExpr
-- Register the `it` object as a widget. -- Register the `it` object as a widget.
if isWidget if isWidget
then registerWidget out then registerWidget out
else return out else return out
else do else do
-- Evaluate this expression as though it's just a statement. -- Evaluate this expression as though it's just a statement. The output is bound to 'it', so we can
-- The output is bound to 'it', so we can then use it. -- then use it.
evalOut <- evalCommand output (Statement expr) state evalOut <- evalCommand output (Statement expr) state
let out = evalResult evalOut let out = evalResult evalOut
showErr = isShowError out showErr = isShowError out
-- If evaluation failed, return the failure. If it was successful, we -- If evaluation failed, return the failure. If it was successful, we may be able to use the
-- may be able to use the IHaskellDisplay typeclass. -- IHaskellDisplay typeclass.
return $ if not showErr || useShowErrors state return $ if not showErr || useShowErrors state
then evalOut then evalOut
else postprocessShowError evalOut else postprocessShowError evalOut
where where
-- Try to evaluate an action. Return True if it succeeds and False if -- Try to evaluate an action. Return True if it succeeds and False if it throws an exception. The
-- it throws an exception. The result of the action is discarded. -- result of the action is discarded.
attempt :: Interpreter a -> Interpreter Bool attempt :: Interpreter a -> Interpreter Bool
attempt action = gcatch (action >> return True) failure attempt action = gcatch (action >> return True) failure
where failure :: SomeException -> Interpreter Bool where
failure _ = return False failure :: SomeException -> Interpreter Bool
failure _ = return False
-- Check if the error is due to trying to print something that doesn't -- Check if the error is due to trying to print something that doesn't implement the Show typeclass.
-- implement the Show typeclass.
isShowError (ManyDisplay _) = False isShowError (ManyDisplay _) = False
isShowError (Display errs) = isShowError (Display errs) =
-- Note that we rely on this error message being 'type cleaned', so -- Note that we rely on this error message being 'type cleaned', so that `Show` is not displayed as
-- that `Show` is not displayed as GHC.Show.Show. This is also very fragile! -- GHC.Show.Show. This is also very fragile!
startswith "No instance for (Show" msg && startswith "No instance for (Show" msg &&
isInfixOf "print it" msg isInfixOf "print it" msg
where msg = extractPlain errs where
msg = extractPlain errs
isSvg (DisplayData mime _) = mime == MimeSvg isSvg (DisplayData mime _) = mime == MimeSvg
...@@ -821,20 +856,16 @@ evalCommand output (Expression expr) state = do ...@@ -821,20 +856,16 @@ evalCommand output (Expression expr) state = do
removeSvg (ManyDisplay disps) = ManyDisplay $ map removeSvg disps removeSvg (ManyDisplay disps) = ManyDisplay $ map removeSvg disps
useDisplay displayExpr = do useDisplay displayExpr = do
-- If there are instance matches, convert the object into -- If there are instance matches, convert the object into a Display. We also serialize it into a
-- a Display. We also serialize it into a bytestring. We get -- bytestring. We get the bytestring IO action as a dynamic and then convert back to a bytestring,
-- the bytestring IO action as a dynamic and then convert back to -- which we promptly unserialize. Note that attempting to do this without the serialization to
-- a bytestring, which we promptly unserialize. Note that -- binary and back gives very strange errors - all the types match but it refuses to decode back
-- attempting to do this without the serialization to binary and -- into a Display. Suppress output, so as not to mess up console. First, evaluate the expression in
-- back gives very strange errors - all the types match but it -- such a way that we have access to `it`.
-- refuses to decode back into a Display.
-- Suppress output, so as not to mess up console.
-- First, evaluate the expression in such a way that we have access to `it`.
io <- isIO expr io <- isIO expr
let stmtTemplate = if io let stmtTemplate = if io
then "it <- (%s)" then "it <- (%s)"
else "let { it = %s }" else "let { it = %s }"
evalOut <- evalCommand output (Statement $ printf stmtTemplate expr) state evalOut <- evalCommand output (Statement $ printf stmtTemplate expr) state
case evalStatus evalOut of case evalStatus evalOut of
Failure -> return evalOut Failure -> return evalOut
...@@ -853,8 +884,8 @@ evalCommand output (Expression expr) state = do ...@@ -853,8 +884,8 @@ evalCommand output (Expression expr) state = do
Right display -> Right display ->
return $ return $
if useSvg state if useSvg state
then display :: Display then display :: Display
else removeSvg display else removeSvg display
registerWidget :: EvalOut -> Ghc EvalOut registerWidget :: EvalOut -> Ghc EvalOut
registerWidget evalOut = registerWidget evalOut =
...@@ -872,10 +903,11 @@ evalCommand output (Expression expr) state = do ...@@ -872,10 +903,11 @@ evalCommand output (Expression expr) state = do
state' = state { openComms = newComms } state' = state { openComms = newComms }
-- Store the fact that we should start this comm. -- Store the fact that we should start this comm.
return evalOut { return
evalComms = CommInfo widget uuid (targetName widget) : evalComms evalOut, evalOut
evalState = state' { evalComms = CommInfo widget uuid (targetName widget) : evalComms evalOut
} , evalState = state'
}
isIO expr = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr isIO expr = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr
...@@ -885,17 +917,22 @@ evalCommand output (Expression expr) state = do ...@@ -885,17 +917,22 @@ evalCommand output (Expression expr) state = do
Display disps = evalResult evalOut Display disps = evalResult evalOut
text = extractPlain disps text = extractPlain disps
postprocess (DisplayData MimeHtml _) = html $ printf fmt unshowableType (formatErrorWithClass "err-msg collapse" text) script postprocess (DisplayData MimeHtml _) = html $ printf
fmt
unshowableType
(formatErrorWithClass "err-msg collapse"
text)
script
where where
fmt = "<div class='collapse-group'><span class='btn btn-default' href='#' id='unshowable'>Unshowable:<span class='show-type'>%s</span></span>%s</div><script>%s</script>" fmt = "<div class='collapse-group'><span class='btn btn-default' href='#' id='unshowable'>Unshowable:<span class='show-type'>%s</span></span>%s</div><script>%s</script>"
script = unlines [ script = unlines
"$('#unshowable').on('click', function(e) {", [ "$('#unshowable').on('click', function(e) {"
" e.preventDefault();", , " e.preventDefault();"
" var $this = $(this);", , " var $this = $(this);"
" var $collapse = $this.closest('.collapse-group').find('.err-msg');", , " var $collapse = $this.closest('.collapse-group').find('.err-msg');"
" $collapse.collapse('toggle');", , " $collapse.collapse('toggle');"
"});" , "});"
] ]
postprocess other = other postprocess other = other
...@@ -906,9 +943,8 @@ evalCommand output (Expression expr) state = do ...@@ -906,9 +943,8 @@ evalCommand output (Expression expr) state = do
firstChar <- headMay after firstChar <- headMay after
return $ if firstChar == '(' return $ if firstChar == '('
then init $ tail after then init $ tail after
else after else after
evalCommand _ (Declaration decl) state = wrapExecution state $ do evalCommand _ (Declaration decl) state = wrapExecution state $ do
...@@ -916,80 +952,75 @@ evalCommand _ (Declaration decl) state = wrapExecution state $ do ...@@ -916,80 +952,75 @@ evalCommand _ (Declaration decl) state = wrapExecution state $ do
boundNames <- evalDeclarations decl boundNames <- evalDeclarations decl
let nonDataNames = filter (not . isUpper . head) boundNames let nonDataNames = filter (not . isUpper . head) boundNames
-- Display the types of all bound names if the option is on. -- Display the types of all bound names if the option is on. This is similar to GHCi :set +t.
-- This is similar to GHCi :set +t.
if not $ useShowTypes state if not $ useShowTypes state
then return mempty then return mempty
else do else do
-- Get all the type strings. -- Get all the type strings.
dflags <- getSessionDynFlags dflags <- getSessionDynFlags
types <- forM nonDataNames $ \name -> do types <- forM nonDataNames $ \name -> do
theType <- showSDocUnqual dflags . ppr <$> exprType name theType <- showSDocUnqual dflags . ppr <$> exprType name
return $ name ++ " :: " ++ theType return $ name ++ " :: " ++ theType
return $ Display [html $ unlines $ map formatGetType types] return $ Display [html $ unlines $ map formatGetType types]
evalCommand _ (TypeSignature sig) state = wrapExecution state $ evalCommand _ (TypeSignature sig) state = wrapExecution state $
-- We purposefully treat this as a "success" because that way execution -- We purposefully treat this as a "success" because that way execution continues. Empty type
-- continues. Empty type signatures are likely due to a parse error later -- signatures are likely due to a parse error later on, and we want that to be displayed.
-- on, and we want that to be displayed. return $ displayError $ "The type signature " ++ sig ++ "\nlacks an accompanying binding."
return $ displayError $ "The type signature " ++ sig ++
"\nlacks an accompanying binding."
evalCommand _ (ParseError loc err) state = do evalCommand _ (ParseError loc err) state = do
write state "Parse Error." write state "Parse Error."
return EvalOut { return
evalStatus = Failure, EvalOut
evalResult = displayError $ formatParseError loc err, { evalStatus = Failure
evalState = state, , evalResult = displayError $ formatParseError loc err
evalPager = "", , evalState = state
evalComms = [] , evalPager = ""
} , evalComms = []
}
evalCommand _ (Pragma (PragmaUnsupported pragmaType) pragmas) state = wrapExecution state $ evalCommand _ (Pragma (PragmaUnsupported pragmaType) pragmas) state = wrapExecution state $
return $ displayError $ "Pragmas of type " ++ pragmaType ++ return $ displayError $ "Pragmas of type " ++ pragmaType ++ "\nare not supported."
"\nare not supported."
evalCommand output (Pragma PragmaLanguage pragmas) state = do evalCommand output (Pragma PragmaLanguage pragmas) state = do
write state $ "Got LANGUAGE pragma " ++ show pragmas write state $ "Got LANGUAGE pragma " ++ show pragmas
evalCommand output (Directive SetExtension $ unwords pragmas) state evalCommand output (Directive SetExtension $ unwords pragmas) state
hoogleResults :: KernelState -> [Hoogle.HoogleResult] -> EvalOut hoogleResults :: KernelState -> [Hoogle.HoogleResult] -> EvalOut
hoogleResults state results = EvalOut { hoogleResults state results =
evalStatus = Success, EvalOut
evalResult = mempty, { evalStatus = Success
evalState = state, , evalResult = mempty
evalPager = output, , evalState = state
evalComms = [] , evalPager = output
} , evalComms = []
}
where where
-- TODO: Make pager work with plaintext -- TODO: Make pager work with plaintext
fmt = Hoogle.HTML fmt = Hoogle.HTML
output = unlines $ map (Hoogle.render fmt) results output = unlines $ map (Hoogle.render fmt) results
-- Read from a file handle until we hit a delimiter or until we've read -- Read from a file handle until we hit a delimiter or until we've read as many characters as
-- as many characters as requested -- requested
readChars :: Handle -> String -> Int -> IO String readChars :: Handle -> String -> Int -> IO String
-- If we're done reading, return nothing. -- If we're done reading, return nothing.
readChars handle delims 0 = return [] readChars handle delims 0 = return []
readChars handle delims nchars = do readChars handle delims nchars = do
-- Try reading a single character. It will throw an exception if the -- Try reading a single character. It will throw an exception if the handle is already closed.
-- handle is already closed.
tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char) tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char)
case tryRead of case tryRead of
Right char -> Right char ->
-- If this is a delimiter, stop reading. -- If this is a delimiter, stop reading.
if char `elem` delims if char `elem` delims
then return [char] then return [char]
else do else do
next <- readChars handle delims (nchars - 1) next <- readChars handle delims (nchars - 1)
return $ char:next return $ char : next
-- An error occurs at the end of the stream, so just stop reading. -- An error occurs at the end of the stream, so just stop reading.
Left _ -> return [] Left _ -> return []
doLoadModule :: String -> String -> Ghc Display doLoadModule :: String -> String -> Ghc Display
doLoadModule name modName = do doLoadModule name modName = do
-- Remember which modules we've loaded before. -- Remember which modules we've loaded before.
...@@ -998,13 +1029,7 @@ doLoadModule name modName = do ...@@ -998,13 +1029,7 @@ doLoadModule name modName = do
flip gcatch (unload importedModules) $ do flip gcatch (unload importedModules) $ do
-- Compile loaded modules. -- Compile loaded modules.
flags <- getSessionDynFlags flags <- getSessionDynFlags
#if MIN_VERSION_ghc(7,8,0) setSessionDynFlags flags { hscTarget = objTarget flags }
let objTarget = defaultObjectTarget platform
platform = targetPlatform flags
#else
let objTarget = defaultObjectTarget
#endif
setSessionDynFlags flags{ hscTarget = objTarget }
-- Clear old targets to be sure. -- Clear old targets to be sure.
setTargets [] setTargets []
...@@ -1025,11 +1050,12 @@ doLoadModule name modName = do ...@@ -1025,11 +1050,12 @@ doLoadModule name modName = do
-- Switch back to interpreted mode. -- Switch back to interpreted mode.
flags <- getSessionDynFlags flags <- getSessionDynFlags
setSessionDynFlags flags{ hscTarget = HscInterpreted } setSessionDynFlags flags { hscTarget = HscInterpreted }
case result of case result of
Succeeded -> return mempty Succeeded -> return mempty
Failed -> return $ displayError $ "Failed to load module " ++ modName Failed -> return $ displayError $ "Failed to load module " ++ modName
where where
unload :: [InteractiveImport] -> SomeException -> Ghc Display unload :: [InteractiveImport] -> SomeException -> Ghc Display
unload imported exception = do unload imported exception = do
...@@ -1040,14 +1066,18 @@ doLoadModule name modName = do ...@@ -1040,14 +1066,18 @@ doLoadModule name modName = do
-- Switch to interpreted mode! -- Switch to interpreted mode!
flags <- getSessionDynFlags flags <- getSessionDynFlags
setSessionDynFlags flags{ hscTarget = HscInterpreted } setSessionDynFlags flags { hscTarget = HscInterpreted }
-- Return to old context, make sure we have `it`. -- Return to old context, make sure we have `it`.
setContext imported setContext imported
initializeItVariable initializeItVariable
return $ displayError $ "Failed to load module " ++ modName ++ ": " ++ show exception return $ displayError $ "Failed to load module " ++ modName ++ ": " ++ show exception
#if MIN_VERSION_ghc(7,8,0)
objTarget flags = defaultObjectTarget $ targetPlatform flags
#else
objTarget flags = defaultObjectTarget
#endif
keepingItVariable :: Interpreter a -> Interpreter a keepingItVariable :: Interpreter a -> Interpreter a
keepingItVariable act = do keepingItVariable act = do
-- Generate the it variable temp name -- Generate the it variable temp name
...@@ -1066,89 +1096,84 @@ capturedStatement :: (String -> IO ()) -- ^ Function used to publish int ...@@ -1066,89 +1096,84 @@ capturedStatement :: (String -> IO ()) -- ^ Function used to publish int
-> String -- ^ Statement to evaluate. -> String -- ^ Statement to evaluate.
-> Interpreter (String, RunResult) -- ^ Return the output and result. -> Interpreter (String, RunResult) -- ^ Return the output and result.
capturedStatement output stmt = do capturedStatement output stmt = do
-- Generate random variable names to use so that we cannot accidentally -- Generate random variable names to use so that we cannot accidentally override the variables by
-- override the variables by using the right names in the terminal. -- using the right names in the terminal.
gen <- liftIO getStdGen gen <- liftIO getStdGen
let let
-- Variable names generation. -- Variable names generation.
rand = take 20 $ randomRs ('0', '9') gen rand = take 20 $ randomRs ('0', '9') gen
var name = name ++ rand var name = name ++ rand
-- Variables for the pipe input and outputs. -- Variables for the pipe input and outputs.
readVariable = var "file_read_var_" readVariable = var "file_read_var_"
writeVariable = var "file_write_var_" writeVariable = var "file_write_var_"
-- Variable where to store old stdout. -- Variable where to store old stdout.
oldVariable = var "old_var_" oldVariable = var "old_var_"
-- Variable used to store true `it` value. -- Variable used to store true `it` value.
itVariable = var "it_var_" itVariable = var "it_var_"
voidpf str = printf $ str ++ " IHaskellPrelude.>> IHaskellPrelude.return ()" voidpf str = printf $ str ++ " IHaskellPrelude.>> IHaskellPrelude.return ()"
-- Statements run before the thing we're evaluating. -- Statements run before the thing we're evaluating.
initStmts = initStmts =
[ printf "let %s = it" itVariable [ printf "let %s = it" itVariable
, printf "(%s, %s) <- IHaskellIO.createPipe" readVariable writeVariable , printf "(%s, %s) <- IHaskellIO.createPipe" readVariable writeVariable
, printf "%s <- IHaskellIO.dup IHaskellIO.stdOutput" oldVariable , printf "%s <- IHaskellIO.dup IHaskellIO.stdOutput" oldVariable
, voidpf "IHaskellIO.dupTo %s IHaskellIO.stdOutput" writeVariable , voidpf "IHaskellIO.dupTo %s IHaskellIO.stdOutput" writeVariable
, voidpf "IHaskellSysIO.hSetBuffering IHaskellSysIO.stdout IHaskellSysIO.NoBuffering" , voidpf "IHaskellSysIO.hSetBuffering IHaskellSysIO.stdout IHaskellSysIO.NoBuffering"
, printf "let it = %s" itVariable , printf "let it = %s" itVariable
] ]
-- Statements run after evaluation. -- Statements run after evaluation.
postStmts = postStmts =
[ printf "let %s = it" itVariable [ printf "let %s = it" itVariable
, voidpf "IHaskellSysIO.hFlush IHaskellSysIO.stdout" , voidpf "IHaskellSysIO.hFlush IHaskellSysIO.stdout"
, voidpf "IHaskellIO.dupTo %s IHaskellIO.stdOutput" oldVariable , voidpf "IHaskellIO.dupTo %s IHaskellIO.stdOutput" oldVariable
, voidpf "IHaskellIO.closeFd %s" writeVariable , voidpf "IHaskellIO.closeFd %s" writeVariable
, printf "let it = %s" itVariable , printf "let it = %s" itVariable
] ]
pipeExpr = printf "let %s = %s" (var "pipe_var_") readVariable pipeExpr = printf "let %s = %s" (var "pipe_var_") readVariable
goStmt :: String -> Ghc RunResult goStmt :: String -> Ghc RunResult
goStmt s = runStmt s RunToCompletion goStmt s = runStmt s RunToCompletion
-- Initialize evaluation context. -- Initialize evaluation context.
void $ forM initStmts goStmt void $ forM initStmts goStmt
-- Get the pipe to read printed output from. -- Get the pipe to read printed output from. This is effectively the source code of dynCompileExpr
-- This is effectively the source code of dynCompileExpr from GHC API's -- from GHC API's InteractiveEval. However, instead of using a `Dynamic` as an intermediary, it just
-- InteractiveEval. However, instead of using a `Dynamic` as an -- directly reads the value. This is incredibly unsafe! However, for some reason the `getContext`
-- intermediary, it just directly reads the value. This is incredibly -- and `setContext` required by dynCompileExpr (to import and clear Data.Dynamic) cause issues with
-- unsafe! However, for some reason the `getContext` and `setContext` -- data declarations being updated (e.g. it drops newer versions of data declarations for older ones
-- required by dynCompileExpr (to import and clear Data.Dynamic) cause -- for unknown reasons). First, compile down to an HValue.
-- issues with data declarations being updated (e.g. it drops newer
-- versions of data declarations for older ones for unknown reasons).
-- First, compile down to an HValue.
Just (_, hValues, _) <- withSession $ liftIO . flip hscStmt pipeExpr Just (_, hValues, _) <- withSession $ liftIO . flip hscStmt pipeExpr
-- Then convert the HValue into an executable bit, and read the value. -- Then convert the HValue into an executable bit, and read the value.
pipe <- liftIO $ do pipe <- liftIO $ do
fd <- head <$> unsafeCoerce hValues fd <- head <$> unsafeCoerce hValues
fdToHandle fd fdToHandle fd
-- Read from a file handle until we hit a delimiter or until we've read -- Read from a file handle until we hit a delimiter or until we've read as many characters as
-- as many characters as requested -- requested
let let readChars :: Handle -> String -> Int -> IO String
readChars :: Handle -> String -> Int -> IO String
-- If we're done reading, return nothing.
-- If we're done reading, return nothing. readChars handle delims 0 = return []
readChars handle delims 0 = return []
readChars handle delims nchars = do
readChars handle delims nchars = do -- Try reading a single character. It will throw an exception if the handle is already closed.
-- Try reading a single character. It will throw an exception if the tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char)
-- handle is already closed. case tryRead of
tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char) Right char ->
case tryRead of -- If this is a delimiter, stop reading.
Right char -> if char `elem` delims
-- If this is a delimiter, stop reading. then return [char]
if char `elem` delims else do
then return [char] next <- readChars handle delims (nchars - 1)
else do return $ char : next
next <- readChars handle delims (nchars - 1) -- An error occurs at the end of the stream, so just stop reading.
return $ char:next Left _ -> return []
-- An error occurs at the end of the stream, so just stop reading.
Left _ -> return []
-- Keep track of whether execution has completed. -- Keep track of whether execution has completed.
...@@ -1157,53 +1182,52 @@ capturedStatement output stmt = do ...@@ -1157,53 +1182,52 @@ capturedStatement output stmt = do
outputAccum <- liftIO $ newMVar "" outputAccum <- liftIO $ newMVar ""
-- Start a loop to publish intermediate results. -- Start a loop to publish intermediate results.
let let
-- Compute how long to wait between reading pieces of the output. -- Compute how long to wait between reading pieces of the output. `threadDelay` takes an
-- `threadDelay` takes an argument of microseconds. -- argument of microseconds.
ms = 1000 ms = 1000
delay = 100 * ms delay = 100 * ms
-- How much to read each time. -- How much to read each time.
chunkSize = 100 chunkSize = 100
-- Maximum size of the output (after which we truncate). -- Maximum size of the output (after which we truncate).
maxSize = 100 * 1000 maxSize = 100 * 1000
loop = do loop = do
-- Wait and then check if the computation is done. -- Wait and then check if the computation is done.
threadDelay delay threadDelay delay
computationDone <- readMVar completed computationDone <- readMVar completed
if not computationDone if not computationDone
then do then do
-- Read next chunk and append to accumulator. -- Read next chunk and append to accumulator.
nextChunk <- readChars pipe "\n" 100 nextChunk <- readChars pipe "\n" 100
modifyMVar_ outputAccum (return . (++ nextChunk)) modifyMVar_ outputAccum (return . (++ nextChunk))
-- Write to frontend and repeat. -- Write to frontend and repeat.
readMVar outputAccum >>= output readMVar outputAccum >>= output
loop loop
else do else do
-- Read remainder of output and accumulate it. -- Read remainder of output and accumulate it.
nextChunk <- readChars pipe "" maxSize nextChunk <- readChars pipe "" maxSize
modifyMVar_ outputAccum (return . (++ nextChunk)) modifyMVar_ outputAccum (return . (++ nextChunk))
-- We're done reading. -- We're done reading.
putMVar finishedReading True putMVar finishedReading True
liftIO $ forkIO loop liftIO $ forkIO loop
result <- gfinally (goStmt stmt) $ do result <- gfinally (goStmt stmt) $ do
-- Execution is done. -- Execution is done.
liftIO $ modifyMVar_ completed (const $ return True) liftIO $ modifyMVar_ completed (const $ return True)
-- Finalize evaluation context. -- Finalize evaluation context.
void $ forM postStmts goStmt void $ forM postStmts goStmt
-- Once context is finalized, reading can finish. -- Once context is finalized, reading can finish. Wait for reading to finish to that the output
-- Wait for reading to finish to that the output accumulator is -- accumulator is completely filled.
-- completely filled. liftIO $ takeMVar finishedReading
liftIO $ takeMVar finishedReading
printedOutput <- liftIO $ readMVar outputAccum printedOutput <- liftIO $ readMVar outputAccum
return (printedOutput, result) return (printedOutput, result)
...@@ -1213,14 +1237,14 @@ formatError = formatErrorWithClass "err-msg" ...@@ -1213,14 +1237,14 @@ formatError = formatErrorWithClass "err-msg"
formatErrorWithClass :: String -> ErrMsg -> String formatErrorWithClass :: String -> ErrMsg -> String
formatErrorWithClass cls = formatErrorWithClass cls =
printf "<span class='%s'>%s</span>" cls . printf "<span class='%s'>%s</span>" cls .
replace "\n" "<br/>" . replace "\n" "<br/>" .
replace useDashV "" . replace useDashV "" .
replace "Ghci" "IHaskell" . replace "Ghci" "IHaskell" .
replace "‘interactive:" "‘" . replace "‘interactive:" "‘" .
fixDollarSigns . fixDollarSigns .
rstrip . rstrip .
typeCleaner typeCleaner
where where
fixDollarSigns = replace "$" "<span>$</span>" fixDollarSigns = replace "$" "<span>$</span>"
useDashV = "\nUse -v to see a list of the files searched for." useDashV = "\nUse -v to see a list of the files searched for."
...@@ -1228,7 +1252,6 @@ formatErrorWithClass cls = ...@@ -1228,7 +1252,6 @@ formatErrorWithClass cls =
startswith "No instance for (Show" err && startswith "No instance for (Show" err &&
isInfixOf " arising from a use of `print'" err isInfixOf " arising from a use of `print'" err
formatParseError :: StringLoc -> String -> ErrMsg formatParseError :: StringLoc -> String -> ErrMsg
formatParseError (Loc line col) = formatParseError (Loc line col) =
printf "Parse error (line %d, column %d): %s" line col printf "Parse error (line %d, column %d): %s" line col
...@@ -1237,7 +1260,7 @@ formatGetType :: String -> String ...@@ -1237,7 +1260,7 @@ formatGetType :: String -> String
formatGetType = printf "<span class='get-type'>%s</span>" formatGetType = printf "<span class='get-type'>%s</span>"
formatType :: String -> Display formatType :: String -> Display
formatType typeStr = Display [plain typeStr, html $ formatGetType typeStr] formatType typeStr = Display [plain typeStr, html $ formatGetType typeStr]
displayError :: ErrMsg -> Display displayError :: ErrMsg -> Display
displayError msg = Display [plain . typeCleaner $ msg, html $ formatError msg] displayError msg = Display [plain . typeCleaner $ msg, html $ formatError msg]
......
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances, OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude, FlexibleInstances, OverloadedStrings #-}
module IHaskell.Eval.Hoogle ( module IHaskell.Eval.Hoogle (
search, search,
document, document,
render, render,
OutputFormat(..), OutputFormat(..),
HoogleResult HoogleResult,
) where ) where
import ClassyPrelude hiding (last, span, div) import ClassyPrelude hiding (last, span, div)
import Text.Printf import Text.Printf
import Network.HTTP.Client import Network.HTTP.Client
import Network.HTTP.Client.TLS import Network.HTTP.Client.TLS
import Data.Aeson import Data.Aeson
import Data.String.Utils import Data.String.Utils
import Data.List (elemIndex, (!!), last) import Data.List (elemIndex, (!!), last)
import Data.Char (isAscii, isAlphaNum) import Data.Char (isAscii, isAlphaNum)
import qualified Data.ByteString.Lazy.Char8 as Char import qualified Data.ByteString.Lazy.Char8 as Char
import qualified Prelude as P import qualified Prelude as P
import IHaskell.IPython import IHaskell.IPython
-- | Types of formats to render output to. -- | Types of formats to render output to.
data OutputFormat data OutputFormat = Plain -- ^ Render to plain text.
= Plain -- ^ Render to plain text. | HTML -- ^ Render to HTML.
| HTML -- ^ Render to HTML.
data HoogleResponse = HoogleResponse { location :: String, self :: String, docs :: String }
data HoogleResponse = HoogleResponse {
location :: String,
self :: String,
docs :: String
}
deriving (Eq, Show) deriving (Eq, Show)
data HoogleResult data HoogleResult = SearchResult HoogleResponse
= SearchResult HoogleResponse | DocResult HoogleResponse
| DocResult HoogleResponse | NoResult String
| NoResult String deriving Show
deriving Show
instance FromJSON [HoogleResponse] where instance FromJSON [HoogleResponse] where
parseJSON (Object obj) = do parseJSON (Object obj) = do
...@@ -48,81 +43,80 @@ instance FromJSON [HoogleResponse] where ...@@ -48,81 +43,80 @@ instance FromJSON [HoogleResponse] where
instance FromJSON HoogleResponse where instance FromJSON HoogleResponse where
parseJSON (Object obj) = parseJSON (Object obj) =
HoogleResponse <$> HoogleResponse <$> obj .: "location" <*> obj .: "self" <*> obj .: "docs"
obj .: "location" <*>
obj .: "self" <*>
obj .: "docs"
parseJSON _ = fail "Expected object with fields: location, self, docs" parseJSON _ = fail "Expected object with fields: location, self, docs"
-- | Query Hoogle for the given string. -- | Query Hoogle for the given string. This searches Hoogle using the internet. It returns either
-- This searches Hoogle using the internet. It returns either an error -- an error message or the successful JSON result.
-- message or the successful JSON result.
query :: String -> IO (Either String String) query :: String -> IO (Either String String)
query str = do query str = do
request <- parseUrl $ queryUrl $ urlEncode str request <- parseUrl $ queryUrl $ urlEncode str
response <- try $ withManager tlsManagerSettings $ httpLbs request response <- try $ withManager tlsManagerSettings $ httpLbs request
return $ case response of return $
Left err -> Left $ show (err :: SomeException) case response of
Right resp -> Right $ Char.unpack $ responseBody resp Left err -> Left $ show (err :: SomeException)
Right resp -> Right $ Char.unpack $ responseBody resp
where where
queryUrl :: String -> String queryUrl :: String -> String
queryUrl = printf "https://www.haskell.org/hoogle/?hoogle=%s&mode=json" queryUrl = printf "https://www.haskell.org/hoogle/?hoogle=%s&mode=json"
-- | Copied from the HTTP package. -- | Copied from the HTTP package.
urlEncode :: String -> String urlEncode :: String -> String
urlEncode [] = [] urlEncode [] = []
urlEncode (ch:t) urlEncode (ch:t)
| (isAscii ch && isAlphaNum ch) || ch `P.elem` "-_.~" = ch : urlEncode t | (isAscii ch && isAlphaNum ch) || ch `P.elem` "-_.~" = ch : urlEncode t
| not (isAscii ch) = P.foldr escape (urlEncode t) (eightBs [] (P.fromEnum ch)) | not (isAscii ch) = P.foldr escape (urlEncode t) (eightBs [] (P.fromEnum ch))
| otherwise = escape (P.fromEnum ch) (urlEncode t) | otherwise = escape (P.fromEnum ch) (urlEncode t)
where where
escape :: Int -> String -> String escape :: Int -> String -> String
escape b rs = '%':showH (b `P.div` 16) (showH (b `mod` 16) rs) escape b rs = '%' : showH (b `P.div` 16) (showH (b `mod` 16) rs)
showH :: Int -> String -> String showH :: Int -> String -> String
showH x xs showH x xs
| x <= 9 = toEnum (o_0 + x) : xs | x <= 9 = toEnum (o_0 + x) : xs
| otherwise = toEnum (o_A + (x-10)) : xs | otherwise = toEnum (o_A + (x - 10)) : xs
where where
o_0 = P.fromEnum '0' o_0 = P.fromEnum '0'
o_A = P.fromEnum 'A' o_A = P.fromEnum 'A'
eightBs :: [Int] -> Int -> [Int] eightBs :: [Int] -> Int -> [Int]
eightBs acc x eightBs acc x
| x <= 0xff = (x:acc) | x <= 255 = x : acc
| otherwise = eightBs ((x `mod` 256) : acc) (x `P.div` 256) | otherwise = eightBs ((x `mod` 256) : acc) (x `P.div` 256)
-- | Search for a query on Hoogle. -- | Search for a query on Hoogle. Return all search results.
-- Return all search results.
search :: String -> IO [HoogleResult] search :: String -> IO [HoogleResult]
search string = do search string = do
response <- query string response <- query string
return $ case response of return $
Left err -> [NoResult err] case response of
Right json -> Left err -> [NoResult err]
case eitherDecode $ Char.pack json of Right json ->
Left err -> [NoResult err] case eitherDecode $ Char.pack json of
Right results -> Left err -> [NoResult err]
case map SearchResult results of Right results ->
[] -> [NoResult "no matching identifiers found."] case map SearchResult results of
res -> res [] -> [NoResult "no matching identifiers found."]
res -> res
-- | Look up an identifier on Hoogle.
-- Return documentation for that identifier. If there are many -- | Look up an identifier on Hoogle. Return documentation for that identifier. If there are many
-- identifiers, include documentation for all of them. -- identifiers, include documentation for all of them.
document :: String -> IO [HoogleResult] document :: String -> IO [HoogleResult]
document string = do document string = do
matchingResults <- filter matches <$> search string matchingResults <- filter matches <$> search string
let results = map toDocResult matchingResults let results = map toDocResult matchingResults
return $ case results of return $
[] -> [NoResult "no matching identifiers found."] case results of
res -> res [] -> [NoResult "no matching identifiers found."]
res -> res
where where
matches (SearchResult resp) = matches (SearchResult resp) =
case split " " $ self resp of case split " " $ self resp of
name:_ -> strip string == strip name name:_ -> strip string == strip name
_ -> False _ -> False
matches _ = False matches _ = False
toDocResult (SearchResult resp) = DocResult resp toDocResult (SearchResult resp) = DocResult resp
...@@ -130,25 +124,18 @@ document string = do ...@@ -130,25 +124,18 @@ document string = do
-- | Render a Hoogle search result into an output format. -- | Render a Hoogle search result into an output format.
render :: OutputFormat -> HoogleResult -> String render :: OutputFormat -> HoogleResult -> String
render Plain = renderPlain render Plain = renderPlain
render HTML = renderHtml render HTML = renderHtml
-- | Render a Hoogle result to plain text. -- | Render a Hoogle result to plain text.
renderPlain :: HoogleResult -> String renderPlain :: HoogleResult -> String
renderPlain (NoResult res) = renderPlain (NoResult res) =
"No response available: " ++ res "No response available: " ++ res
renderPlain (SearchResult resp) = renderPlain (SearchResult resp) =
printf "%s\nURL: %s\n%s" printf "%s\nURL: %s\n%s" (self resp) (location resp) (docs resp)
(self resp)
(location resp)
(docs resp)
renderPlain (DocResult resp) = renderPlain (DocResult resp) =
printf "%s\nURL: %s\n%s" printf "%s\nURL: %s\n%s" (self resp) (location resp) (docs resp)
(self resp)
(location resp)
(docs resp)
-- | Render a Hoogle result to HTML. -- | Render a Hoogle result to HTML.
renderHtml :: HoogleResult -> String renderHtml :: HoogleResult -> String
...@@ -167,37 +154,37 @@ renderHtml (SearchResult resp) = ...@@ -167,37 +154,37 @@ renderHtml (SearchResult resp) =
renderSelf :: String -> String -> String renderSelf :: String -> String -> String
renderSelf string loc renderSelf string loc
| startswith "package" string | startswith "package" string =
= pkg ++ " " ++ span "hoogle-package" (link loc $ extractPackage string) pkg ++ " " ++ span "hoogle-package" (link loc $ extractPackage string)
| startswith "module" string | startswith "module" string =
= let package = extractPackageName loc in let package = extractPackageName loc
mod ++ " " ++ in mod ++ " " ++
span "hoogle-module" (link loc $ extractModule string) ++ span "hoogle-module" (link loc $ extractModule string) ++
packageSub package packageSub package
| startswith "class" string | startswith "class" string =
= let package = extractPackageName loc in let package = extractPackageName loc
cls ++ " " ++ in cls ++ " " ++
span "hoogle-class" (link loc $ extractClass string) ++ span "hoogle-class" (link loc $ extractClass string) ++
packageSub package packageSub package
| startswith "data" string | startswith "data" string =
= let package = extractPackageName loc in let package = extractPackageName loc
dat ++ " " ++ in dat ++ " " ++
span "hoogle-class" (link loc $ extractData string) ++ span "hoogle-class" (link loc $ extractData string) ++
packageSub package packageSub package
| otherwise | otherwise =
= let [name, args] = split "::" string let [name, args] = split "::" string
package = extractPackageName loc package = extractPackageName loc
modname = extractModuleName loc in modname = extractModuleName loc
span "hoogle-name" (unicodeReplace $ in span "hoogle-name"
link loc (strip name) ++ (unicodeReplace $
" :: " ++ link loc (strip name) ++
strip args) " :: " ++
++ packageAndModuleSub package modname strip args)
++ packageAndModuleSub package modname
where where
extractPackage = strip . replace "package" "" extractPackage = strip . replace "package" ""
extractModule = strip . replace "module" "" extractModule = strip . replace "module" ""
...@@ -210,10 +197,10 @@ renderSelf string loc ...@@ -210,10 +197,10 @@ renderSelf string loc
unicodeReplace :: String -> String unicodeReplace :: String -> String
unicodeReplace = unicodeReplace =
replace "forall" "&#x2200;" . replace "forall" "&#x2200;" .
replace "=>" "&#x21D2;" . replace "=>" "&#x21D2;" .
replace "->" "&#x2192;" . replace "->" "&#x2192;" .
replace "::" "&#x2237;" replace "::" "&#x2237;"
packageSub Nothing = "" packageSub Nothing = ""
packageSub (Just package) = packageSub (Just package) =
...@@ -223,26 +210,25 @@ renderSelf string loc ...@@ -223,26 +210,25 @@ renderSelf string loc
packageAndModuleSub Nothing _ = "" packageAndModuleSub Nothing _ = ""
packageAndModuleSub (Just package) Nothing = packageSub (Just package) packageAndModuleSub (Just package) Nothing = packageSub (Just package)
packageAndModuleSub (Just package) (Just modname) = packageAndModuleSub (Just package) (Just modname) =
span "hoogle-sub" $ span "hoogle-sub" $
"(" ++ pkg ++ " " ++ span "hoogle-package" package ++ "(" ++ pkg ++ " " ++ span "hoogle-package" package ++
", " ++ mod ++ " " ++ span "hoogle-module" modname ++ ")" ", " ++ mod ++ " " ++ span "hoogle-module" modname ++ ")"
renderDocs :: String -> String renderDocs :: String -> String
renderDocs doc = renderDocs doc =
let groups = groupBy bothAreCode $ lines doc let groups = groupBy bothAreCode $ lines doc
nonull = filter (not . null . strip) nonull = filter (not . null . strip)
bothAreCode s1 s2 = bothAreCode s1 s2 =
startswith ">" (strip s1) && startswith ">" (strip s1) &&
startswith ">" (strip s2) startswith ">" (strip s2)
isCode (s:_) = startswith ">" $ strip s isCode (s:_) = startswith ">" $ strip s
makeBlock lines = makeBlock lines =
if isCode lines if isCode lines
then div "hoogle-code" $ unlines $ nonull lines then div "hoogle-code" $ unlines $ nonull lines
else div "hoogle-text" $ unlines $ nonull lines else div "hoogle-text" $ unlines $ nonull lines
in in div "hoogle-doc" $ unlines $ map makeBlock groups
div "hoogle-doc" $ unlines $ map makeBlock groups
extractPackageName :: String -> Maybe String extractPackageName :: String -> Maybe String
extractPackageName link = do extractPackageName link = do
let pieces = split "/" link let pieces = split "/" link
archiveLoc <- elemIndex "archive" pieces archiveLoc <- elemIndex "archive" pieces
...@@ -250,7 +236,7 @@ extractPackageName link = do ...@@ -250,7 +236,7 @@ extractPackageName link = do
guard $ latestLoc - archiveLoc == 2 guard $ latestLoc - archiveLoc == 2
return $ pieces !! (latestLoc - 1) return $ pieces !! (latestLoc - 1)
extractModuleName :: String -> Maybe String extractModuleName :: String -> Maybe String
extractModuleName link = do extractModuleName link = do
let pieces = split "/" link let pieces = split "/" link
guard $ not $ null pieces guard $ not $ null pieces
......
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{- | Description : Inspect type and function information and documentation.
-}
module IHaskell.Eval.Info (
info
) where
import ClassyPrelude hiding (liftIO) {- | Description : Inspect type and function information and documentation. -}
module IHaskell.Eval.Info (info) where
import IHaskell.Eval.Evaluate (typeCleaner, Interpreter) import ClassyPrelude hiding (liftIO)
import GHC import IHaskell.Eval.Evaluate (typeCleaner, Interpreter)
import Outputable
import Exception import GHC
import Outputable
import Exception
info :: String -> Interpreter String info :: String -> Interpreter String
info name = ghandle handler $ do info name = ghandle handler $ do
dflags <- getSessionDynFlags dflags <- getSessionDynFlags
result <- exprType name result <- exprType name
return $ typeCleaner $ showPpr dflags result return $ typeCleaner $ showPpr dflags result
where where
handler :: SomeException -> Interpreter String handler :: SomeException -> Interpreter String
handler _ = return "" handler _ = return ""
{-# LANGUAGE NoImplicitPrelude, QuasiQuotes, ViewPatterns #-} {-# LANGUAGE NoImplicitPrelude, QuasiQuotes, ViewPatterns #-}
module IHaskell.Eval.Lint (
lint module IHaskell.Eval.Lint (lint) where
) where
import Data.String.Utils (replace, startswith, strip, split)
import Data.String.Utils (replace, startswith, strip, split) import Prelude (head, tail, last)
import Prelude (head, tail, last) import ClassyPrelude hiding (last)
import ClassyPrelude hiding (last) import Control.Monad
import Control.Monad import Data.List (findIndex)
import Data.List (findIndex) import Text.Printf
import Text.Printf import Data.String.Here
import Data.String.Here import Data.Char
import Data.Char import Data.Monoid
import Data.Monoid import Data.Maybe (mapMaybe)
import Data.Maybe (mapMaybe) import System.IO.Unsafe (unsafePerformIO)
import System.IO.Unsafe (unsafePerformIO)
import Language.Haskell.Exts.Annotated.Syntax hiding (Module)
import Language.Haskell.Exts.Annotated.Syntax hiding (Module)
import qualified Language.Haskell.Exts.Annotated.Syntax as SrcExts import qualified Language.Haskell.Exts.Annotated.Syntax as SrcExts
import Language.Haskell.Exts.Annotated (parseFileContentsWithMode) import Language.Haskell.Exts.Annotated (parseFileContentsWithMode)
import Language.Haskell.Exts.Annotated.Build (doE) import Language.Haskell.Exts.Annotated.Build (doE)
import Language.Haskell.Exts.Annotated hiding (Module) import Language.Haskell.Exts.Annotated hiding (Module)
import Language.Haskell.Exts.SrcLoc import Language.Haskell.Exts.SrcLoc
import Language.Haskell.HLint as HLint import Language.Haskell.HLint as HLint
import Language.Haskell.HLint2 import Language.Haskell.HLint2
import IHaskell.Types import IHaskell.Types
import IHaskell.Display import IHaskell.Display
import IHaskell.IPython import IHaskell.IPython
import IHaskell.Eval.Parser hiding (line) import IHaskell.Eval.Parser hiding (line)
type ExtsModule = SrcExts.Module SrcSpanInfo type ExtsModule = SrcExts.Module SrcSpanInfo
data LintSuggestion data LintSuggestion =
= Suggest { Suggest
line :: LineNumber, { line :: LineNumber
found :: String, , found :: String
whyNot :: String, , whyNot :: String
severity :: Severity, , severity :: Severity
suggestion :: String , suggestion :: String
} }
deriving (Eq, Show) deriving (Eq, Show)
-- Store settings for Hlint once it's initialized. -- Store settings for Hlint once it's initialized.
...@@ -51,8 +50,8 @@ hlintSettings = unsafePerformIO newEmptyMVar ...@@ -51,8 +50,8 @@ hlintSettings = unsafePerformIO newEmptyMVar
lintIdent :: String lintIdent :: String
lintIdent = "lintIdentAEjlkQeh" lintIdent = "lintIdentAEjlkQeh"
-- | Given parsed code chunks, perform linting and output a displayable -- | Given parsed code chunks, perform linting and output a displayable report on linting warnings
-- report on linting warnings and errors. -- and errors.
lint :: [Located CodeBlock] -> IO Display lint :: [Located CodeBlock] -> IO Display
lint blocks = do lint blocks = do
-- Initialize hlint settings -- Initialize hlint settings
...@@ -66,63 +65,62 @@ lint blocks = do ...@@ -66,63 +65,62 @@ lint blocks = do
-- create 'suggestions' -- create 'suggestions'
let modules = mapMaybe (createModule mode) blocks let modules = mapMaybe (createModule mode) blocks
ideas = applyHints classify hint (map (\m->(m,[])) modules) ideas = applyHints classify hint (map (\m -> (m, [])) modules)
suggestions = mapMaybe showIdea ideas suggestions = mapMaybe showIdea ideas
return $ Display $ return $ Display $
if null suggestions if null suggestions
then [] then []
else else [plain $ concatMap plainSuggestion suggestions, html $ htmlSuggestions suggestions]
[plain $ concatMap plainSuggestion suggestions,
html $ htmlSuggestions suggestions]
showIdea :: Idea -> Maybe LintSuggestion showIdea :: Idea -> Maybe LintSuggestion
showIdea idea = showIdea idea =
case ideaTo idea of case ideaTo idea of
Nothing -> Nothing Nothing -> Nothing
Just whyNot -> Just Suggest { Just whyNot -> Just
line = srcSpanStartLine $ ideaSpan idea, Suggest
found = showSuggestion $ ideaFrom idea, { line = srcSpanStartLine $ ideaSpan idea
whyNot = showSuggestion whyNot, , found = showSuggestion $ ideaFrom idea
severity = ideaSeverity idea, , whyNot = showSuggestion whyNot
suggestion = ideaHint idea , severity = ideaSeverity idea
} , suggestion = ideaHint idea
}
createModule :: ParseMode -> Located CodeBlock -> Maybe ExtsModule createModule :: ParseMode -> Located CodeBlock -> Maybe ExtsModule
createModule mode (Located line block) = createModule mode (Located line block) =
case block of case block of
Expression expr -> unparse $ exprToModule expr Expression expr -> unparse $ exprToModule expr
Declaration decl -> unparse $ declToModule decl Declaration decl -> unparse $ declToModule decl
Statement stmt -> unparse $ stmtToModule stmt Statement stmt -> unparse $ stmtToModule stmt
Import impt -> unparse $ imptToModule impt Import impt -> unparse $ imptToModule impt
Module mod -> unparse $ parseModule mod Module mod -> unparse $ parseModule mod
_ -> Nothing _ -> Nothing
where where
blockStr = blockStr =
case block of case block of
Expression expr -> expr Expression expr -> expr
Declaration decl -> decl Declaration decl -> decl
Statement stmt -> stmt Statement stmt -> stmt
Import impt -> impt Import impt -> impt
Module mod -> mod Module mod -> mod
unparse :: ParseResult a -> Maybe a unparse :: ParseResult a -> Maybe a
unparse (ParseOk a) = Just a unparse (ParseOk a) = Just a
unparse _ = Nothing unparse _ = Nothing
srcSpan :: SrcSpan srcSpan :: SrcSpan
srcSpan = SrcSpan { srcSpan = SrcSpan
srcSpanFilename = "<interactive>", { srcSpanFilename = "<interactive>"
srcSpanStartLine = line, , srcSpanStartLine = line
srcSpanStartColumn = 0, , srcSpanStartColumn = 0
srcSpanEndLine = line + length (lines blockStr), , srcSpanEndLine = line + length (lines blockStr)
srcSpanEndColumn = length $ last $ lines blockStr , srcSpanEndColumn = length $ last $ lines blockStr
} }
loc :: SrcSpanInfo loc :: SrcSpanInfo
loc = SrcSpanInfo srcSpan [] loc = SrcSpanInfo srcSpan []
moduleWithDecls :: Decl SrcSpanInfo -> ExtsModule moduleWithDecls :: Decl SrcSpanInfo -> ExtsModule
moduleWithDecls decl = SrcExts.Module loc Nothing [] [] [decl] moduleWithDecls decl = SrcExts.Module loc Nothing [] [] [decl]
parseModule :: String -> ParseResult ExtsModule parseModule :: String -> ParseResult ExtsModule
...@@ -135,9 +133,10 @@ createModule mode (Located line block) = ...@@ -135,9 +133,10 @@ createModule mode (Located line block) =
exprToModule exp = moduleWithDecls <$> SpliceDecl loc <$> parseExpWithMode mode exp exprToModule exp = moduleWithDecls <$> SpliceDecl loc <$> parseExpWithMode mode exp
stmtToModule :: String -> ParseResult ExtsModule stmtToModule :: String -> ParseResult ExtsModule
stmtToModule stmtStr = case parseStmtWithMode mode stmtStr of stmtToModule stmtStr =
ParseOk stmt -> ParseOk mod case parseStmtWithMode mode stmtStr of
ParseFailed a b -> ParseFailed a b ParseOk stmt -> ParseOk mod
ParseFailed a b -> ParseFailed a b
where where
mod = moduleWithDecls decl mod = moduleWithDecls decl
...@@ -157,35 +156,31 @@ createModule mode (Located line block) = ...@@ -157,35 +156,31 @@ createModule mode (Located line block) =
imptToModule = parseFileContentsWithMode mode imptToModule = parseFileContentsWithMode mode
plainSuggestion :: LintSuggestion -> String plainSuggestion :: LintSuggestion -> String
plainSuggestion suggest = plainSuggestion suggest =
printf "Line %d: %s\nFound:\n%s\nWhy not:\n%s" printf "Line %d: %s\nFound:\n%s\nWhy not:\n%s" (line suggest) (suggestion suggest) (found suggest)
(line suggest)
(suggestion suggest)
(found suggest)
(whyNot suggest) (whyNot suggest)
htmlSuggestions :: [LintSuggestion] -> String htmlSuggestions :: [LintSuggestion] -> String
htmlSuggestions = concatMap toHtml htmlSuggestions = concatMap toHtml
where where
toHtml :: LintSuggestion -> String toHtml :: LintSuggestion -> String
toHtml suggest = concat toHtml suggest = concat
[ [ named $ suggestion suggest
named $ suggestion suggest, , floating "left" $ style severityClass "Found:" ++
floating "left" $ style severityClass "Found:" ++ -- Things that look like this get highlighted.
-- Things that look like this get highlighted. styleId "highlight-code" "haskell" (found suggest)
styleId "highlight-code" "haskell" (found suggest), , floating "left" $ style severityClass "Why Not:" ++
floating "left" $ style severityClass "Why Not:" ++ -- Things that look like this get highlighted.
-- Things that look like this get highlighted. styleId "highlight-code" "haskell" (whyNot suggest)
styleId "highlight-code" "haskell" (whyNot suggest) ]
]
where where
severityClass = case severity suggest of severityClass =
Error -> "error" case severity suggest of
Warning -> "warning" Error -> "error"
Warning -> "warning"
-- Should not occur -- Should not occur
_ -> "warning" _ -> "warning"
style :: String -> String -> String style :: String -> String -> String
style cls thing = [i| <div class="suggestion-${cls}">${thing}</div> |] style cls thing = [i| <div class="suggestion-${cls}">${thing}</div> |]
...@@ -195,37 +190,32 @@ htmlSuggestions = concatMap toHtml ...@@ -195,37 +190,32 @@ htmlSuggestions = concatMap toHtml
styleId :: String -> String -> String -> String styleId :: String -> String -> String -> String
styleId cls id thing = [i| <div class="${cls}" id="${id}">${thing}</div> |] styleId cls id thing = [i| <div class="${cls}" id="${id}">${thing}</div> |]
floating :: String -> String -> String floating :: String -> String -> String
floating dir thing = [i| <div class="suggestion-row" style="float: ${dir};">${thing}</div> |] floating dir thing = [i| <div class="suggestion-row" style="float: ${dir};">${thing}</div> |]
showSuggestion :: String -> String showSuggestion :: String -> String
showSuggestion = remove lintIdent . dropDo showSuggestion = remove lintIdent . dropDo
where where
remove str = replace str "" remove str = replace str ""
-- Drop leading ' do ', and blank spaces following. -- Drop leading ' do ', and blank spaces following.
dropDo :: String -> String dropDo :: String -> String
dropDo string = dropDo string =
-- If this is not a statement, we don't need to drop the do statement. -- If this is not a statement, we don't need to drop the do statement.
if lintIdent `isInfixOf` string if lintIdent `isInfixOf` string
then unlines . clean . lines $ string then unlines . clean . lines $ string
else string else string
clean :: [String] -> [String] clean :: [String] -> [String]
-- If the first line starts with a `do`... -- If the first line starts with a `do`... Note that hlint always indents by two spaces in its
-- Note that hlint always indents by two spaces in its output. -- output.
clean ((stripPrefix " do " -> Just a) : as) = clean ((stripPrefix " do " -> Just a):as) =
-- Take all indented lines and unindent them. -- Take all indented lines and unindent them.
let unindented = catMaybes let unindented = catMaybes $ takeWhile isJust $ map (stripPrefix " ") as
$ takeWhile isJust fullDo = a : unindented
$ map (stripPrefix " ") as afterDo = drop (length unindented) as
fullDo = a:unindented in fullDo ++ clean afterDo
afterDo = drop (length unindented) as
in
--
fullDo ++ clean afterDo
-- Ignore other list elements - just proceed onwards. -- Ignore other list elements - just proceed onwards.
clean (x:xs) = x : clean xs clean (x:xs) = x : clean xs
......
-- | This module splits a shell command line into a list of strings, -- | This module splits a shell command line into a list of strings,
-- one for each command / filename -- one for each command / filename
module IHaskell.Eval.ParseShell (parseShell) where module IHaskell.Eval.ParseShell (parseShell) where
import Prelude hiding (words) import Prelude hiding (words)
import Text.ParserCombinators.Parsec hiding (manyTill) import Text.ParserCombinators.Parsec hiding (manyTill)
import Control.Applicative hiding ((<|>), many, optional) import Control.Applicative hiding ((<|>), many, optional)
eol :: Parser Char eol :: Parser Char
eol = oneOf "\n\r" <?> "end of line" eol = oneOf "\n\r" <?> "end of line"
quote :: Parser Char quote :: Parser Char
quote = char '\"' quote = char '\"'
-- | @manyTill p end@ from hidden @manyTill@ in that it appends the result of @end@ -- | @manyTill p end@ from hidden @manyTill@ in that it appends the result of @end@
...@@ -18,16 +17,17 @@ manyTill :: Parser a -> Parser [a] -> Parser [a] ...@@ -18,16 +17,17 @@ manyTill :: Parser a -> Parser [a] -> Parser [a]
manyTill p end = scan manyTill p end = scan
where where
scan = end <|> do scan = end <|> do
x <- p x <- p
xs <- scan xs <- scan
return $ x:xs return $ x : xs
manyTill1 p end = do x <- p manyTill1 p end = do
xs <- manyTill p end x <- p
return $ x : xs xs <- manyTill p end
return $ x : xs
unescapedChar :: Parser Char -> Parser String unescapedChar :: Parser Char -> Parser String
unescapedChar p = try $ do unescapedChar p = try $ do
x <- noneOf "\\" x <- noneOf "\\"
lookAhead p lookAhead p
return [x] return [x]
...@@ -36,8 +36,9 @@ quotedString = do ...@@ -36,8 +36,9 @@ quotedString = do
quote <?> "expected starting quote" quote <?> "expected starting quote"
(manyTill anyChar (unescapedChar quote) <* quote) <?> "unexpected in quoted String " (manyTill anyChar (unescapedChar quote) <* quote) <?> "unexpected in quoted String "
unquotedString = manyTill1 anyChar end unquotedString = manyTill1 anyChar end
where end = unescapedChar space where
end = unescapedChar space
<|> (lookAhead eol >> return []) <|> (lookAhead eol >> return [])
word = quotedString <|> unquotedString <?> "word" word = quotedString <|> unquotedString <?> "word"
...@@ -48,12 +49,12 @@ separator = many1 space <?> "separator" ...@@ -48,12 +49,12 @@ separator = many1 space <?> "separator"
-- | Input must terminate in a space character (like a \n) -- | Input must terminate in a space character (like a \n)
words :: Parser [String] words :: Parser [String]
words = try (eof *> return []) <|> do words = try (eof *> return []) <|> do
x <- word x <- word
rest1 <- lookAhead (many anyToken) rest1 <- lookAhead (many anyToken)
ss <- separator ss <- separator
rest2 <- lookAhead (many anyToken) rest2 <- lookAhead (many anyToken)
xs <- words xs <- words
return $ x : xs return $ x : xs
parseShell :: String -> Either ParseError [String] parseShell :: String -> Either ParseError [String]
parseShell string = parse words "shell" (string ++ "\n") parseShell string = parse words "shell" (string ++ "\n")
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
module IHaskell.Eval.Parser ( module IHaskell.Eval.Parser (
parseString, parseString,
CodeBlock(..), CodeBlock(..),
...@@ -14,56 +15,55 @@ module IHaskell.Eval.Parser ( ...@@ -14,56 +15,55 @@ module IHaskell.Eval.Parser (
PragmaType(..), PragmaType(..),
) where ) where
import ClassyPrelude hiding (head, liftIO, maximumBy) import ClassyPrelude hiding (head, liftIO, maximumBy)
import Data.List (maximumBy, inits) import Data.List (maximumBy, inits)
import Data.String.Utils (startswith, strip, split) import Data.String.Utils (startswith, strip, split)
import Prelude (head, tail) import Prelude (head, tail)
import Control.Monad (msum) import Control.Monad (msum)
import GHC hiding (Located) import GHC hiding (Located)
import Language.Haskell.GHC.Parser import Language.Haskell.GHC.Parser
import IHaskell.Eval.Util import IHaskell.Eval.Util
-- | A block of code to be evaluated. -- | A block of code to be evaluated. Each block contains a single element - one declaration,
-- Each block contains a single element - one declaration, statement, -- statement, expression, etc. If parsing of the block failed, the block is instead a ParseError,
-- expression, etc. If parsing of the block failed, the block is instead -- which has the error location and error message.
-- a ParseError, which has the error location and error message. data CodeBlock = Expression String -- ^ A Haskell expression.
data CodeBlock | Declaration String -- ^ A data type or function declaration.
= Expression String -- ^ A Haskell expression. | Statement String -- ^ A Haskell statement (as if in a `do` block).
| Declaration String -- ^ A data type or function declaration. | Import String -- ^ An import statement.
| Statement String -- ^ A Haskell statement (as if in a `do` block). | TypeSignature String -- ^ A lonely type signature (not above a function
| Import String -- ^ An import statement. -- declaration).
| TypeSignature String -- ^ A lonely type signature (not above a function declaration). | Directive DirectiveType String -- ^ An IHaskell directive.
| Directive DirectiveType String -- ^ An IHaskell directive. | Module String -- ^ A full Haskell module, to be compiled and loaded.
| Module String -- ^ A full Haskell module, to be compiled and loaded. | ParseError StringLoc ErrMsg -- ^ An error indicating that parsing the code block
| ParseError StringLoc ErrMsg -- ^ An error indicating that parsing the code block failed. -- failed.
| Pragma PragmaType [String] -- ^ A list of GHC pragmas (from a {-# LANGUAGE ... #-} block) | Pragma PragmaType [String] -- ^ A list of GHC pragmas (from a {-# LANGUAGE ... #-}
-- block)
deriving (Show, Eq) deriving (Show, Eq)
-- | Directive types. Each directive is associated with a string in the -- | Directive types. Each directive is associated with a string in the directive code block.
-- directive code block. data DirectiveType = GetType -- ^ Get the type of an expression via ':type' (or unique prefixes)
data DirectiveType | GetInfo -- ^ Get info about the identifier via ':info' (or unique prefixes)
= GetType -- ^ Get the type of an expression via ':type' (or unique prefixes) | SetDynFlag -- ^ Enable or disable an extensions, packages etc. via `:set`.
| GetInfo -- ^ Get info about the identifier via ':info' (or unique prefixes) -- Emulates GHCi's `:set`
| SetDynFlag -- ^ Enable or disable an extensions, packages etc. via `:set`. Emulates GHCi's `:set` | LoadFile -- ^ Load a Haskell module.
| LoadFile -- ^ Load a Haskell module. | SetOption -- ^ Set IHaskell kernel option `:option`.
| SetOption -- ^ Set IHaskell kernel option `:option`. | SetExtension -- ^ `:extension Foo` is a shortcut for `:set -XFoo`
| SetExtension -- ^ `:extension Foo` is a shortcut for `:set -XFoo` | ShellCmd -- ^ Execute a shell command.
| ShellCmd -- ^ Execute a shell command. | GetHelp -- ^ General help via ':?' or ':help'.
| GetHelp -- ^ General help via ':?' or ':help'. | SearchHoogle -- ^ Search for something via Hoogle.
| SearchHoogle -- ^ Search for something via Hoogle. | GetDoc -- ^ Get documentation for an identifier via Hoogle.
| GetDoc -- ^ Get documentation for an identifier via Hoogle. | GetKind -- ^ Get the kind of a type via ':kind'.
| GetKind -- ^ Get the kind of a type via ':kind'. | LoadModule -- ^ Load and unload modules via ':module'.
| LoadModule -- ^ Load and unload modules via ':module'.
deriving (Show, Eq) deriving (Show, Eq)
-- | Pragma types. Only LANGUAGE pragmas are currently supported. -- | Pragma types. Only LANGUAGE pragmas are currently supported. Other pragma types are kept around
-- Other pragma types are kept around as a string for error reporting. -- as a string for error reporting.
data PragmaType data PragmaType = PragmaLanguage
= PragmaLanguage | PragmaUnsupported String
| PragmaUnsupported String
deriving (Show, Eq) deriving (Show, Eq)
-- | Parse a string into code blocks. -- | Parse a string into code blocks.
...@@ -73,18 +73,18 @@ parseString codeString = do ...@@ -73,18 +73,18 @@ parseString codeString = do
flags <- getSessionDynFlags flags <- getSessionDynFlags
let output = runParser flags parserModule codeString let output = runParser flags parserModule codeString
case output of case output of
Parsed mod | Just _ <- hsmodName (unLoc mod) -> return [Located 1 $ Module codeString] Parsed mod
| Just _ <- hsmodName (unLoc mod) -> return [Located 1 $ Module codeString]
_ -> do _ -> do
-- Split input into chunks based on indentation. -- Split input into chunks based on indentation.
let chunks = layoutChunks $ removeComments codeString let chunks = layoutChunks $ removeComments codeString
result <- joinFunctions <$> processChunks [] chunks result <- joinFunctions <$> processChunks [] chunks
-- Return to previous flags. When parsing, flags can be set to make -- Return to previous flags. When parsing, flags can be set to make sure parsing works properly. But
-- sure parsing works properly. But we don't want those flags to be -- we don't want those flags to be set during evaluation until the right time.
-- set during evaluation until the right time.
_ <- setSessionDynFlags flags _ <- setSessionDynFlags flags
return result return result
otherwise -> error "parseString failed, output was neither Parsed nor Failure"
where where
parseChunk :: GhcMonad m => String -> LineNumber -> m (Located CodeBlock) parseChunk :: GhcMonad m => String -> LineNumber -> m (Located CodeBlock)
parseChunk chunk line = Located line <$> handleChunk chunk line parseChunk chunk line = Located line <$> handleChunk chunk line
...@@ -101,7 +101,7 @@ parseString codeString = do ...@@ -101,7 +101,7 @@ parseString codeString = do
[] -> return $ reverse accum [] -> return $ reverse accum
-- If we have more remaining, parse the current chunk and recurse. -- If we have more remaining, parse the current chunk and recurse.
Located line chunk:remaining -> do Located line chunk:remaining -> do
block <- parseChunk chunk line block <- parseChunk chunk line
activateExtensions $ unloc block activateExtensions $ unloc block
processChunks (block : accum) remaining processChunks (block : accum) remaining
...@@ -119,7 +119,7 @@ activateExtensions (Directive SetExtension ext) = void $ setExtension ext ...@@ -119,7 +119,7 @@ activateExtensions (Directive SetExtension ext) = void $ setExtension ext
activateExtensions (Directive SetDynFlag flags) = activateExtensions (Directive SetDynFlag flags) =
case stripPrefix "-X" flags of case stripPrefix "-X" flags of
Just ext -> void $ setExtension ext Just ext -> void $ setExtension ext
Nothing -> return () Nothing -> return ()
activateExtensions (Pragma PragmaLanguage extensions) = void $ setAll extensions activateExtensions (Pragma PragmaLanguage extensions) = void $ setAll extensions
where where
setAll :: GhcMonad m => [String] -> m (Maybe String) setAll :: GhcMonad m => [String] -> m (Maybe String)
...@@ -131,20 +131,21 @@ activateExtensions _ = return () ...@@ -131,20 +131,21 @@ activateExtensions _ = return ()
-- | Parse a single chunk of code, as indicated by the layout of the code. -- | Parse a single chunk of code, as indicated by the layout of the code.
parseCodeChunk :: GhcMonad m => String -> LineNumber -> m CodeBlock parseCodeChunk :: GhcMonad m => String -> LineNumber -> m CodeBlock
parseCodeChunk code startLine = do parseCodeChunk code startLine = do
flags <- getSessionDynFlags flags <- getSessionDynFlags
let let
-- Try each parser in turn. -- Try each parser in turn.
rawResults = map (tryParser code) (parsers flags) rawResults = map (tryParser code) (parsers flags)
-- Convert statements into expressions where we can -- Convert statements into expressions where we can
results = map (statementToExpression flags) rawResults in results = map (statementToExpression flags) rawResults
case successes results of case successes results of
-- If none of them succeeded, choose the best error message to -- If none of them succeeded, choose the best error message to display. Only one of the error
-- display. Only one of the error messages is actually relevant. -- messages is actually relevant.
[] -> return $ bestError $ failures results [] -> return $ bestError $ failures results
-- If one of the parsers succeeded -- If one of the parsers succeeded
result:_ -> return result result:_ -> return result
where where
successes :: [ParseOutput a] -> [a] successes :: [ParseOutput a] -> [a]
successes [] = [] successes [] = []
...@@ -164,47 +165,50 @@ parseCodeChunk code startLine = do ...@@ -164,47 +165,50 @@ parseCodeChunk code startLine = do
statementToExpression :: DynFlags -> ParseOutput CodeBlock -> ParseOutput CodeBlock statementToExpression :: DynFlags -> ParseOutput CodeBlock -> ParseOutput CodeBlock
statementToExpression flags (Parsed (Statement stmt)) = Parsed result statementToExpression flags (Parsed (Statement stmt)) = Parsed result
where result = if isExpr flags stmt where
then Expression stmt result = if isExpr flags stmt
else Statement stmt then Expression stmt
else Statement stmt
statementToExpression _ other = other statementToExpression _ other = other
-- Check whether a string is a valid expression. -- Check whether a string is a valid expression.
isExpr :: DynFlags -> String -> Bool isExpr :: DynFlags -> String -> Bool
isExpr flags str = case runParser flags parserExpression str of isExpr flags str =
Parsed {} -> True case runParser flags parserExpression str of
_ -> False Parsed{} -> True
_ -> False
tryParser :: String -> (String -> CodeBlock, String -> ParseOutput String) -> ParseOutput CodeBlock tryParser :: String -> (String -> CodeBlock, String -> ParseOutput String) -> ParseOutput CodeBlock
tryParser string (blockType, parser) = case parser string of tryParser string (blockType, parser) =
Parsed res -> Parsed (blockType res) case parser string of
Failure err loc -> Failure err loc Parsed res -> Parsed (blockType res)
otherwise -> error "tryParser failed, output was neither Parsed nor Failure" Failure err loc -> Failure err loc
otherwise -> error "tryParser failed, output was neither Parsed nor Failure"
parsers :: DynFlags -> [(String -> CodeBlock, String -> ParseOutput String)] parsers :: DynFlags -> [(String -> CodeBlock, String -> ParseOutput String)]
parsers flags = parsers flags =
[ (Import, unparser parserImport) [ (Import, unparser parserImport)
, (TypeSignature, unparser parserTypeSignature) , (TypeSignature, unparser parserTypeSignature)
, (Statement, unparser parserStatement) , (Statement, unparser parserStatement)
, (Declaration, unparser parserDeclaration) , (Declaration, unparser parserDeclaration)
] ]
where where
unparser :: Parser a -> String -> ParseOutput String unparser :: Parser a -> String -> ParseOutput String
unparser parser code = unparser parser code =
case runParser flags parser code of case runParser flags parser code of
Parsed out -> Parsed code Parsed out -> Parsed code
Partial out strs -> Partial code strs Partial out strs -> Partial code strs
Failure err loc -> Failure err loc Failure err loc -> Failure err loc
-- | Find consecutive declarations of the same function and join them into -- | Find consecutive declarations of the same function and join them into a single declaration.
-- a single declaration. These declarations may also include a type -- These declarations may also include a type signature, which is also joined with the subsequent
-- signature, which is also joined with the subsequent declarations. -- declarations.
joinFunctions :: [Located CodeBlock] -> [Located CodeBlock] joinFunctions :: [Located CodeBlock] -> [Located CodeBlock]
joinFunctions [] = [] joinFunctions [] = []
joinFunctions blocks = joinFunctions blocks =
if signatureOrDecl $ unloc $ head blocks if signatureOrDecl $ unloc $ head blocks
then Located lnum (conjoin $ map unloc decls) : joinFunctions rest then Located lnum (conjoin $ map unloc decls) : joinFunctions rest
else head blocks : joinFunctions (tail blocks) else head blocks : joinFunctions (tail blocks)
where where
decls = takeWhile (signatureOrDecl . unloc) blocks decls = takeWhile (signatureOrDecl . unloc) blocks
rest = drop (length decls) blocks rest = drop (length decls) blocks
...@@ -221,7 +225,6 @@ joinFunctions blocks = ...@@ -221,7 +225,6 @@ joinFunctions blocks =
conjoin :: [CodeBlock] -> CodeBlock conjoin :: [CodeBlock] -> CodeBlock
conjoin = Declaration . intercalate "\n" . map str conjoin = Declaration . intercalate "\n" . map str
-- | Parse a pragma of the form {-# LANGUAGE ... #-} -- | Parse a pragma of the form {-# LANGUAGE ... #-}
parsePragma :: String -- ^ Pragma string. parsePragma :: String -- ^ Pragma string.
-> Int -- ^ Line number at which the directive appears. -> Int -- ^ Line number at which the directive appears.
...@@ -229,10 +232,11 @@ parsePragma :: String -- ^ Pragma string. ...@@ -229,10 +232,11 @@ parsePragma :: String -- ^ Pragma string.
parsePragma ('{':'-':'#':pragma) line = parsePragma ('{':'-':'#':pragma) line =
let commaToSpace :: Char -> Char let commaToSpace :: Char -> Char
commaToSpace ',' = ' ' commaToSpace ',' = ' '
commaToSpace x = x commaToSpace x = x
pragmas = words $ takeWhile (/= '#') $ map commaToSpace pragma in pragmas = words $ takeWhile (/= '#') $ map commaToSpace pragma
case pragmas of in case pragmas of
[] -> Pragma (PragmaUnsupported "") [] --empty string pragmas are unsupported --empty string pragmas are unsupported
[] -> Pragma (PragmaUnsupported "") []
"LANGUAGE":xs -> Pragma PragmaLanguage xs "LANGUAGE":xs -> Pragma PragmaLanguage xs
x:xs -> Pragma (PragmaUnsupported x) xs x:xs -> Pragma (PragmaUnsupported x) xs
...@@ -240,48 +244,50 @@ parsePragma ('{':'-':'#':pragma) line = ...@@ -240,48 +244,50 @@ parsePragma ('{':'-':'#':pragma) line =
parseDirective :: String -- ^ Directive string. parseDirective :: String -- ^ Directive string.
-> Int -- ^ Line number at which the directive appears. -> Int -- ^ Line number at which the directive appears.
-> CodeBlock -- ^ Directive code block or a parse error. -> CodeBlock -- ^ Directive code block or a parse error.
parseDirective (':':'!':directive) line = Directive ShellCmd $ '!' : directive
parseDirective (':':'!':directive) line = Directive ShellCmd $ '!':directive parseDirective (':':directive) line =
parseDirective (':':directive) line = case find rightDirective directives of case find rightDirective directives of
Just (directiveType, _) -> Directive directiveType arg Just (directiveType, _) -> Directive directiveType arg
where arg = unwords restLine where arg = unwords restLine
_:restLine = words directive _:restLine = words directive
Nothing -> Nothing ->
let directiveStart = case words directive of let directiveStart =
[] -> "" case words directive of
first:_ -> first in [] -> ""
ParseError (Loc line 1) $ "Unknown directive: '" ++ directiveStart ++ "'." first:_ -> first
in ParseError (Loc line 1) $ "Unknown directive: '" ++ directiveStart ++ "'."
where where
rightDirective (_, dirname) = case words directive of rightDirective (_, dirname) =
[] -> False case words directive of
dir:_ -> dir `elem` tail (inits dirname) [] -> False
dir:_ -> dir `elem` tail (inits dirname)
directives = directives =
[ (LoadModule, "module") [ (LoadModule, "module")
, (GetType, "type") , (GetType, "type")
, (GetKind, "kind") , (GetKind, "kind")
, (GetInfo, "info") , (GetInfo, "info")
, (SearchHoogle, "hoogle") , (SearchHoogle, "hoogle")
, (GetDoc, "documentation") , (GetDoc, "documentation")
, (SetDynFlag, "set") , (SetDynFlag, "set")
, (LoadFile, "load") , (LoadFile, "load")
, (SetOption, "option") , (SetOption, "option")
, (SetExtension, "extension") , (SetExtension, "extension")
, (GetHelp, "?") , (GetHelp, "?")
, (GetHelp, "help") , (GetHelp, "help")
] ]
parseDirective _ _ = error "Directive must start with colon!" parseDirective _ _ = error "Directive must start with colon!"
-- | Parse a module and return the name declared in the 'module X where' -- | Parse a module and return the name declared in the 'module X where' line. That line is
-- line. That line is required, and if it does not exist, this will error. -- required, and if it does not exist, this will error. Names with periods in them are returned
-- Names with periods in them are returned piece y piece. -- piece y piece.
getModuleName :: GhcMonad m => String -> m [String] getModuleName :: GhcMonad m => String -> m [String]
getModuleName moduleSrc = do getModuleName moduleSrc = do
flags <- getSessionDynFlags flags <- getSessionDynFlags
let output = runParser flags parserModule moduleSrc let output = runParser flags parserModule moduleSrc
case output of case output of
Failure {} -> error "Module parsing failed." Failure{} -> error "Module parsing failed."
Parsed mod -> Parsed mod ->
case unLoc <$> hsmodName (unLoc mod) of case unLoc <$> hsmodName (unLoc mod) of
Nothing -> error "Module must have a name." Nothing -> error "Module must have a name."
Just name -> return $ split "." $ moduleNameString name Just name -> return $ split "." $ moduleNameString name
otherwise -> error "getModuleName failed, output was neither Parsed nor Failure" otherwise -> error "getModuleName failed, output was neither Parsed nor Failure"
{-# LANGUAGE CPP, NoImplicitPrelude #-} {-# LANGUAGE CPP, NoImplicitPrelude #-}
module IHaskell.Eval.Util ( module IHaskell.Eval.Util (
-- * Initialization -- * Initialization
initGhci, initGhci,
-- * Flags and extensions -- * Flags and extensions ** Set and unset flags.
-- ** Set and unset flags. extensionFlag,
extensionFlag, setExtension, setExtension,
ExtFlag(..), ExtFlag(..),
setFlags, setFlags,
-- * Code Evaluation -- * Code Evaluation
evalImport, evalImport,
removeImport, removeImport,
evalDeclarations, evalDeclarations,
getType, getType,
getDescription, getDescription,
-- * Pretty printing -- * Pretty printing
doc, doc,
pprDynFlags, pprDynFlags,
pprLanguages pprLanguages,
) where ) where
import ClassyPrelude hiding ((<>)) import ClassyPrelude hiding ((<>))
...@@ -50,20 +51,17 @@ import Data.String.Utils (replace) ...@@ -50,20 +51,17 @@ import Data.String.Utils (replace)
import Data.List (nubBy) import Data.List (nubBy)
-- | A extension flag that can be set or unset. -- | A extension flag that can be set or unset.
data ExtFlag data ExtFlag = SetFlag ExtensionFlag
= SetFlag ExtensionFlag | UnsetFlag ExtensionFlag
| UnsetFlag ExtensionFlag
-- | Find the extension that corresponds to a given flag. Create the -- | Find the extension that corresponds to a given flag. Create the corresponding 'ExtFlag' via
-- corresponding 'ExtFlag' via @SetFlag@ or @UnsetFlag@. -- @SetFlag@ or @UnsetFlag@. If no such extension exist, yield @Nothing@.
-- If no such extension exist, yield @Nothing@.
extensionFlag :: String -- Extension name, such as @"DataKinds"@ extensionFlag :: String -- Extension name, such as @"DataKinds"@
-> Maybe ExtFlag -> Maybe ExtFlag
extensionFlag ext = extensionFlag ext =
case find (flagMatches ext) xFlags of case find (flagMatches ext) xFlags of
Just fs -> Just $ SetFlag $ flagSpecFlag fs Just fs -> Just $ SetFlag $ flagSpecFlag fs
-- If it doesn't match an extension name, try matching against -- If it doesn't match an extension name, try matching against disabling an extension.
-- disabling an extension.
Nothing -> Nothing ->
case find (flagMatchesNo ext) xFlags of case find (flagMatchesNo ext) xFlags of
Just fs -> Just $ UnsetFlag $ flagSpecFlag fs Just fs -> Just $ UnsetFlag $ flagSpecFlag fs
...@@ -72,103 +70,95 @@ extensionFlag ext = ...@@ -72,103 +70,95 @@ extensionFlag ext =
-- Check if a FlagSpec matches an extension name. -- Check if a FlagSpec matches an extension name.
flagMatches ext fs = ext == flagSpecName fs flagMatches ext fs = ext == flagSpecName fs
-- Check if a FlagSpec matches "No<ExtensionName>". -- Check if a FlagSpec matches "No<ExtensionName>". In that case, we disable the extension.
-- In that case, we disable the extension.
flagMatchesNo ext fs = ext == "No" ++ flagSpecName fs flagMatchesNo ext fs = ext == "No" ++ flagSpecName fs
#if !MIN_VERSION_ghc(7,10,0) #if !MIN_VERSION_ghc(7,10,0)
flagSpecName (name,_,_) = name flagSpecName (name, _, _) = name
flagSpecFlag (_,flag,_) = flag
#endif
#if !MIN_VERSION_ghc(7,10,0) flagSpecFlag (_, flag, _) = flag
flagSpecName (name,_,_) = name
flagSpecFlag (_,flag,_) = flag
#endif #endif
-- | Pretty-print dynamic flags (taken from 'InteractiveUI' module of `ghc-bin`) -- | Pretty-print dynamic flags (taken from 'InteractiveUI' module of `ghc-bin`)
pprDynFlags :: Bool -- ^ Whether to include flags which are on by default pprDynFlags :: Bool -- ^ Whether to include flags which are on by default
-> DynFlags -> DynFlags
-> SDoc -> SDoc
pprDynFlags show_all dflags = pprDynFlags show_all dflags =
vcat [ vcat
[ text "GHCi-specific dynamic flag settings:" $$
nest 2 (vcat (map (setting opt) ghciFlags))
, text "other dynamic, non-language, flag settings:" $$
nest 2 (vcat (map (setting opt) others))
, text "warning settings:" $$
nest 2 (vcat (map (setting wopt) DynFlags.fWarningFlags))
]
where
#if MIN_VERSION_ghc(7,8,0) #if MIN_VERSION_ghc(7,8,0)
text "GHCi-specific dynamic flag settings:" $$ opt = gopt
nest 2 (vcat (map (setting gopt) ghciFlags)),
text "other dynamic, non-language, flag settings:" $$
nest 2 (vcat (map (setting gopt) others)),
text "warning settings:" $$
nest 2 (vcat (map (setting wopt) DynFlags.fWarningFlags))
#else #else
text "GHCi-specific dynamic flag settings:" $$ opt = dopt
nest 2 (vcat (map (setting dopt) ghciFlags)),
text "other dynamic, non-language, flag settings:" $$
nest 2 (vcat (map (setting dopt) others)),
text "warning settings:" $$
nest 2 (vcat (map (setting wopt) DynFlags.fWarningFlags))
#endif #endif
] setting test flag
where | quiet = empty
setting test flag | is_on = fstr name
| quiet = empty | otherwise = fnostr name
| is_on = fstr name where
| otherwise = fnostr name name = flagSpecName flag
where name = flagSpecName flag f = flagSpecFlag flag
f = flagSpecFlag flag is_on = test f dflags
is_on = test f dflags quiet = not show_all && test f default_dflags == is_on
quiet = not show_all && test f default_dflags == is_on
default_dflags = defaultDynFlags (settings dflags)
default_dflags = defaultDynFlags (settings dflags)
fstr str = text "-f" <> text str
fstr str = text "-f" <> text str
fnostr str = text "-fno-" <> text str fnostr str = text "-fno-" <> text str
(ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs) (ghciFlags, others) = partition (\f -> flagSpecFlag f `elem` flgs) DynFlags.fFlags
DynFlags.fFlags
flgs = [ flgs = concat [flgs1, flgs2, flgs3]
Opt_PrintExplicitForalls
flgs1 = [Opt_PrintExplicitForalls]
#if MIN_VERSION_ghc(7,8,0) #if MIN_VERSION_ghc(7,8,0)
, Opt_PrintExplicitKinds flgs2 = [Opt_PrintExplicitKinds]
#else
flgs2 = []
#endif #endif
, Opt_PrintBindResult flgs3 = [Opt_PrintBindResult, Opt_BreakOnException, Opt_BreakOnError, Opt_PrintEvldWithShow]
, Opt_BreakOnException
, Opt_BreakOnError
, Opt_PrintEvldWithShow
]
-- | Pretty-print the base language and active options (taken from `InteractiveUI` module of `ghc-bin`) -- | Pretty-print the base language and active options (taken from `InteractiveUI` module of
-- `ghc-bin`)
pprLanguages :: Bool -- ^ Whether to include flags which are on by default pprLanguages :: Bool -- ^ Whether to include flags which are on by default
-> DynFlags -> DynFlags
-> SDoc -> SDoc
pprLanguages show_all dflags = pprLanguages show_all dflags =
vcat vcat
[ text "base language is: " <> [text "base language is: " <>
case language dflags of case language dflags of
Nothing -> text "Haskell2010" Nothing -> text "Haskell2010"
Just Haskell98 -> text "Haskell98" Just Haskell98 -> text "Haskell98"
Just Haskell2010 -> text "Haskell2010" Just Haskell2010 -> text "Haskell2010", (if show_all
, (if show_all then text "all active language options:" then text "all active language options:"
else text "with the following modifiers:") $$ else text "with the following modifiers:") $$
nest 2 (vcat (map (setting xopt) DynFlags.xFlags)) nest 2 (vcat (map (setting xopt) DynFlags.xFlags))]
]
where where
setting test flag setting test flag
| quiet = empty | quiet = empty
| is_on = text "-X" <> text name | is_on = text "-X" <> text name
| otherwise = text "-XNo" <> text name | otherwise = text "-XNo" <> text name
where name = flagSpecName flag where
f = flagSpecFlag flag name = flagSpecName flag
is_on = test f dflags f = flagSpecFlag flag
quiet = not show_all && test f default_dflags == is_on is_on = test f dflags
quiet = not show_all && test f default_dflags == is_on
default_dflags =
defaultDynFlags (settings dflags) `lang_set` default_dflags =
case language dflags of defaultDynFlags (settings dflags) `lang_set`
Nothing -> Just Haskell2010 case language dflags of
other -> other Nothing -> Just Haskell2010
other -> other
-- | Set an extension and update flags.
-- Return @Nothing@ on success. On failure, return an error message. -- | Set an extension and update flags. Return @Nothing@ on success. On failure, return an error
-- message.
setExtension :: GhcMonad m => String -> m (Maybe String) setExtension :: GhcMonad m => String -> m (Maybe String)
setExtension ext = do setExtension ext = do
flags <- getSessionDynFlags flags <- getSessionDynFlags
...@@ -177,37 +167,35 @@ setExtension ext = do ...@@ -177,37 +167,35 @@ setExtension ext = do
Just flag -> do Just flag -> do
setSessionDynFlags $ setSessionDynFlags $
case flag of case flag of
SetFlag ghcFlag -> xopt_set flags ghcFlag SetFlag ghcFlag -> xopt_set flags ghcFlag
UnsetFlag ghcFlag -> xopt_unset flags ghcFlag UnsetFlag ghcFlag -> xopt_unset flags ghcFlag
return Nothing return Nothing
-- | Set a list of flags, as per GHCi's `:set`. -- | Set a list of flags, as per GHCi's `:set`. This was adapted from GHC's InteractiveUI.hs
-- This was adapted from GHC's InteractiveUI.hs (newDynFlags). -- (newDynFlags). It returns a list of error messages.
-- It returns a list of error messages.
setFlags :: GhcMonad m => [String] -> m [String] setFlags :: GhcMonad m => [String] -> m [String]
setFlags ext = do setFlags ext = do
-- Try to parse flags. -- Try to parse flags.
flags <- getSessionDynFlags flags <- getSessionDynFlags
(flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext) (flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext)
-- First, try to check if this flag matches any extension name. -- First, try to check if this flag matches any extension name.
let restorePkg x = x { packageFlags = packageFlags flags } let restorePkg x = x { packageFlags = packageFlags flags }
let restoredPkgs = flags' { packageFlags = packageFlags flags} let restoredPkgs = flags' { packageFlags = packageFlags flags }
GHC.setProgramDynFlags restoredPkgs GHC.setProgramDynFlags restoredPkgs
GHC.setInteractiveDynFlags restoredPkgs GHC.setInteractiveDynFlags restoredPkgs
-- Create the parse errors. -- Create the parse errors.
let noParseErrs = map (("Could not parse: " ++) . unLoc) unrecognized let noParseErrs = map (("Could not parse: " ++) . unLoc) unrecognized
allWarns = map unLoc warnings ++ allWarns = map unLoc warnings ++
["-package not supported yet" | packageFlags flags /= packageFlags flags'] ["-package not supported yet" | packageFlags flags /= packageFlags flags']
warnErrs = map ("Warning: " ++) allWarns warnErrs = map ("Warning: " ++) allWarns
return $ noParseErrs ++ warnErrs return $ noParseErrs ++ warnErrs
-- | Convert an 'SDoc' into a string. This is similar to the family of -- | Convert an 'SDoc' into a string. This is similar to the family of 'showSDoc' functions, but
-- 'showSDoc' functions, but does not impose an arbitrary width limit on -- does not impose an arbitrary width limit on the output (in terms of number of columns). Instead,
-- the output (in terms of number of columns). Instead, it respsects the -- it respsects the 'pprCols' field in the structure returned by 'getSessionDynFlags', and thus
-- 'pprCols' field in the structure returned by 'getSessionDynFlags', and -- gives a configurable width of output.
-- thus gives a configurable width of output.
doc :: GhcMonad m => SDoc -> m String doc :: GhcMonad m => SDoc -> m String
doc sdoc = do doc sdoc = do
flags <- getSessionDynFlags flags <- getSessionDynFlags
...@@ -216,15 +204,16 @@ doc sdoc = do ...@@ -216,15 +204,16 @@ doc sdoc = do
let cols = pprCols flags let cols = pprCols flags
d = runSDoc sdoc (initSDocContext flags style) d = runSDoc sdoc (initSDocContext flags style)
return $ Pretty.fullRender Pretty.PageMode cols 1.5 string_txt "" d return $ Pretty.fullRender Pretty.PageMode cols 1.5 string_txt "" d
where where
string_txt :: Pretty.TextDetails -> String -> String string_txt :: Pretty.TextDetails -> String -> String
string_txt (Pretty.Chr c) s = c:s string_txt (Pretty.Chr c) s = c : s
string_txt (Pretty.Str s1) s2 = s1 ++ s2 string_txt (Pretty.Str s1) s2 = s1 ++ s2
string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2 string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2
string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2 string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2
-- | Initialize the GHC API. Run this as the first thing in the `runGhc`. -- | Initialize the GHC API. Run this as the first thing in the `runGhc`. This initializes some dyn
-- This initializes some dyn flags (@ExtendedDefaultRules@, -- flags (@ExtendedDefaultRules@,
-- @NoMonomorphismRestriction@), sets the target to interpreted, link in -- @NoMonomorphismRestriction@), sets the target to interpreted, link in
-- memory, sets a reasonable output width, and potentially a few other -- memory, sets a reasonable output width, and potentially a few other
-- things. It should be invoked before other functions from this module. -- things. It should be invoked before other functions from this module.
...@@ -234,27 +223,28 @@ doc sdoc = do ...@@ -234,27 +223,28 @@ doc sdoc = do
-- (and only the first time) it is called. -- (and only the first time) it is called.
initGhci :: GhcMonad m => Maybe String -> m () initGhci :: GhcMonad m => Maybe String -> m ()
initGhci sandboxPackages = do initGhci sandboxPackages = do
-- Initialize dyn flags. -- Initialize dyn flags. Start with -XExtendedDefaultRules and -XNoMonomorphismRestriction.
-- Start with -XExtendedDefaultRules and -XNoMonomorphismRestriction.
originalFlags <- getSessionDynFlags originalFlags <- getSessionDynFlags
let flag = flip xopt_set let flag = flip xopt_set
unflag = flip xopt_unset unflag = flip xopt_unset
dflags = flag Opt_ExtendedDefaultRules . unflag Opt_MonomorphismRestriction $ originalFlags dflags = flag Opt_ExtendedDefaultRules . unflag Opt_MonomorphismRestriction $ originalFlags
pkgConfs = case sandboxPackages of pkgConfs =
Nothing -> extraPkgConfs originalFlags case sandboxPackages of
Just path -> Nothing -> extraPkgConfs originalFlags
let pkg = PkgConfFile path in Just path ->
(pkg:) . extraPkgConfs originalFlags let pkg = PkgConfFile path
in (pkg :) . extraPkgConfs originalFlags
void $ setSessionDynFlags $ dflags { hscTarget = HscInterpreted,
ghcLink = LinkInMemory, void $ setSessionDynFlags $ dflags
pprCols = 300, { hscTarget = HscInterpreted
extraPkgConfs = pkgConfs } , ghcLink = LinkInMemory
, pprCols = 300
-- | Evaluate a single import statement. , extraPkgConfs = pkgConfs
-- If this import statement is importing a module which was previously }
-- imported implicitly (such as `Prelude`) or if this module has a `hiding`
-- annotation, the previous import is removed. -- | Evaluate a single import statement. If this import statement is importing a module which was
-- previously imported implicitly (such as `Prelude`) or if this module has a `hiding` annotation,
-- the previous import is removed.
evalImport :: GhcMonad m => String -> m () evalImport :: GhcMonad m => String -> m ()
evalImport imports = do evalImport imports = do
importDecl <- parseImportDecl imports importDecl <- parseImportDecl imports
...@@ -265,8 +255,8 @@ evalImport imports = do ...@@ -265,8 +255,8 @@ evalImport imports = do
-- If this is a `hiding` import, remove previous non-`hiding` imports. -- If this is a `hiding` import, remove previous non-`hiding` imports.
oldImps = if isHiddenImport importDecl oldImps = if isHiddenImport importDecl
then filter (not . importOf importDecl) context then filter (not . importOf importDecl) context
else noImplicit else noImplicit
-- Replace the context. -- Replace the context.
setContext $ IIDecl importDecl : oldImps setContext $ IIDecl importDecl : oldImps
...@@ -285,9 +275,10 @@ evalImport imports = do ...@@ -285,9 +275,10 @@ evalImport imports = do
-- Check whether an import is hidden. -- Check whether an import is hidden.
isHiddenImport :: ImportDecl RdrName -> Bool isHiddenImport :: ImportDecl RdrName -> Bool
isHiddenImport imp = case ideclHiding imp of isHiddenImport imp =
Just (True, _) -> True case ideclHiding imp of
_ -> False Just (True, _) -> True
_ -> False
removeImport :: GhcMonad m => String -> m () removeImport :: GhcMonad m => String -> m ()
removeImport moduleName = do removeImport moduleName = do
...@@ -301,8 +292,7 @@ removeImport moduleName = do ...@@ -301,8 +292,7 @@ removeImport moduleName = do
isImportOf name (IIModule modName) = name == modName isImportOf name (IIModule modName) = name == modName
isImportOf name (IIDecl impDecl) = name == unLoc (ideclName impDecl) isImportOf name (IIDecl impDecl) = name == unLoc (ideclName impDecl)
-- | Evaluate a series of declarations. -- | Evaluate a series of declarations. Return all names which were bound by these declarations.
-- Return all names which were bound by these declarations.
evalDeclarations :: GhcMonad m => String -> m [String] evalDeclarations :: GhcMonad m => String -> m [String]
evalDeclarations decl = do evalDeclarations decl = do
names <- runDecls decl names <- runDecls decl
...@@ -321,16 +311,16 @@ cleanUpDuplicateInstances = modifySession $ \hscEnv -> ...@@ -321,16 +311,16 @@ cleanUpDuplicateInstances = modifySession $ \hscEnv ->
in hscEnv { hsc_IC = ic { ic_instances = (clsInsts', famInsts) } } in hscEnv { hsc_IC = ic { ic_instances = (clsInsts', famInsts) } }
where where
instEq :: ClsInst -> ClsInst -> Bool instEq :: ClsInst -> ClsInst -> Bool
instEq ClsInst{is_tvs = tpl_tvs,is_tys = tpl_tys, is_cls = cls} ClsInst{is_tys = tpl_tys', is_cls = cls'} =
#if MIN_VERSION_ghc(7,8,0) #if MIN_VERSION_ghc(7,8,0)
-- Only support replacing instances on GHC 7.8 and up -- Only support replacing instances on GHC 7.8 and up
let tpl_tv_set = mkVarSet tpl_tvs instEq c1 c2
in cls == cls' && isJust (tcMatchTys tpl_tv_set tpl_tys tpl_tys') | ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys, is_cls = cls } <- c1,
ClsInst { is_tys = tpl_tys', is_cls = cls' } <- c2
= let tpl_tv_set = mkVarSet tpl_tvs
in cls == cls' && isJust (tcMatchTys tpl_tv_set tpl_tys tpl_tys')
#else #else
False instEq _ _ = False
#endif #endif
-- | Get the type of an expression and convert it to a string. -- | Get the type of an expression and convert it to a string.
getType :: GhcMonad m => String -> m String getType :: GhcMonad m => String -> m String
getType expr = do getType expr = do
...@@ -342,21 +332,23 @@ getType expr = do ...@@ -342,21 +332,23 @@ getType expr = do
-- | A wrapper around @getInfo@. Return info about each name in the string. -- | A wrapper around @getInfo@. Return info about each name in the string.
getDescription :: GhcMonad m => String -> m [String] getDescription :: GhcMonad m => String -> m [String]
getDescription str = do getDescription str = do
names <- parseName str names <- parseName str
maybeInfos <- mapM getInfo' names maybeInfos <- mapM getInfo' names
-- Filter out types that have parents in the same set. -- Filter out types that have parents in the same set. GHCi also does this.
-- GHCi also does this.
let infos = catMaybes maybeInfos let infos = catMaybes maybeInfos
allNames = mkNameSet $ map (getName . getType) infos allNames = mkNameSet $ map (getName . getType) infos
hasParent info = case tyThingParent_maybe (getType info) of hasParent info =
Just parent -> getName parent `elemNameSet` allNames case tyThingParent_maybe (getType info) of
Nothing -> False Just parent -> getName parent `elemNameSet` allNames
Nothing -> False
filteredOutput = filter (not . hasParent) infos filteredOutput = filter (not . hasParent) infos
-- Print nicely -- Print nicely
mapM (doc . printInfo) filteredOutput mapM (doc . printInfo) filteredOutput
where where
#if MIN_VERSION_ghc(7,8,0) #if MIN_VERSION_ghc(7,8,0)
getInfo' = getInfo False getInfo' = getInfo False
#else #else
...@@ -371,15 +363,16 @@ getDescription str = do ...@@ -371,15 +363,16 @@ getDescription str = do
#if MIN_VERSION_ghc(7,8,0) #if MIN_VERSION_ghc(7,8,0)
printInfo (thing, fixity, classInstances, famInstances) = printInfo (thing, fixity, classInstances, famInstances) =
pprTyThingInContextLoc thing $$ pprTyThingInContextLoc thing $$
showFixity thing fixity $$ showFixity thing fixity $$
vcat (map GHC.pprInstance classInstances) $$ vcat (map GHC.pprInstance classInstances) $$
vcat (map GHC.pprFamInst famInstances) vcat (map GHC.pprFamInst famInstances)
#else #else
printInfo (thing, fixity, classInstances) = printInfo (thing, fixity, classInstances) =
pprTyThingInContextLoc False thing $$ showFixity thing fixity $$ vcat (map GHC.pprInstance classInstances) pprTyThingInContextLoc False thing $$ showFixity thing fixity $$
vcat (map GHC.pprInstance classInstances)
#endif #endif
showFixity thing fixity = showFixity thing fixity =
if fixity == GHC.defaultFixity if fixity == GHC.defaultFixity
then empty then empty
else ppr fixity <+> pprInfixName (getName thing) else ppr fixity <+> pprInfixName (getName thing)
{-# LANGUAGE NoImplicitPrelude, DeriveFunctor #-} {-# LANGUAGE NoImplicitPrelude, DeriveFunctor #-}
module IHaskell.Flags ( module IHaskell.Flags (
IHaskellMode(..), IHaskellMode(..),
Argument(..), Argument(..),
...@@ -16,8 +17,7 @@ import System.Console.CmdArgs.Text ...@@ -16,8 +17,7 @@ import System.Console.CmdArgs.Text
import Data.List (findIndex) import Data.List (findIndex)
import IHaskell.Types import IHaskell.Types
-- Command line arguments to IHaskell. A set of aruments is annotated with -- Command line arguments to IHaskell. A set of arguments is annotated with the mode being invoked.
-- the mode being invoked.
data Args = Args IHaskellMode [Argument] data Args = Args IHaskellMode [Argument]
deriving Show deriving Show
...@@ -33,30 +33,29 @@ data Argument = ConfFile String -- ^ A file with commands to load at startup ...@@ -33,30 +33,29 @@ data Argument = ConfFile String -- ^ A file with commands to load at startup
| ConvertLhsStyle (LhsStyle String) | ConvertLhsStyle (LhsStyle String)
deriving (Eq, Show) deriving (Eq, Show)
data LhsStyle string = LhsStyle { lhsCodePrefix :: string -- ^ @>@ data LhsStyle string =
, lhsOutputPrefix :: string -- ^ @<<@ LhsStyle
, lhsBeginCode :: string -- ^ @\\begin{code}@ { lhsCodePrefix :: string -- ^ @>@
, lhsEndCode :: string -- ^ @\\end{code}@ , lhsOutputPrefix :: string -- ^ @<<@
, lhsBeginOutput :: string -- ^ @\\begin{verbatim}@ , lhsBeginCode :: string -- ^ @\\begin{code}@
, lhsEndOutput :: string -- ^ @\\end{verbatim}@ , lhsEndCode :: string -- ^ @\\end{code}@
} , lhsBeginOutput :: string -- ^ @\\begin{verbatim}@
, lhsEndOutput :: string -- ^ @\\end{verbatim}@
}
deriving (Eq, Functor, Show) deriving (Eq, Functor, Show)
data NotebookFormat = LhsMarkdown data NotebookFormat = LhsMarkdown
| IpynbFile | IpynbFile
deriving (Eq, Show) deriving (Eq, Show)
-- Which mode IHaskell is being invoked in. -- Which mode IHaskell is being invoked in.
-- `None` means no mode was specified.
data IHaskellMode = ShowHelp String data IHaskellMode = ShowHelp String
| InstallKernelSpec | InstallKernelSpec
| ConvertLhs | ConvertLhs
| Kernel (Maybe String) | Kernel (Maybe String)
deriving (Eq, Show) deriving (Eq, Show)
-- | Given a list of command-line arguments, return the IHaskell mode and -- | Given a list of command-line arguments, return the IHaskell mode and arguments to process.
-- arguments to process.
parseFlags :: [String] -> Either String Args parseFlags :: [String] -> Either String Args
parseFlags flags = parseFlags flags =
let modeIndex = findIndex (`elem` modeFlags) flags let modeIndex = findIndex (`elem` modeFlags) flags
...@@ -111,7 +110,8 @@ installKernelSpec = ...@@ -111,7 +110,8 @@ installKernelSpec =
[ghcLibFlag, kernelDebugFlag, confFlag, helpFlag] [ghcLibFlag, kernelDebugFlag, confFlag, helpFlag]
kernel :: Mode Args kernel :: Mode Args
kernel = mode "kernel" (Args (Kernel Nothing) []) "Invoke the IHaskell kernel." kernelArg [ghcLibFlag, kernelDebugFlag, confFlag] kernel = mode "kernel" (Args (Kernel Nothing) []) "Invoke the IHaskell kernel." kernelArg
[ghcLibFlag, kernelDebugFlag, confFlag]
where where
kernelArg = flagArg update "<json-kernel-file>" kernelArg = flagArg update "<json-kernel-file>"
update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags
...@@ -154,16 +154,17 @@ convert = mode "convert" (Args ConvertLhs []) description unnamedArg convertFlag ...@@ -154,16 +154,17 @@ convert = mode "convert" (Args ConvertLhs []) description unnamedArg convertFlag
lhsStyleBird, lhsStyleTex :: LhsStyle String lhsStyleBird, lhsStyleTex :: LhsStyle String
lhsStyleBird = LhsStyle "> " "\n<< " "" "" "" "" lhsStyleBird = LhsStyle "> " "\n<< " "" "" "" ""
lhsStyleTex = LhsStyle "" "" "\\begin{code}" "\\end{code}" "\\begin{verbatim}" "\\end{verbatim}"
lhsStyleTex = LhsStyle "" "" "\\begin{code}" "\\end{code}" "\\begin{verbatim}" "\\end{verbatim}"
ihaskellArgs :: Mode Args ihaskellArgs :: Mode Args
ihaskellArgs = ihaskellArgs =
let descr = "Haskell for Interactive Computing." let descr = "Haskell for Interactive Computing."
helpStr = showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs helpStr = showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs
onlyHelp = [flagHelpSimple (add Help)] onlyHelp = [flagHelpSimple (add Help)]
noMode = mode "IHaskell" (Args (ShowHelp helpStr) []) descr noArgs onlyHelp in noMode = mode "IHaskell" (Args (ShowHelp helpStr) []) descr noArgs onlyHelp
noMode { modeGroupModes = toGroup allModes } in noMode { modeGroupModes = toGroup allModes }
where where
add flag (Args mode flags) = Args mode $ flag : flags add flag (Args mode flags) = Args mode $ flag : flags
noArgs = flagArg unexpected "" noArgs = flagArg unexpected ""
......
...@@ -40,17 +40,20 @@ import qualified GHC.Paths ...@@ -40,17 +40,20 @@ import qualified GHC.Paths
import IHaskell.Types import IHaskell.Types
import System.Posix.Signals import System.Posix.Signals
data KernelSpecOptions =
data KernelSpecOptions = KernelSpecOptions { kernelSpecGhcLibdir :: String -- ^ GHC libdir. KernelSpecOptions
, kernelSpecDebug :: Bool -- ^ Spew debugging output? { kernelSpecGhcLibdir :: String -- ^ GHC libdir.
, kernelSpecConfFile :: IO (Maybe String) -- ^ Filename of profile JSON file. , kernelSpecDebug :: Bool -- ^ Spew debugging output?
} , kernelSpecConfFile :: IO (Maybe String) -- ^ Filename of profile JSON file.
}
defaultKernelSpecOptions :: KernelSpecOptions defaultKernelSpecOptions :: KernelSpecOptions
defaultKernelSpecOptions = KernelSpecOptions { kernelSpecGhcLibdir = GHC.Paths.libdir defaultKernelSpecOptions = KernelSpecOptions
, kernelSpecDebug = False { kernelSpecGhcLibdir = GHC.Paths.libdir
, kernelSpecConfFile = defaultConfFile , kernelSpecDebug = False
} , kernelSpecConfFile = defaultConfFile
}
-- | The IPython kernel name. -- | The IPython kernel name.
kernelName :: IsString a => a kernelName :: IsString a => a
kernelName = "haskell" kernelName = "haskell"
...@@ -133,6 +136,7 @@ verifyIPythonVersion = do ...@@ -133,6 +136,7 @@ verifyIPythonVersion = do
Just (1:_) -> oldIPython Just (1:_) -> oldIPython
Just (0:_) -> oldIPython Just (0:_) -> oldIPython
_ -> badIPython "Detected IPython, but could not parse version number." _ -> badIPython "Detected IPython, but could not parse version number."
where where
badIPython :: Text -> Sh () badIPython :: Text -> Sh ()
badIPython message = liftIO $ do badIPython message = liftIO $ do
...@@ -140,8 +144,8 @@ verifyIPythonVersion = do ...@@ -140,8 +144,8 @@ verifyIPythonVersion = do
exitFailure exitFailure
oldIPython = badIPython "Detected old version of IPython. IHaskell requires 3.0.0 or up." oldIPython = badIPython "Detected old version of IPython. IHaskell requires 3.0.0 or up."
-- | Install an IHaskell kernelspec into the right location. -- | Install an IHaskell kernelspec into the right location. The right location is determined by
-- The right location is determined by using `ipython kernelspec install --user`. -- using `ipython kernelspec install --user`.
installKernelspec :: Bool -> KernelSpecOptions -> Sh () installKernelspec :: Bool -> KernelSpecOptions -> Sh ()
installKernelspec replace opts = void $ do installKernelspec replace opts = void $ do
ihaskellPath <- getIHaskellPath ihaskellPath <- getIHaskellPath
...@@ -155,13 +159,14 @@ installKernelspec replace opts = void $ do ...@@ -155,13 +159,14 @@ installKernelspec replace opts = void $ do
Just file -> ["--conf", file]) Just file -> ["--conf", file])
++ ["--ghclib", kernelSpecGhcLibdir opts] ++ ["--ghclib", kernelSpecGhcLibdir opts]
let kernelSpec = KernelSpec { kernelDisplayName = "Haskell" let kernelSpec = KernelSpec
, kernelLanguage = kernelName { kernelDisplayName = "Haskell"
, kernelCommand = [ihaskellPath, "kernel", "{connection_file}"] ++ kernelFlags , kernelLanguage = kernelName
} , kernelCommand = [ihaskellPath, "kernel", "{connection_file}"] ++ kernelFlags
}
-- Create a temporary directory. Use this temporary directory to make a kernelspec -- Create a temporary directory. Use this temporary directory to make a kernelspec directory; then,
-- directory; then, shell out to IPython to install this kernelspec directory. -- shell out to IPython to install this kernelspec directory.
withTmpDir $ \tmp -> do withTmpDir $ \tmp -> do
let kernelDir = tmp </> kernelName let kernelDir = tmp </> kernelName
let filename = kernelDir </> "kernel.json" let filename = kernelDir </> "kernel.json"
...@@ -180,21 +185,19 @@ installKernelspec replace opts = void $ do ...@@ -180,21 +185,19 @@ installKernelspec replace opts = void $ do
kernelSpecCreated :: Sh Bool kernelSpecCreated :: Sh Bool
kernelSpecCreated = do kernelSpecCreated = do
Just ipython <- which "ipython" Just ipython <- which "ipython"
out <- silently $ run ipython ["kernelspec", "list"] out <- silently $ run ipython ["kernelspec", "list"]
let kernelspecs = map T.strip $ lines out let kernelspecs = map T.strip $ lines out
return $ kernelName `elem` kernelspecs return $ kernelName `elem` kernelspecs
-- | Replace "~" with $HOME if $HOME is defined. -- | Replace "~" with $HOME if $HOME is defined. Otherwise, do nothing.
-- Otherwise, do nothing.
subHome :: String -> IO String subHome :: String -> IO String
subHome path = shelly $ do subHome path = shelly $ do
home <- unpack <$> fromMaybe "~" <$> get_env "HOME" home <- unpack <$> fromMaybe "~" <$> get_env "HOME"
return $ replace "~" home path return $ replace "~" home path
-- | Get the path to an executable. If it doensn't exist, fail with an error message complaining
-- | Get the path to an executable. If it doensn't exist, fail with an -- about it.
-- error message complaining about it.
path :: Text -> Sh FilePath path :: Text -> Sh FilePath
path exe = do path exe = do
path <- which $ fromText exe path <- which $ fromText exe
...@@ -229,9 +232,8 @@ getIHaskellPath = do ...@@ -229,9 +232,8 @@ getIHaskellPath = do
if FS.absolute f if FS.absolute f
then return $ FS.encodeString f then return $ FS.encodeString f
else else
-- Check whether this is a relative path, or just 'IHaskell' with $PATH -- Check whether this is a relative path, or just 'IHaskell' with $PATH resolution done by
-- resolution done by the shell. If it's just 'IHaskell', use the $PATH -- the shell. If it's just 'IHaskell', use the $PATH variable to find where IHaskell lives.
-- variable to find where IHaskell lives.
if FS.filename f == f if FS.filename f == f
then do then do
ihaskellPath <- which "ihaskell" ihaskellPath <- which "ihaskell"
......
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-} {-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric, ExistentialQuantification #-}
{-# LANGUAGE ExistentialQuantification #-}
-- | Description : All message type definitions. -- | Description : All message type definitions.
module IHaskell.Types ( module IHaskell.Types (
Message (..), Message(..),
MessageHeader (..), MessageHeader(..),
MessageType(..), MessageType(..),
Username, Username,
Metadata(..), Metadata(..),
replyType, replyType,
ExecutionState (..), ExecutionState(..),
StreamType(..), StreamType(..),
MimeType(..), MimeType(..),
DisplayData(..), DisplayData(..),
EvaluationResult(..), EvaluationResult(..),
ExecuteReplyStatus(..), ExecuteReplyStatus(..),
KernelState(..), KernelState(..),
LintStatus(..), LintStatus(..),
Width, Height, Width,
Display(..), Height,
defaultKernelState, Display(..),
extractPlain, defaultKernelState,
kernelOpts, extractPlain,
KernelOpt(..), kernelOpts,
IHaskellDisplay(..), KernelOpt(..),
IHaskellWidget(..), IHaskellDisplay(..),
Widget(..), IHaskellWidget(..),
CommInfo(..), Widget(..),
KernelSpec(..), CommInfo(..),
) where KernelSpec(..),
) where
import ClassyPrelude import ClassyPrelude
import qualified Data.ByteString.Char8 as Char import qualified Data.ByteString.Char8 as Char
...@@ -40,8 +41,8 @@ import IHaskell.IPython.Kernel ...@@ -40,8 +41,8 @@ import IHaskell.IPython.Kernel
-- | A class for displayable Haskell types. -- | A class for displayable Haskell types.
-- --
-- IHaskell's displaying of results behaves as if these two -- IHaskell's displaying of results behaves as if these two overlapping/undecidable instances also
-- overlapping/undecidable instances also existed: -- existed:
-- --
-- > instance (Show a) => IHaskellDisplay a -- > instance (Show a) => IHaskellDisplay a
-- > instance Show a where shows _ = id -- > instance Show a where shows _ = id
...@@ -50,12 +51,10 @@ class IHaskellDisplay a where ...@@ -50,12 +51,10 @@ class IHaskellDisplay a where
-- | Display as an interactive widget. -- | Display as an interactive widget.
class IHaskellDisplay a => IHaskellWidget a where class IHaskellDisplay a => IHaskellWidget a where
-- | Output target name for this widget. -- | Output target name for this widget. The actual input parameter should be ignored.
-- The actual input parameter should be ignored.
targetName :: a -> String targetName :: a -> String
-- | Called when the comm is opened. Allows additional messages to be sent -- | Called when the comm is opened. Allows additional messages to be sent after comm open.
-- after comm open.
open :: a -- ^ Widget to open a comm port with. open :: a -- ^ Widget to open a comm port with.
-> (Value -> IO ()) -- ^ Way to respond to the message. -> (Value -> IO ()) -- ^ Way to respond to the message.
-> IO () -> IO ()
...@@ -75,7 +74,7 @@ class IHaskellDisplay a => IHaskellWidget a where ...@@ -75,7 +74,7 @@ class IHaskellDisplay a => IHaskellWidget a where
close _ _ = return () close _ _ = return ()
data Widget = forall a. IHaskellWidget a => Widget a data Widget = forall a. IHaskellWidget a => Widget a
deriving Typeable deriving Typeable
instance IHaskellDisplay Widget where instance IHaskellDisplay Widget where
display (Widget widget) = display widget display (Widget widget) = display widget
...@@ -89,86 +88,92 @@ instance IHaskellWidget Widget where ...@@ -89,86 +88,92 @@ instance IHaskellWidget Widget where
instance Show Widget where instance Show Widget where
show _ = "<Widget>" show _ = "<Widget>"
-- | Wrapper for ipython-kernel's DisplayData which allows sending multiple results from the same
-- | Wrapper for ipython-kernel's DisplayData which allows sending multiple -- expression.
-- results from the same expression.
data Display = Display [DisplayData] data Display = Display [DisplayData]
| ManyDisplay [Display] | ManyDisplay [Display]
deriving (Show, Typeable, Generic) deriving (Show, Typeable, Generic)
instance Serialize Display instance Serialize Display
instance Monoid Display where instance Monoid Display where
mempty = Display [] mempty = Display []
ManyDisplay a `mappend` ManyDisplay b = ManyDisplay (a ++ b) ManyDisplay a `mappend` ManyDisplay b = ManyDisplay (a ++ b)
ManyDisplay a `mappend` b = ManyDisplay (a ++ [b]) ManyDisplay a `mappend` b = ManyDisplay (a ++ [b])
a `mappend` ManyDisplay b = ManyDisplay (a : b) a `mappend` ManyDisplay b = ManyDisplay (a : b)
a `mappend` b = ManyDisplay [a,b] a `mappend` b = ManyDisplay [a, b]
instance Semigroup Display where instance Semigroup Display where
a <> b = a `mappend` b a <> b = a `mappend` b
-- | All state stored in the kernel between executions. -- | All state stored in the kernel between executions.
data KernelState = KernelState { getExecutionCounter :: Int data KernelState =
, getLintStatus :: LintStatus -- Whether to use hlint, and what arguments to pass it. KernelState
, useSvg :: Bool { getExecutionCounter :: Int
, useShowErrors :: Bool , getLintStatus :: LintStatus -- Whether to use hlint, and what arguments to pass it.
, useShowTypes :: Bool , useSvg :: Bool
, usePager :: Bool , useShowErrors :: Bool
, openComms :: Map UUID Widget , useShowTypes :: Bool
, kernelDebug :: Bool , usePager :: Bool
} , openComms :: Map UUID Widget
, kernelDebug :: Bool
}
deriving Show deriving Show
defaultKernelState :: KernelState defaultKernelState :: KernelState
defaultKernelState = KernelState { getExecutionCounter = 1 defaultKernelState = KernelState
, getLintStatus = LintOn { getExecutionCounter = 1
, useSvg = True , getLintStatus = LintOn
, useShowErrors = False , useSvg = True
, useShowTypes = False , useShowErrors = False
, usePager = True , useShowTypes = False
, openComms = empty , usePager = True
, kernelDebug = False , openComms = empty
} , kernelDebug = False
}
-- | Kernel options to be set via `:set` and `:option`. -- | Kernel options to be set via `:set` and `:option`.
data KernelOpt = KernelOpt { data KernelOpt =
getOptionName :: [String], -- ^ Ways to set this option via `:option` KernelOpt
getSetName :: [String], -- ^ Ways to set this option via `:set` { getOptionName :: [String] -- ^ Ways to set this option via `:option`
getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel state. , getSetName :: [String] -- ^ Ways to set this option via `:set`
} , getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel
-- state.
}
kernelOpts :: [KernelOpt] kernelOpts :: [KernelOpt]
kernelOpts = kernelOpts =
[ KernelOpt ["lint"] [] $ \state -> state { getLintStatus = LintOn } [ KernelOpt ["lint"] [] $ \state -> state { getLintStatus = LintOn }
, KernelOpt ["no-lint"] [] $ \state -> state { getLintStatus = LintOff } , KernelOpt ["no-lint"] [] $ \state -> state { getLintStatus = LintOff }
, KernelOpt ["svg"] [] $ \state -> state { useSvg = True } , KernelOpt ["svg"] [] $ \state -> state { useSvg = True }
, KernelOpt ["no-svg"] [] $ \state -> state { useSvg = False } , KernelOpt ["no-svg"] [] $ \state -> state { useSvg = False }
, KernelOpt ["show-types"] ["+t"] $ \state -> state { useShowTypes = True } , KernelOpt ["show-types"] ["+t"] $ \state -> state { useShowTypes = True }
, KernelOpt ["no-show-types"] ["-t"] $ \state -> state { useShowTypes = False } , KernelOpt ["no-show-types"] ["-t"] $ \state -> state { useShowTypes = False }
, KernelOpt ["show-errors"] [] $ \state -> state { useShowErrors = True } , KernelOpt ["show-errors"] [] $ \state -> state { useShowErrors = True }
, KernelOpt ["no-show-errors"] [] $ \state -> state { useShowErrors = False } , KernelOpt ["no-show-errors"] [] $ \state -> state { useShowErrors = False }
, KernelOpt ["pager"] [] $ \state -> state { usePager = True } , KernelOpt ["pager"] [] $ \state -> state { usePager = True }
, KernelOpt ["no-pager"] [] $ \state -> state { usePager = False } , KernelOpt ["no-pager"] [] $ \state -> state { usePager = False }
] ]
-- | Current HLint status. -- | Current HLint status.
data LintStatus data LintStatus = LintOn
= LintOn | LintOff
| LintOff deriving (Eq, Show)
deriving (Eq, Show)
data CommInfo = CommInfo Widget UUID String deriving Show data CommInfo = CommInfo Widget UUID String
deriving Show
-- | Output of evaluation. -- | Output of evaluation.
data EvaluationResult = data EvaluationResult =
-- | An intermediate result which communicates what has been printed thus -- | An intermediate result which communicates what has been printed thus
-- far. -- far.
IntermediateResult { IntermediateResult
outputs :: Display -- ^ Display outputs. { outputs :: Display -- ^ Display outputs.
} }
| FinalResult { |
outputs :: Display, -- ^ Display outputs. FinalResult
pagerOut :: String, -- ^ Text to display in the IPython pager. { outputs :: Display -- ^ Display outputs.
startComms :: [CommInfo] -- ^ Comms to start. , pagerOut :: String -- ^ Text to display in the IPython pager.
} , startComms :: [CommInfo] -- ^ Comms to start.
}
deriving Show deriving Show
{-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables, QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables, QuasiQuotes #-}
-- | Description : Argument parsing and basic messaging loop, using Haskell -- | Description : Argument parsing and basic messaging loop, using Haskell
-- Chans to communicate with the ZeroMQ sockets. -- Chans to communicate with the ZeroMQ sockets.
module Main where module Main (main) where
-- Prelude imports. -- Prelude imports.
import ClassyPrelude hiding (last, liftIO, readChan, writeChan) import ClassyPrelude hiding (last, liftIO, readChan, writeChan)
...@@ -71,7 +72,7 @@ ihaskell (Args (Kernel (Just filename)) args) = do ...@@ -71,7 +72,7 @@ ihaskell (Args (Kernel (Just filename)) args) = do
showingHelp :: IHaskellMode -> [Argument] -> IO () -> IO () showingHelp :: IHaskellMode -> [Argument] -> IO () -> IO ()
showingHelp mode flags act = showingHelp mode flags act =
case find (==Help) flags of case find (== Help) flags of
Just _ -> Just _ ->
putStrLn $ pack $ help mode putStrLn $ pack $ help mode
Nothing -> Nothing ->
...@@ -114,13 +115,11 @@ runKernel kernelOpts profileSrc = do ...@@ -114,13 +115,11 @@ runKernel kernelOpts profileSrc = do
-- Receive and reply to all messages on the shell socket. -- Receive and reply to all messages on the shell socket.
interpret libdir True $ do interpret libdir True $ do
-- Ignore Ctrl-C the first time. This has to go inside the -- Ignore Ctrl-C the first time. This has to go inside the `interpret`, because GHC API resets the
-- `interpret`, because GHC API resets the signal handlers for some -- signal handlers for some reason (completely unknown to me).
-- reason (completely unknown to me).
liftIO ignoreCtrlC liftIO ignoreCtrlC
-- Initialize the context by evaluating everything we got from the -- Initialize the context by evaluating everything we got from the command line flags.
-- command line flags.
let noPublish _ = return () let noPublish _ = return ()
evaluator line = void $ do evaluator line = void $ do
-- Create a new state each time. -- Create a new state each time.
...@@ -131,7 +130,7 @@ runKernel kernelOpts profileSrc = do ...@@ -131,7 +130,7 @@ runKernel kernelOpts profileSrc = do
confFile <- liftIO $ kernelSpecConfFile kernelOpts confFile <- liftIO $ kernelSpecConfFile kernelOpts
case confFile of case confFile of
Just filename -> liftIO (readFile $ fpFromString filename) >>= evaluator Just filename -> liftIO (readFile $ fpFromString filename) >>= evaluator
Nothing -> return () Nothing -> return ()
forever $ do forever $ do
-- Read the request from the request channel. -- Read the request from the request channel.
...@@ -140,9 +139,8 @@ runKernel kernelOpts profileSrc = do ...@@ -140,9 +139,8 @@ runKernel kernelOpts profileSrc = do
-- Create a header for the reply. -- Create a header for the reply.
replyHeader <- createReplyHeader (header request) replyHeader <- createReplyHeader (header request)
-- We handle comm messages and normal ones separately. -- We handle comm messages and normal ones separately. The normal ones are a standard
-- The normal ones are a standard request/response style, while comms -- request/response style, while comms can be anything, and don't necessarily require a response.
-- can be anything, and don't necessarily require a response.
if isCommMessage request if isCommMessage request
then liftIO $ do then liftIO $ do
oldState <- takeMVar state oldState <- takeMVar state
...@@ -185,62 +183,59 @@ createReplyHeader parent = do ...@@ -185,62 +183,59 @@ createReplyHeader parent = do
let repType = fromMaybe err (replyType $ msgType parent) let repType = fromMaybe err (replyType $ msgType parent)
err = error $ "No reply for message " ++ show (msgType parent) err = error $ "No reply for message " ++ show (msgType parent)
return MessageHeader { return
identifiers = identifiers parent, MessageHeader
parentHeader = Just parent, { identifiers = identifiers parent
metadata = Map.fromList [], , parentHeader = Just parent
messageId = newMessageId, , metadata = Map.fromList []
sessionId = sessionId parent, , messageId = newMessageId
username = username parent, , sessionId = sessionId parent
msgType = repType , username = username parent
} , msgType = repType
}
-- | Compute a reply to a message. -- | Compute a reply to a message.
replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> Interpreter (KernelState, Message) replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> Interpreter (KernelState, Message)
-- Reply to kernel info requests with a kernel info reply. No computation needs to be done, as a
-- Reply to kernel info requests with a kernel info reply. No computation -- kernel info reply is a static object (all info is hard coded into the representation of that
-- needs to be done, as a kernel info reply is a static object (all info is -- message type).
-- hard coded into the representation of that message type).
replyTo _ KernelInfoRequest{} replyHeader state = replyTo _ KernelInfoRequest{} replyHeader state =
return (state, KernelInfoReply { return
header = replyHeader, (state, KernelInfoReply
language = "haskell", { header = replyHeader
versionList = ghcVersionInts , language = "haskell"
}) , versionList = ghcVersionInts
})
-- Reply to a shutdown request by exiting the main thread.
-- Before shutdown, reply to the request to let the frontend know shutdown -- Reply to a shutdown request by exiting the main thread. Before shutdown, reply to the request to
-- is happening. -- let the frontend know shutdown is happening.
replyTo interface ShutdownRequest{restartPending = restartPending} replyHeader _ = liftIO $ do replyTo interface ShutdownRequest { restartPending = restartPending } replyHeader _ = liftIO $ do
writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader restartPending writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader restartPending
exitSuccess exitSuccess
-- Reply to an execution request. The reply itself does not require -- Reply to an execution request. The reply itself does not require computation, but this causes
-- computation, but this causes messages to be sent to the IOPub socket -- messages to be sent to the IOPub socket with the output of the code in the execution request.
-- with the output of the code in the execution request. replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do -- Convenience function to send a message to the IOPub socket.
-- Convenience function to send a message to the IOPub socket.
let send msg = liftIO $ writeChan (iopubChannel interface) msg let send msg = liftIO $ writeChan (iopubChannel interface) msg
-- Log things so that we can use stdin. -- Log things so that we can use stdin.
dir <- liftIO getIHaskellDir dir <- liftIO getIHaskellDir
liftIO $ Stdin.recordParentHeader dir $ header req liftIO $ Stdin.recordParentHeader dir $ header req
-- Notify the frontend that the kernel is busy computing. -- Notify the frontend that the kernel is busy computing. All the headers are copies of the reply
-- All the headers are copies of the reply header with a different -- header with a different message type, because this preserves the session ID, parent header, and
-- message type, because this preserves the session ID, parent header, -- other important information.
-- and other important information.
busyHeader <- liftIO $ dupHeader replyHeader StatusMessage busyHeader <- liftIO $ dupHeader replyHeader StatusMessage
send $ PublishStatus busyHeader Busy send $ PublishStatus busyHeader Busy
-- Construct a function for publishing output as this is going. -- Construct a function for publishing output as this is going. This function accepts a boolean
-- This function accepts a boolean indicating whether this is the final -- indicating whether this is the final output and the thing to display. Store the final outputs in
-- output and the thing to display. Store the final outputs in a list so -- a list so that when we receive an updated non-final output, we can clear the entire output and
-- that when we receive an updated non-final output, we can clear the -- re-display with the updated output.
-- entire output and re-display with the updated output. displayed <- liftIO $ newMVar []
displayed <- liftIO $ newMVar []
updateNeeded <- liftIO $ newMVar False updateNeeded <- liftIO $ newMVar False
pagerOutput <- liftIO $ newMVar "" pagerOutput <- liftIO $ newMVar ""
let clearOutput = do let clearOutput = do
header <- dupHeader replyHeader ClearOutputMessage header <- dupHeader replyHeader ClearOutputMessage
send $ ClearOutput header True send $ ClearOutput header True
...@@ -254,7 +249,8 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do ...@@ -254,7 +249,8 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
convertSvgToHtml x = x convertSvgToHtml x = x
makeSvgImg base64data = unpack $ "<img src=\"data:image/svg+xml;base64," ++ base64data ++ "\"/>" makeSvgImg base64data = unpack $ "<img src=\"data:image/svg+xml;base64," ++ base64data ++ "\"/>"
prependCss (DisplayData MimeHtml html) = DisplayData MimeHtml $ concat ["<style>", pack ihaskellCSS, "</style>", html] prependCss (DisplayData MimeHtml html) =
DisplayData MimeHtml $concat ["<style>", pack ihaskellCSS, "</style>", html]
prependCss x = x prependCss x = x
startComm :: CommInfo -> IO () startComm :: CommInfo -> IO ()
...@@ -271,9 +267,10 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do ...@@ -271,9 +267,10 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
publish :: EvaluationResult -> IO () publish :: EvaluationResult -> IO ()
publish result = do publish result = do
let final = case result of let final =
IntermediateResult {} -> False case result of
FinalResult {} -> True IntermediateResult{} -> False
FinalResult{} -> True
outs = outputs result outs = outputs result
-- If necessary, clear all previous output and redraw. -- If necessary, clear all previous output and redraw.
...@@ -286,12 +283,11 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do ...@@ -286,12 +283,11 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
-- Draw this message. -- Draw this message.
sendOutput outs sendOutput outs
-- If this is the final message, add it to the list of completed -- If this is the final message, add it to the list of completed messages. If it isn't, make sure we
-- messages. If it isn't, make sure we clear it later by marking -- clear it later by marking update needed as true.
-- update needed as true.
modifyMVar_ updateNeeded (const $ return $ not final) modifyMVar_ updateNeeded (const $ return $ not final)
when final $ do when final $ do
modifyMVar_ displayed (return . (outs:)) modifyMVar_ displayed (return . (outs :))
-- Start all comms that need to be started. -- Start all comms that need to be started.
mapM_ startComm $ startComms result mapM_ startComm $ startComms result
...@@ -300,8 +296,8 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do ...@@ -300,8 +296,8 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
let pager = pagerOut result let pager = pagerOut result
unless (null pager) $ unless (null pager) $
if usePager state if usePager state
then modifyMVar_ pagerOutput (return . (++ pager ++ "\n")) then modifyMVar_ pagerOutput (return . (++ pager ++ "\n"))
else sendOutput $ Display [html pager] else sendOutput $ Display [html pager]
let execCount = getExecutionCounter state let execCount = getExecutionCounter state
-- Let all frontends know the execution count and code that's about to run -- Let all frontends know the execution count and code that's about to run
...@@ -317,14 +313,15 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do ...@@ -317,14 +313,15 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
-- Take pager output if we're using the pager. -- Take pager output if we're using the pager.
pager <- if usePager state pager <- if usePager state
then liftIO $ readMVar pagerOutput then liftIO $ readMVar pagerOutput
else return "" else return ""
return (updatedState, ExecuteReply { return
header = replyHeader, (updatedState, ExecuteReply
pagerOutput = pager, { header = replyHeader
executionCounter = execCount, , pagerOutput = pager
status = Ok , executionCounter = execCount
}) , status = Ok
})
replyTo _ req@CompleteRequest{} replyHeader state = do replyTo _ req@CompleteRequest{} replyHeader state = do
...@@ -334,28 +331,29 @@ replyTo _ req@CompleteRequest{} replyHeader state = do ...@@ -334,28 +331,29 @@ replyTo _ req@CompleteRequest{} replyHeader state = do
let start = pos - length matchedText let start = pos - length matchedText
end = pos end = pos
reply = CompleteReply replyHeader (map pack completions) start end Map.empty True reply = CompleteReply replyHeader (map pack completions) start end Map.empty True
return (state, reply) return (state, reply)
-- Reply to the object_info_request message. Given an object name, return -- Reply to the object_info_request message. Given an object name, return the associated type
-- the associated type calculated by GHC. -- calculated by GHC.
replyTo _ ObjectInfoRequest{objectName = oname} replyHeader state = do replyTo _ ObjectInfoRequest { objectName = oname } replyHeader state = do
docs <- pack <$> info (unpack oname) docs <- pack <$> info (unpack oname)
let reply = ObjectInfoReply { let reply = ObjectInfoReply
header = replyHeader, { header = replyHeader
objectName = oname, , objectName = oname
objectFound = strip docs /= "", , objectFound = strip docs /= ""
objectTypeString = docs, , objectTypeString = docs
objectDocString = docs , objectDocString = docs
} }
return (state, reply) return (state, reply)
-- TODO: Implement history_reply. -- TODO: Implement history_reply.
replyTo _ HistoryRequest{} replyHeader state = do replyTo _ HistoryRequest{} replyHeader state = do
let reply = HistoryReply { let reply = HistoryReply
header = replyHeader, { header = replyHeader
historyReply = [] -- FIXME -- FIXME
} , historyReply = []
}
return (state, reply) return (state, reply)
handleComm :: (Message -> IO ()) -> KernelState -> Message -> MessageHeader -> IO KernelState handleComm :: (Message -> IO ()) -> KernelState -> Message -> MessageHeader -> IO KernelState
......
#!/usr/bin/env python3
from __future__ import print_function
import sys
import os
import subprocess
def hindent(contents):
with open(".tmp3", "w") as f:
f.write(contents)
with open(".tmp3", "r") as f:
output = subprocess.check_output(["hindent", "--style", "gibiansky"],
stdin=f)
return output.decode('utf-8')
def diff(src1, src2):
# Ignore trailing newlines
if src1[-1] == "\n":
src1 = src1[:-1]
if src2[-1] == "\n":
src2 = src2[:-1]
with open(".tmp1", "w") as f1:
f1.write(src1)
with open(".tmp2", "w") as f2:
f2.write(src2)
try:
output = subprocess.check_output(["diff", ".tmp1", ".tmp2"])
return output.decode('utf-8')
except subprocess.CalledProcessError as e:
return e.output.decode('utf-8')
# Verify that we're in the right directory
try:
open("ihaskell.cabal", "r").close()
except:
print(sys.argv[0], "must be run from the ihaskell directory",
file=sys.stderr)
# Find all the source files
sources = []
for root, dirnames, filenames in os.walk("src"):
for filename in filenames:
if filename.endswith(".hs"):
sources.append(os.path.join(root, filename))
hindent_outputs = {}
for source_file in sources:
print("Formatting file", source_file)
with open(source_file, "r") as f:
original_source = f.read()
formatted_source = hindent(original_source)
hindent_outputs[source_file] = (original_source, formatted_source)
diffs = {filename: diff(original, formatted)
for (filename, (original, formatted)) in hindent_outputs.items()}
incorrect_formatting = False
for filename, diff in diffs.items():
if diff:
incorrect_formatting = True
print('Incorrect formatting in', filename)
print('=' * 10)
print(diff)
if incorrect_formatting:
sys.exit(1)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment