mirrors/IHaskell
1
0
Fork 0
mirror of https://github.com/IHaskell/IHaskell.git synced 2025-04-16 03:16:20 +00:00
Code Issues Packages Projects Releases Wiki Activity

Reformatting all of ihaskell source

Browse Source
This commit is contained in:
Andrew Gibiansky 2015-03-19 18:30:22 -07:00
parent e5e9203624
commit 2f06049777
20 changed files with 1598 additions and 1564 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -16,3 +16,5 @@ todo
profile/profile.tar
.cabal-sandbox
cabal.sandbox.config
.tmp1
.tmp2

36
src/IHaskell/BrokenPackages.hs
View File

@ -1,40 +1,38 @@
{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-}
module IHaskell.BrokenPackages (getBrokenPackages) where
import ClassyPrelude hiding ((<|>))
import ClassyPrelude hiding ((<|>))
import Text.Parsec
import Text.Parsec.String
import Control.Applicative hiding ((<|>), many)
import Text.Parsec
import Text.Parsec.String
import Control.Applicative hiding ((<|>), many)
import Data.String.Utils (startswith)
import Data.String.Utils (startswith)
import Shelly
import Shelly
data BrokenPackage = BrokenPackage {
packageID :: String,
brokenDeps :: [String]
}
data BrokenPackage = BrokenPackage { packageID :: String, brokenDeps :: [String] }
instance Show BrokenPackage where
show = packageID
-- | Get a list of broken packages.
-- This function internally shells out to `ghc-pkg`, and parses the output
-- in order to determine what packages are broken.
-- | Get a list of broken packages. This function internally shells out to `ghc-pkg`, and parses the
-- output in order to determine what packages are broken.
getBrokenPackages :: IO [String]
getBrokenPackages = shelly $ do
silently $ errExit False $ run "ghc-pkg" ["check"]
checkOut <- lastStderr
-- Get rid of extraneous things
let rightStart str = startswith "There are problems" str ||
startswith " dependency" str
let rightStart str = startswith "There are problems" str ||
startswith " dependency" str
ghcPkgOutput = unlines . filter rightStart . lines $ unpack checkOut
return $ case parse (many check) "ghc-pkg output" ghcPkgOutput of
Left err -> []
Right pkgs -> map show pkgs
return $
case parse (many check) "ghc-pkg output" ghcPkgOutput of
Left err -> []
Right pkgs -> map show pkgs
check :: Parser BrokenPackage
check = string "There are problems in package "

40
src/IHaskell/Convert.hs
View File

@ -1,27 +1,31 @@
-- | Description : mostly reversible conversion between ipynb and lhs
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 IHaskell.Convert.IpynbToLhs (ipynbToLhs)
import IHaskell.Convert.LhsToIpynb (lhsToIpynb)
import IHaskell.Flags (Argument)
import System.Directory (doesFileExist)
import Text.Printf (printf)
import Control.Monad.Identity (Identity(Identity), unless, when)
import IHaskell.Convert.Args (ConvertSpec(ConvertSpec, convertInput, convertLhsStyle, convertOutput, convertOverwriteFiles, convertToIpynb), fromJustConvertSpec, toConvertSpec)
import IHaskell.Convert.IpynbToLhs (ipynbToLhs)
import IHaskell.Convert.LhsToIpynb (lhsToIpynb)
import IHaskell.Flags (Argument)
import System.Directory (doesFileExist)
import Text.Printf (printf)
-- | used by @IHaskell convert@
convert :: [Argument] -> IO ()
convert args = case fromJustConvertSpec (toConvertSpec args) of
ConvertSpec { convertToIpynb = Identity toIpynb,
convertInput = Identity inputFile,
convertOutput = Identity outputFile,
convertLhsStyle = Identity lhsStyle,
convertOverwriteFiles = force }
convert args =
case fromJustConvertSpec (toConvertSpec args) of
ConvertSpec
{ convertToIpynb = Identity toIpynb
, convertInput = Identity inputFile
, convertOutput = Identity outputFile
, convertLhsStyle = Identity lhsStyle
, convertOverwriteFiles = force
}
| toIpynb -> do
unless force (failIfExists outputFile)
lhsToIpynb lhsStyle inputFile outputFile
unless force (failIfExists outputFile)
lhsToIpynb lhsStyle inputFile outputFile
| otherwise -> do
unless force (failIfExists outputFile)
ipynbToLhs lhsStyle inputFile outputFile
unless force (failIfExists outputFile)
ipynbToLhs lhsStyle inputFile outputFile
-- | Call fail when the named file already exists.
failIfExists :: FilePath -> IO ()
@ -29,5 +33,3 @@ failIfExists file = do
exists <- doesFileExist file
when exists $ fail $
printf "File %s already exists. To force supply --force." file

139
src/IHaskell/Convert/Args.hs
View File

@ -1,107 +1,102 @@
-- | Description: interpret flags parsed by "IHaskell.Flags"
module IHaskell.Convert.Args
(ConvertSpec(..),
fromJustConvertSpec,
toConvertSpec,
) where
module IHaskell.Convert.Args (ConvertSpec(..), fromJustConvertSpec, toConvertSpec) where
import Control.Applicative ((<$>))
import Control.Monad.Identity (Identity(Identity))
import Data.Char (toLower)
import Data.List (partition)
import Data.Maybe (fromMaybe)
import Control.Applicative ((<$>))
import Control.Monad.Identity (Identity(Identity))
import Data.Char (toLower)
import Data.List (partition)
import Data.Maybe (fromMaybe)
import qualified Data.Text.Lazy as T (pack, Text)
import IHaskell.Flags (Argument(..), LhsStyle, lhsStyleBird, NotebookFormat(..))
import System.FilePath ((<.>), dropExtension, takeExtension)
import Text.Printf (printf)
import IHaskell.Flags (Argument(..), LhsStyle, lhsStyleBird, NotebookFormat(..))
import System.FilePath ((<.>), dropExtension, takeExtension)
import Text.Printf (printf)
-- | ConvertSpec is the accumulator for command line arguments
data ConvertSpec f = ConvertSpec
{ convertToIpynb :: f Bool,
convertInput :: f FilePath,
convertOutput :: f FilePath,
convertLhsStyle :: f (LhsStyle T.Text),
convertOverwriteFiles :: Bool
}
data ConvertSpec f =
ConvertSpec
{ convertToIpynb :: f Bool
, convertInput :: f FilePath
, convertOutput :: f FilePath
, convertLhsStyle :: f (LhsStyle T.Text)
, convertOverwriteFiles :: Bool
}
-- | Convert a possibly-incomplete specification for what to convert
-- into one which can be executed. Calls error when data is missing.
fromJustConvertSpec :: ConvertSpec Maybe -> ConvertSpec Identity
fromJustConvertSpec convertSpec = convertSpec {
convertToIpynb = Identity toIpynb,
convertInput = Identity inputFile,
convertOutput = Identity outputFile,
convertLhsStyle = Identity $ fromMaybe
(T.pack <$> lhsStyleBird)
(convertLhsStyle convertSpec)
}
-- | Convert a possibly-incomplete specification for what to convert into one which can be executed.
-- Calls error when data is missing.
fromJustConvertSpec :: ConvertSpec Maybe -> ConvertSpec Identity
fromJustConvertSpec convertSpec = convertSpec
{ convertToIpynb = Identity toIpynb
, convertInput = Identity inputFile
, convertOutput = Identity outputFile
, convertLhsStyle = Identity $ fromMaybe (T.pack <$> lhsStyleBird) (convertLhsStyle convertSpec)
}
where
toIpynb = fromMaybe (error "Error: direction for conversion unknown")
(convertToIpynb convertSpec)
(inputFile, outputFile) = case (convertInput convertSpec, convertOutput convertSpec) of
(convertToIpynb convertSpec)
(inputFile, outputFile) =
case (convertInput convertSpec, convertOutput convertSpec) of
(Nothing, Nothing) -> error "Error: no files specified for conversion"
(Just i, Nothing) | toIpynb -> (i, dropExtension i <.> "ipynb")
| otherwise -> (i, dropExtension i <.> "lhs")
(Nothing, Just o) | toIpynb -> (dropExtension o <.> "lhs", o)
| otherwise -> (dropExtension o <.> "ipynb", o)
(Just i, Nothing)
| toIpynb -> (i, dropExtension i <.> "ipynb")
| otherwise -> (i, dropExtension i <.> "lhs")
(Nothing, Just o)
| toIpynb -> (dropExtension o <.> "lhs", o)
| otherwise -> (dropExtension o <.> "ipynb", o)
(Just i, Just o) -> (i, o)
-- | Does this @Argument@ explicitly request a file format?
isFormatSpec :: Argument -> Bool
isFormatSpec :: Argument -> Bool
isFormatSpec (ConvertToFormat _) = True
isFormatSpec (ConvertFromFormat _) = True
isFormatSpec _ = False
toConvertSpec :: [Argument] -> ConvertSpec Maybe
toConvertSpec args = mergeArgs otherArgs
(mergeArgs formatSpecArgs initialConvertSpec)
toConvertSpec args = mergeArgs otherArgs (mergeArgs formatSpecArgs initialConvertSpec)
where
(formatSpecArgs, otherArgs) = partition isFormatSpec args
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
mergeArg :: Argument -> ConvertSpec Maybe -> ConvertSpec Maybe
mergeArg :: Argument -> ConvertSpec Maybe -> ConvertSpec Maybe
mergeArg OverwriteFiles convertSpec = convertSpec { convertOverwriteFiles = True }
mergeArg (ConvertLhsStyle lhsStyle) convertSpec
| Just previousLhsStyle <- convertLhsStyle convertSpec,
previousLhsStyle /= fmap T.pack lhsStyle = error $ printf
"Conflicting lhs styles requested: <%s> and <%s>"
(show lhsStyle) (show previousLhsStyle)
previousLhsStyle /= fmap T.pack lhsStyle
= error $ printf "Conflicting lhs styles requested: <%s> and <%s>" (show lhsStyle)
(show previousLhsStyle)
| otherwise = convertSpec { convertLhsStyle = Just (T.pack <$> lhsStyle) }
mergeArg (ConvertFrom inputFile) convertSpec
| Just previousInputFile <- convertInput convertSpec,
previousInputFile /= inputFile = error $ printf "Multiple input files specified: <%s> and <%s>"
inputFile previousInputFile
| otherwise = convertSpec {
convertInput = Just inputFile,
convertToIpynb = case (convertToIpynb convertSpec, fromExt inputFile) of
(prev, Nothing) -> prev
(prev @ (Just _), _) -> prev
(Nothing, format) -> fmap (== LhsMarkdown) format
}
previousInputFile /= inputFile
= error $ printf "Multiple input files specified: <%s> and <%s>" inputFile previousInputFile
| otherwise = convertSpec
{ convertInput = Just inputFile
, convertToIpynb = case (convertToIpynb convertSpec, fromExt inputFile) of
(prev, Nothing) -> prev
(prev@(Just _), _) -> prev
(Nothing, format) -> fmap (== LhsMarkdown) format
}
mergeArg (ConvertTo outputFile) convertSpec
| Just previousOutputFile <- convertOutput convertSpec,
previousOutputFile /= outputFile = error $ printf "Multiple output files specified: <%s> and <%s>"
outputFile previousOutputFile
| otherwise = convertSpec {
convertOutput = Just outputFile,
convertToIpynb = case (convertToIpynb convertSpec, fromExt outputFile) of
(prev, Nothing) -> prev
(prev @ (Just _), _) -> prev
(Nothing, format) -> fmap (== IpynbFile) format
}
previousOutputFile /= outputFile
= error $ printf "Multiple output files specified: <%s> and <%s>" outputFile previousOutputFile
| otherwise = convertSpec
{ convertOutput = Just outputFile
, convertToIpynb = case (convertToIpynb convertSpec, fromExt outputFile) of
(prev, Nothing) -> prev
(prev@(Just _), _) -> prev
(Nothing, format) -> fmap (== IpynbFile) format
}
mergeArg unexpectedArg _ = error $ "IHaskell.Convert.mergeArg: impossible argument: "
++ show unexpectedArg
++ show unexpectedArg
-- | Guess the format based on the file extension.
fromExt :: FilePath -> Maybe NotebookFormat
fromExt s = case map toLower (takeExtension s) of
".lhs" -> Just LhsMarkdown
".ipynb" -> Just IpynbFile
_ -> Nothing
fromExt :: FilePath -> Maybe NotebookFormat
fromExt s =
case map toLower (takeExtension s) of
".lhs" -> Just LhsMarkdown
".ipynb" -> Just IpynbFile
_ -> Nothing

57
src/IHaskell/Convert/IpynbToLhs.hs
View File

@ -1,64 +1,67 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module IHaskell.Convert.IpynbToLhs (ipynbToLhs) where
import Control.Applicative ((<$>))
import Data.Aeson (decode, Object, Value(Array, Object, String))
import Control.Applicative ((<$>))
import Data.Aeson (decode, Object, Value(Array, Object, String))
import qualified Data.ByteString.Lazy as L (readFile)
import qualified Data.HashMap.Strict as M (lookup)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), Monoid(mempty))
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), Monoid(mempty))
import qualified Data.Text.Lazy as T (concat, fromStrict, Text, unlines)
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 IHaskell.Flags (LhsStyle(lhsBeginCode, lhsBeginOutput, lhsCodePrefix, lhsEndCode, lhsEndOutput, lhsOutputPrefix))
import IHaskell.Flags (LhsStyle(lhsBeginCode, lhsBeginOutput, lhsCodePrefix, lhsEndCode,
lhsEndOutput, lhsOutputPrefix))
ipynbToLhs :: LhsStyle T.Text
-> FilePath -- ^ the filename of an ipython notebook
-> FilePath -- ^ the filename of the literate haskell to write
-> IO ()
-> FilePath -- ^ the filename of an ipython notebook
-> FilePath -- ^ the filename of the literate haskell to write
-> IO ()
ipynbToLhs sty from to = do
Just (js :: Object) <- decode <$> L.readFile from
case M.lookup "cells" js of
Just (Array cells) ->
T.writeFile to $ T.unlines $ V.toList
$ V.map (\(Object y) -> convCell sty y) cells
T.writeFile to $ T.unlines $ V.toList $ V.map (\(Object y) -> convCell sty y) cells
_ -> error "IHaskell.Convert.ipynbTolhs: json does not follow expected schema"
concatWithPrefix :: T.Text -- ^ the prefix to add to every line
-> Vector Value -- ^ a json array of text lines
-> Maybe T.Text
-> Vector Value -- ^ a json array of text lines
-> Maybe T.Text
concatWithPrefix p arr = T.concat . map (p <>) . V.toList <$> V.mapM toStr arr
toStr :: Value -> Maybe T.Text
toStr (String x) = Just (T.fromStrict x)
toStr _ = Nothing
-- | @convCell sty cell@ converts a single cell in JSON into text suitable
-- for the type of lhs file described by the @sty@
-- | @convCell sty cell@ converts a single cell in JSON into text suitable for the type of lhs file
-- described by the @sty@
convCell :: LhsStyle T.Text -> Object -> T.Text
convCell _sty object
| Just (String "markdown") <- M.lookup "cell_type" object,
Just (Array xs) <- M.lookup "source" object,
~ (Just s) <- concatWithPrefix "" xs = s
Just (Array xs) <- M.lookup "source" object,
~(Just s) <- concatWithPrefix "" xs
= s
convCell sty object
| Just (String "code") <- M.lookup "cell_type" object,
Just (Array i) <- M.lookup "source" object,
Just (Array o) <- M.lookup "outputs" object,
~ (Just i) <- concatWithPrefix (lhsCodePrefix sty) i,
o <- fromMaybe mempty (convOutputs sty o) = "\n" <>
lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o <> "\n"
| Just (String "code") <- M.lookup "cell_type" object,
Just (Array i) <- M.lookup "source" object,
Just (Array o) <- M.lookup "outputs" object,
~(Just i) <- concatWithPrefix (lhsCodePrefix sty) i,
o <- fromMaybe mempty (convOutputs sty o)
= "\n" <>
lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o <> "\n"
convCell _ _ = "IHaskell.Convert.convCell: unknown cell"
convOutputs :: LhsStyle T.Text
-> Vector Value -- ^ JSON array of output lines containing text or markup
-> Maybe T.Text
convOutputs :: LhsStyle T.Text
-> Vector Value -- ^ JSON array of output lines containing text or markup
-> Maybe T.Text
convOutputs sty array = do
outputLines <- V.mapM (getTexts (lhsOutputPrefix sty)) array
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)
| Just (Array text) <- M.lookup "text" object = concatWithPrefix p text
getTexts _ _ = Nothing

131
src/IHaskell/Convert/LhsToIpynb.hs
View File

@ -1,119 +1,122 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module IHaskell.Convert.LhsToIpynb (lhsToIpynb) where
import Control.Applicative ((<$>))
import Control.Monad (mplus)
import Data.Aeson ((.=), encode, object, Value(Array, Bool, Number, String, Null))
import Control.Applicative ((<$>))
import Control.Monad (mplus)
import Data.Aeson ((.=), encode, object, Value(Array, Bool, Number, String, Null))
import qualified Data.ByteString.Lazy as L (writeFile)
import Data.Char (isSpace)
import Data.Monoid (Monoid(mempty))
import Data.Char (isSpace)
import Data.Monoid (Monoid(mempty))
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.IO as T (readFile)
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 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
data CellLine a = CodeLine a | OutputLine a | MarkdownLine a
deriving Show
data CellLine a = CodeLine a
| OutputLine a
| MarkdownLine a
deriving Show
isCode :: CellLine t -> Bool
isCode :: CellLine t -> Bool
isCode (CodeLine _) = True
isCode _ = False
isOutput :: CellLine t -> Bool
isOutput :: CellLine t -> Bool
isOutput (OutputLine _) = True
isOutput _ = False
isMD :: CellLine t -> Bool
isMD :: CellLine t -> Bool
isMD (MarkdownLine _) = True
isMD _ = False
isEmptyMD :: (Eq a, Monoid a) => CellLine a -> Bool
isEmptyMD :: (Eq a, Monoid a) => CellLine a -> Bool
isEmptyMD (MarkdownLine a) = a == mempty
isEmptyMD _ = False
untag :: CellLine t -> t
untag :: CellLine t -> t
untag (CodeLine a) = a
untag (OutputLine a) = a
untag (MarkdownLine a) = a
data Cell a = Code a a | Markdown a
deriving (Show)
data Cell a = Code a a
| Markdown a
deriving Show
encodeCells :: [Cell [T.Text]] -> Value
encodeCells xs = object $
[ "cells" .= Array (V.fromList (map cellToVal xs)) ]
++ boilerplate
["cells" .= Array (V.fromList (map cellToVal xs))]
++ boilerplate
cellToVal :: Cell [T.Text] -> Value
cellToVal (Code i o) = object $
[ "cell_type" .= String "code",
"execution_count" .= Null,
"metadata" .= object [ "collapsed" .= Bool False ],
"source" .= arrayFromTxt i,
"outputs" .= Array
(V.fromList (
[ object ["text" .= arrayFromTxt o,
"metadata" .= object [],
"output_type" .= String "display_data" ]
| _ <- take 1 o])) ]
[ "cell_type" .= String "code"
, "execution_count" .= Null
, "metadata" .= object ["collapsed" .= Bool False]
, "source" .= arrayFromTxt i
, "outputs" .= Array
(V.fromList
([object
[ "text" .= arrayFromTxt o
, "metadata" .= object []
, "output_type" .= String "display_data"
] | _ <- take 1 o]))
]
cellToVal (Markdown txt) = object $
[ "cell_type" .= String "markdown",
"metadata" .= object [ "hidden" .= Bool False ],
"source" .= arrayFromTxt txt ]
[ "cell_type" .= String "markdown"
, "metadata" .= object ["hidden" .= Bool False]
, "source" .= arrayFromTxt txt
]
-- | arrayFromTxt makes a JSON array of string s
arrayFromTxt :: [T.Text] -> Value
arrayFromTxt :: [T.Text] -> Value
arrayFromTxt i = Array (V.fromList $ map stringify i)
where
stringify = String . T.toStrict . flip T.snoc '\n'
where
stringify = String . T.toStrict . flip T.snoc '\n'
-- | ihaskell needs this boilerplate at the upper level to interpret the
-- json describing cells and output correctly.
-- | ihaskell needs this boilerplate at the upper level to interpret the json describing cells and
-- output correctly.
boilerplate :: [(TS.Text, Value)]
boilerplate =
[ "metadata" .= object [ kernelspec, lang ]
, "nbformat" .= Number 4
, "nbformat_minor" .= Number 0
]
["metadata" .= object [kernelspec, lang], "nbformat" .= Number 4, "nbformat_minor" .= Number 0]
where
kernelspec = "kernelspec" .= object [
"display_name" .= String "Haskell"
, "language" .= String "haskell"
, "name" .= String "haskell"
]
lang = "language_info" .= object [
"name" .= String "haskell"
, "version" .= String VERSION_ghc
]
kernelspec = "kernelspec" .= object
[ "display_name" .= String "Haskell"
, "language" .= String "haskell"
, "name" .= String "haskell"
]
lang = "language_info" .= object ["name" .= String "haskell", "version" .= String VERSION_ghc]
groupClassified :: [CellLine T.Text] -> [Cell [T.Text]]
groupClassified (CodeLine a : x)
| (c,x) <- span isCode x,
(_,x) <- span isEmptyMD x,
(o,x) <- span isOutput x = Code (a : map untag c) (map untag o) : groupClassified x
groupClassified (MarkdownLine a : x)
| (m,x) <- span isMD x = Markdown (a: map untag m) : groupClassified x
groupClassified (OutputLine a : x ) = Markdown [a] : groupClassified x
groupClassified (CodeLine a:x)
| (c, x) <- span isCode x,
(_, x) <- span isEmptyMD x,
(o, x) <- span isOutput x
= Code (a : map untag c) (map untag o) : groupClassified x
groupClassified (MarkdownLine a:x)
| (m, x) <- span isMD x = Markdown (a : map untag m) : groupClassified x
groupClassified (OutputLine a:x) = Markdown [a] : groupClassified x
groupClassified [] = []
classifyLines :: LhsStyle T.Text -> [T.Text] -> [CellLine T.Text]
classifyLines sty@(LhsStyle c o _ _ _ _) (l:ls) = case (sp c, sp o) of
(Just a, Nothing) -> CodeLine a : classifyLines sty ls
(Nothing, Just a) -> OutputLine a : classifyLines sty ls
(Nothing,Nothing) -> MarkdownLine l : classifyLines sty ls
_ -> error "IHaskell.Convert.classifyLines"
classifyLines sty@(LhsStyle c o _ _ _ _) (l:ls) =
case (sp c, sp o) of
(Just a, Nothing) -> CodeLine a : classifyLines sty ls
(Nothing, Just a) -> OutputLine a : classifyLines sty ls
(Nothing, Nothing) -> MarkdownLine l : classifyLines sty ls
_ -> error "IHaskell.Convert.classifyLines"
where
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
classifyLines _ [] = []

136
src/IHaskell/Display.hs
View File

@ -1,56 +1,66 @@
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleInstances #-}
-- | If you are interested in the IHaskell library for the purpose of
-- augmenting the IHaskell notebook or writing your own display mechanisms
-- and widgets, this module contains all functions you need.
-- | If you are interested in the IHaskell library for the purpose of augmenting the IHaskell
-- notebook or writing your own display mechanisms and widgets, this module contains all functions
-- you need.
--
-- In order to create a display mechanism for a particular data type, write
-- a module named (for example) @IHaskell.Display.YourThing@ in a package named @ihaskell-yourThing@.
-- (Note the capitalization - it's important!) Then, in that module, add an
-- instance of @IHaskellDisplay@ for your data type. Similarly, to create
-- a widget, add an instance of @IHaskellWidget@.
-- In order to create a display mechanism for a particular data type, write a module named (for
-- example) @IHaskell.Display.YourThing@ in a package named @ihaskell-yourThing@. (Note the
-- capitalization - it's important!) Then, in that module, add an instance of @IHaskellDisplay@ for
-- your data type. Similarly, to create 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 (
-- * Rich display and interactive display typeclasses and types
IHaskellDisplay(..),
Display(..),
DisplayData(..),
IHaskellWidget(..),
-- * Rich display and interactive display typeclasses and types
IHaskellDisplay(..),
Display(..),
DisplayData(..),
IHaskellWidget(..),
-- ** Interactive use functions
printDisplay,
-- ** Interactive use functions
printDisplay,
-- * Constructors for displays
plain, html, png, jpg, svg, latex, javascript, many,
-- * Constructors for displays
plain,
html,
png,
jpg,
svg,
latex,
javascript,
many,
-- ** Image and data encoding functions
Width, Height, Base64(..),
encode64, base64,
-- ** Image and data encoding functions
Width,
Height,
Base64(..),
encode64,
base64,
-- ** Utilities
switchToTmpDir,
-- ** Utilities
switchToTmpDir,
-- * Internal only use
displayFromChan,
serializeDisplay,
Widget(..),
) where
-- * 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 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.Char8 as Char
import Data.Aeson (Value)
import System.Directory(getTemporaryDirectory, setCurrentDirectory)
import Data.Aeson (Value)
import System.Directory (getTemporaryDirectory, setCurrentDirectory)
import Control.Concurrent.STM.TChan
import System.IO.Unsafe (unsafePerformIO)
import Control.Concurrent.STM.TChan
import System.IO.Unsafe (unsafePerformIO)
import IHaskell.Types
import IHaskell.Types
type Base64 = Text
@ -61,8 +71,7 @@ type Base64 = Text
-- > IO [Display]
-- > IO (IO Display)
--
-- be run the IO and get rendered (if the frontend allows it) in the pretty
-- form.
-- be run the IO and get rendered (if the frontend allows it) in the pretty form.
instance IHaskellDisplay a => IHaskellDisplay (IO a) where
display = (display =<<)
@ -77,6 +86,8 @@ instance IHaskellDisplay a => IHaskellDisplay [a] where
displays <- mapM display disps
return $ ManyDisplay displays
-- | Encode many displays into a single one. All will be output.
many :: [Display] -> Display
many = ManyDisplay
@ -101,15 +112,15 @@ latex = DisplayData MimeLatex . pack
javascript :: String -> DisplayData
javascript = DisplayData MimeJavascript . pack
-- | Generate a PNG display of the given width and height. Data must be
-- provided in a Base64 encoded manner, suitable for embedding into HTML.
-- The @base64@ function may be used to encode data into this format.
-- | Generate a PNG display of the given width and height. Data must be provided in a Base64 encoded
-- manner, suitable for embedding into HTML. The @base64@ function may be used to encode data into
-- this format.
png :: Width -> Height -> Base64 -> DisplayData
png width height = DisplayData (MimePng width height)
-- | Generate a JPG display of the given width and height. Data must be
-- provided in a Base64 encoded manner, suitable for embedding into HTML.
-- The @base64@ function may be used to encode data into this format.
-- | Generate a JPG display of the given width and height. Data must be provided in a Base64 encoded
-- manner, suitable for embedding into HTML. The @base64@ function may be used to encode data into
-- this format.
jpg :: Width -> Height -> Base64 -> DisplayData
jpg width height = DisplayData (MimeJpg width height)
@ -121,42 +132,37 @@ encode64 str = base64 $ Char.pack str
base64 :: ByteString -> Base64
base64 = decodeUtf8 . Base64.encode
-- | For internal use within IHaskell.
-- Serialize displays to a ByteString.
-- | For internal use within IHaskell. Serialize displays to a ByteString.
serializeDisplay :: Display -> ByteString
serializeDisplay = Serialize.encode
-- | Items written to this chan will be included in the output sent
-- to the frontend (ultimately the browser), the next time IHaskell
-- has an item to display.
-- | Items written to this chan will be included in the output sent to the frontend (ultimately the
-- browser), the next time IHaskell has an item to display.
{-# NOINLINE displayChan #-}
displayChan :: TChan Display
displayChan = unsafePerformIO newTChanIO
-- | Take everything that was put into the 'displayChan' at that point
-- out, and make a 'Display' out of it.
-- | Take everything that was put into the 'displayChan' at that point out, and make a 'Display' out
-- of it.
displayFromChan :: IO (Maybe Display)
displayFromChan =
Just . many <$> unfoldM (atomically $ tryReadTChan displayChan)
-- | This is unfoldM from monad-loops. It repeatedly runs an IO action
-- until it return Nothing, and puts all the Justs in a list.
-- If you find yourself using more functionality from monad-loops, just add
-- the package dependency instead of copying more code from it.
-- | This is unfoldM from monad-loops. It repeatedly runs an IO action until it return Nothing, and
-- puts all the Justs in a list. If you find yourself using more functionality from monad-loops,
-- just add the package dependency instead of copying more code from it.
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
-- notebook once the current execution call ends.
-- | Write to the display channel. The contents will be displayed in the notebook once the current
-- execution call ends.
printDisplay :: IHaskellDisplay a => a -> IO ()
printDisplay disp = display disp >>= atomically . writeTChan displayChan
-- | Convenience function for client libraries. Switch to a temporary
-- directory so that any files we create aren't visible. On Unix, this is
-- usually /tmp.
-- | Convenience function for client libraries. Switch to a temporary directory so that any files we
-- create aren't visible. On Unix, this is usually /tmp.
switchToTmpDir = void (try switchDir :: IO (Either SomeException ()))
where
where
switchDir =
getTemporaryDirectory >>=
getTemporaryDirectory >>=
setCurrentDirectory

362
src/IHaskell/Eval/Completion.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
{- |
Description: Generates tab completion options.
@ -12,64 +13,65 @@ This has a limited amount of context sensitivity. It distinguishes between four
-}
module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where
import ClassyPrelude hiding (init, last, head, liftIO)
--import Prelude
import ClassyPrelude hiding (init, last, head, liftIO)
import Control.Applicative ((<$>))
import Data.ByteString.UTF8 hiding (drop, take, lines, length)
import Data.Char
import Data.List (nub, init, last, head, elemIndex)
import Data.List.Split
import Data.List.Split.Internals
import Data.Maybe (fromJust)
import Data.String.Utils (strip, startswith, endswith, replace)
import Control.Applicative ((<$>))
import Data.ByteString.UTF8 hiding (drop, take, lines, length)
import Data.Char
import Data.List (nub, init, last, head, elemIndex)
import Data.List.Split
import Data.List.Split.Internals
import Data.Maybe (fromJust)
import Data.String.Utils (strip, startswith, endswith, replace)
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)
import GHC.PackageDb (ExposedModule(exposedName))
import GHC.PackageDb (ExposedModule(exposedName))
#endif
import DynFlags
import GhcMonad
import PackageConfig
import Outputable (showPpr)
import DynFlags
import GhcMonad
import PackageConfig
import Outputable (showPpr)
import System.Directory
import System.FilePath
import MonadUtils (MonadIO)
import System.Directory
import System.FilePath
import MonadUtils (MonadIO)
import System.Console.Haskeline.Completion
import System.Console.Haskeline.Completion
import IHaskell.Types
import IHaskell.Eval.Evaluate (Interpreter)
import IHaskell.Eval.ParseShell (parseShell)
data CompletionType
= Empty
| Identifier String
| DynFlag String
| Qualified String String
| ModuleName String String
| HsFilePath String String
| FilePath String String
| KernelOption String
| Extension String
deriving (Show, Eq)
import IHaskell.Types
import IHaskell.Eval.Evaluate (Interpreter)
import IHaskell.Eval.ParseShell (parseShell)
data CompletionType = Empty
| Identifier String
| DynFlag String
| Qualified String String
| ModuleName String String
| HsFilePath String String
| FilePath String String
| KernelOption String
| Extension String
deriving (Show, Eq)
#if MIN_VERSION_ghc(7,10,0)
extName (FlagSpec { flagSpecName = name }) = name
#else
extName (name, _, _) = name
exposedName = id
#endif
complete :: String -> Int -> Interpreter (String, [String])
complete code posOffset = do
-- 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
then (offset, first)
else findLine (offset - length first - 1) rest
then (offset, first)
else findLine (offset - length first - 1) rest
findLine _ [] = error $ "Could not find line: " ++ show (map length $ lines code, posOffset)
(pos, line) = findLine posOffset (lines code)
flags <- getSessionDynFlags
rdrNames <- map (showPpr flags) <$> getRdrNamesInScope
@ -78,10 +80,6 @@ complete code posOffset = do
unqualNames = nub $ filter (not . isQualified) rdrNames
qualNames = nub $ scopeNames ++ filter isQualified rdrNames
#if !MIN_VERSION_ghc(7,10,0)
let exposedName = id
#endif
let Just db = pkgDatabase flags
getNames = map (moduleNameString . exposedName) . exposedModules
moduleNames = nub $ concatMap getNames db
@ -89,69 +87,63 @@ complete code posOffset = do
let target = completionTarget line pos
completion = completionType line pos target
let matchedText = case completion of
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 <-
let matchedText =
case completion of
Empty -> return []
HsFilePath _ match -> match
FilePath _ match -> match
otherwise -> intercalate "." target
Identifier candidate ->
return $ filter (candidate `isPrefixOf`) unqualNames
options <- case completion of
Empty -> return []
Qualified moduleName candidate -> do
trueName <- getTrueModuleName moduleName
let prefix = intercalate "." [trueName, candidate]
completions = filter (prefix `isPrefixOf`) qualNames
falsifyName = replace trueName moduleName
return $ map falsifyName completions
Identifier candidate ->
return $ filter (candidate `isPrefixOf`) unqualNames
ModuleName previous candidate -> do
let prefix = if null previous
then candidate
else intercalate "." [previous, candidate]
return $ filter (prefix `isPrefixOf`) moduleNames
Qualified moduleName candidate -> do
trueName <- getTrueModuleName moduleName
let prefix = intercalate "." [trueName, candidate]
completions = filter (prefix `isPrefixOf`) qualNames
falsifyName = replace trueName moduleName
return $ map falsifyName completions
DynFlag ext -> do
-- Possibly leave out the fLangFlags? The
-- -XUndecidableInstances vs. obsolete
-- -fallow-undecidable-instances.
let kernelOptNames = concatMap getSetName kernelOpts
otherNames = ["-package","-Wall","-w"]
ModuleName previous candidate -> do
let prefix = if null previous
then candidate
else intercalate "." [previous, candidate]
return $ filter (prefix `isPrefixOf`) moduleNames
fNames = map extName fFlags ++
map extName fWarningFlags ++
map extName fLangFlags
fNoNames = map ("no"++) fNames
fAllNames = map ("-f"++) (fNames ++ fNoNames)
DynFlag ext -> do
-- Possibly leave out the fLangFlags? The -XUndecidableInstances vs. obsolete
-- -fallow-undecidable-instances.
let kernelOptNames = concatMap getSetName kernelOpts
otherNames = ["-package", "-Wall", "-w"]
xNames = map extName xFlags
xNoNames = map ("No" ++) xNames
xAllNames = map ("-X"++) (xNames ++ xNoNames)
fNames = map extName fFlags ++
map extName fWarningFlags ++
map extName fLangFlags
fNoNames = map ("no" ++) fNames
fAllNames = map ("-f" ++) (fNames ++ fNoNames)
allNames = xAllNames ++ otherNames ++ fAllNames
xNames = map extName xFlags
xNoNames = map ("No" ++) xNames
xAllNames = map ("-X" ++) (xNames ++ xNoNames)
return $ filter (ext `isPrefixOf`) allNames
allNames = xAllNames ++ otherNames ++ fAllNames
Extension ext -> do
let xNames = map extName xFlags
xNoNames = map ("No" ++) xNames
return $ filter (ext `isPrefixOf`) $ xNames ++ xNoNames
return $ filter (ext `isPrefixOf`) allNames
HsFilePath lineUpToCursor match -> completePathWithExtensions [".hs", ".lhs"] lineUpToCursor
Extension ext -> do
let xNames = map extName xFlags
xNoNames = map ("No" ++) xNames
return $ filter (ext `isPrefixOf`) $ xNames ++ xNoNames
FilePath lineUpToCursor match -> completePath lineUpToCursor
HsFilePath lineUpToCursor match -> completePathWithExtensions [".hs", ".lhs"]
lineUpToCursor
KernelOption str -> return $
filter (str `isPrefixOf`) (concatMap getOptionName kernelOpts)
FilePath lineUpToCursor match -> completePath lineUpToCursor
KernelOption str -> return $
filter (str `isPrefixOf`) (concatMap getOptionName kernelOpts)
return (matchedText, options)
@ -164,116 +156,117 @@ getTrueModuleName name = do
-- Get all imports that we use.
imports <- ClassyPrelude.catMaybes <$> map onlyImportDecl <$> getContext
-- Find the ones that have a qualified name attached.
-- If this name isn't one of them, it already is the true name.
-- Find the ones that have a qualified name attached. If this name isn't one of them, it already is
-- the true name.
flags <- getSessionDynFlags
let qualifiedImports = filter (isJust . ideclAs) imports
hasName imp = name == (showPpr flags . fromJust . ideclAs) imp
case find hasName qualifiedImports of
Nothing -> return name
Nothing -> return name
Just trueImp -> return $ showPpr flags $ unLoc $ ideclName trueImp
-- | Get which type of completion this is from the surrounding context.
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).
-> CompletionType
completionType line loc target
-- File and directory completions are special
| startswith ":!" stripped
= fileComplete FilePath
| startswith ":l" stripped
= fileComplete HsFilePath
| startswith ":!" stripped =
fileComplete FilePath
| startswith ":l" stripped =
fileComplete HsFilePath
-- Complete :set, :opt, and :ext
| startswith ":s" stripped
= DynFlag candidate
| startswith ":o" stripped
= KernelOption candidate
| startswith ":e" stripped
= Extension candidate
| startswith ":s" stripped =
DynFlag candidate
| startswith ":o" stripped =
KernelOption candidate
| startswith ":e" stripped =
Extension candidate
-- Use target for other completions.
-- If it's empty, no completion.
| null target
= Empty
-- Use target for other completions. If it's empty, no completion.
| null target =
Empty
-- When in a string, complete filenames.
| cursorInString line loc
= FilePath (getStringTarget lineUpToCursor) (getStringTarget lineUpToCursor)
| cursorInString line loc =
FilePath (getStringTarget lineUpToCursor) (getStringTarget lineUpToCursor)
-- Complete module names in imports and elsewhere.
| startswith "import" stripped && isModName
= ModuleName dotted candidate
| isModName && (not . null . init) target
= Qualified dotted candidate
| startswith "import" stripped && isModName =
ModuleName dotted candidate
| isModName && (not . null . init) target =
Qualified dotted candidate
-- Default to completing identifiers.
| otherwise
= Identifier candidate
where stripped = strip line
dotted = dots target
candidate | null target = ""
| otherwise = last target
dots = intercalate "." . init
isModName = all isCapitalized (init target)
| otherwise =
Identifier candidate
where
stripped = strip line
dotted = dots target
candidate
| null target = ""
| otherwise = last target
dots = intercalate "." . init
isModName = all isCapitalized (init target)
isCapitalized [] = False
isCapitalized (x:_) = isUpper x
isCapitalized [] = False
isCapitalized (x:_) = isUpper x
lineUpToCursor = take loc line
fileComplete filePath = case parseShell lineUpToCursor of
Right xs -> filePath lineUpToCursor $
if endswith (last xs) lineUpToCursor
then last xs
else []
Left _ -> Empty
lineUpToCursor = take loc line
fileComplete filePath =
case parseShell lineUpToCursor of
Right xs -> filePath lineUpToCursor $
if endswith (last xs) lineUpToCursor
then last xs
else []
Left _ -> Empty
cursorInString str loc = nquotes (take loc str) `mod` 2 /= 0
cursorInString str loc = nquotes (take loc str) `mod` 2 /= 0
nquotes ('\\':'"':xs) = nquotes xs
nquotes ('"':xs) = 1 + nquotes xs
nquotes (_:xs) = nquotes xs
nquotes [] = 0
nquotes ('\\':'"':xs) = nquotes xs
nquotes ('"':xs) = 1 + nquotes xs
nquotes (_:xs) = nquotes xs
nquotes [] = 0
-- Get the bit of a string that might be a filename completion.
-- Logic is a bit convoluted, but basically go backwards from the
-- end, stopping at any quote or space, unless they are escaped.
getStringTarget :: String -> String
getStringTarget = go "" . reverse
where
go acc rest = case rest of
'"':'\\':rem -> go ('"':acc) rem
'"':rem -> acc
' ':'\\':rem -> go (' ':acc) rem
' ':rem -> acc
x:rem -> go (x:acc) rem
[] -> acc
-- Get the bit of a string that might be a filename completion. Logic is a bit convoluted, but
-- basically go backwards from the end, stopping at any quote or space, unless they are escaped.
getStringTarget :: String -> String
getStringTarget = go "" . reverse
where
go acc rest =
case rest of
'"':'\\':rem -> go ('"' : acc) rem
'"':rem -> acc
' ':'\\':rem -> go (' ' : acc) rem
' ':rem -> acc
x:rem -> go (x : acc) rem
[] -> acc
-- | Get the word under a given cursor location.
completionTarget :: String -> Int -> [String]
completionTarget code cursor = expandCompletionPiece pieceToComplete
where
pieceToComplete = map fst <$> find (elem cursor . map snd) pieces
pieces = splitAlongCursor $ split splitter $ zip code [1 .. ]
splitter = defaultSplitter {
-- Split using only the characters, which are the first elements of
-- the (char, index) tuple
delimiter = Delimiter [uncurry isDelim],
-- Condense multiple delimiters into one and then drop them.
condensePolicy = Condense,
delimPolicy = Drop
}
pieces = splitAlongCursor $ split splitter $ zip code [1 ..]
splitter = defaultSplitter {
-- Split using only the characters, which are the first elements of
-- the (char, index) tuple
delimiter = Delimiter [uncurry isDelim],
-- Condense multiple delimiters into one and then drop
-- them.
condensePolicy = Condense, delimPolicy = Drop }
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 [] = []
splitAlongCursor (x:xs) =
case elemIndex cursor $ map snd x of
Nothing -> x:splitAlongCursor xs
Just idx -> take (idx + 1) x:drop (idx + 1) x:splitAlongCursor xs
case elemIndex cursor $ map snd x of
Nothing -> x : splitAlongCursor xs
Just idx -> take (idx + 1) x : drop (idx + 1) x : splitAlongCursor xs
-- These are never part of an identifier.
neverIdent :: String
@ -284,10 +277,11 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete
getHome :: IO String
getHome = do
homeEither <- try $ getEnv "HOME" :: IO (Either SomeException String)
return $ case homeEither of
Left _ -> "~"
Right home -> home
homeEither <- try $ getEnv "HOME" :: IO (Either SomeException String)
return $
case homeEither of
Left _ -> "~"
Right home -> home
dirExpand :: String -> IO String
dirExpand str = do
@ -301,7 +295,8 @@ unDirExpand str = do
completePath :: String -> Interpreter [String]
completePath line = completePathFilter acceptAll acceptAll line ""
where acceptAll = const True
where
acceptAll = const True
completePathWithExtensions :: [String] -> String -> Interpreter [String]
completePathWithExtensions extensions line =
@ -309,7 +304,8 @@ completePathWithExtensions extensions line =
where
acceptAll = const True
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.
-> (String -> Bool) -- ^ Directory filter: test whether to include this directory.
@ -321,21 +317,19 @@ completePathFilter includeFile includeDirectory left right = liftIO $ do
expanded <- dirExpand left
completions <- map replacement <$> snd <$> completeFilename (reverse expanded, right)
-- Split up into files and directories.
-- Filter out ones we don't want.
-- Split up into files and directories. Filter out ones we don't want.
areDirs <- mapM doesDirectoryExist completions
let dirs = filter includeDirectory $ map fst $ filter snd $ zip completions areDirs
files = filter includeFile $ map fst $ filter (not . 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
-- Return directories before files. However, stick everything that starts
-- with a dot after everything else. If we wanted to keep original
-- order, we could instead use
-- Return directories before files. However, stick everything that starts with a dot after
-- everything else. If we wanted to keep original order, we could instead use
-- filter (`elem` (dirs ++ files)) completions
suggestions <- mapM unDirExpand $ dirs ++ files
let isHidden str = startswith "." . last . StringUtils.split "/" $
if endswith "/" str
then init str
else str
then init str
else str
visible = filter (not . isHidden) suggestions
hidden = filter isHidden suggestions
hidden = filter isHidden suggestions
return $ visible ++ hidden

809
src/IHaskell/Eval/Evaluate.hs
View File

File diff suppressed because it is too large Load Diff

223
src/IHaskell/Eval/Hoogle.hs
View File

@ -1,43 +1,38 @@
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances, OverloadedStrings #-}
module IHaskell.Eval.Hoogle (
search,
document,
render,
OutputFormat(..),
HoogleResult
) where
import ClassyPrelude hiding (last, span, div)
import Text.Printf
import Network.HTTP.Client
import Network.HTTP.Client.TLS
import Data.Aeson
import Data.String.Utils
import Data.List (elemIndex, (!!), last)
import Data.Char (isAscii, isAlphaNum)
module IHaskell.Eval.Hoogle (
search,
document,
render,
OutputFormat(..),
HoogleResult,
) where
import ClassyPrelude hiding (last, span, div)
import Text.Printf
import Network.HTTP.Client
import Network.HTTP.Client.TLS
import Data.Aeson
import Data.String.Utils
import Data.List (elemIndex, (!!), last)
import Data.Char (isAscii, isAlphaNum)
import qualified Data.ByteString.Lazy.Char8 as Char
import qualified Prelude as P
import IHaskell.IPython
import IHaskell.IPython
-- | Types of formats to render output to.
data OutputFormat
= Plain -- ^ Render to plain text.
| HTML -- ^ Render to HTML.
data OutputFormat = Plain -- ^ Render to plain text.
| 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)
data HoogleResult
= SearchResult HoogleResponse
| DocResult HoogleResponse
| NoResult String
deriving Show
data HoogleResult = SearchResult HoogleResponse
| DocResult HoogleResponse
| NoResult String
deriving Show
instance FromJSON [HoogleResponse] where
parseJSON (Object obj) = do
@ -48,23 +43,21 @@ instance FromJSON [HoogleResponse] where
instance FromJSON HoogleResponse where
parseJSON (Object obj) =
HoogleResponse <$>
obj .: "location" <*>
obj .: "self" <*>
obj .: "docs"
HoogleResponse <$> obj .: "location" <*> obj .: "self" <*> obj .: "docs"
parseJSON _ = fail "Expected object with fields: location, self, docs"
-- | Query Hoogle for the given string.
-- This searches Hoogle using the internet. It returns either an error
-- message or the successful JSON result.
-- | Query Hoogle for the given string. This searches Hoogle using the internet. It returns either
-- an error message or the successful JSON result.
query :: String -> IO (Either String String)
query str = do
request <- parseUrl $ queryUrl $ urlEncode str
response <- try $ withManager tlsManagerSettings $ httpLbs request
return $ case response of
Left err -> Left $ show (err :: SomeException)
Right resp -> Right $ Char.unpack $ responseBody resp
return $
case response of
Left err -> Left $ show (err :: SomeException)
Right resp -> Right $ Char.unpack $ responseBody resp
where
queryUrl :: String -> String
queryUrl = printf "https://www.haskell.org/hoogle/?hoogle=%s&mode=json"
@ -76,53 +69,54 @@ urlEncode (ch:t)
| (isAscii ch && isAlphaNum ch) || ch `P.elem` "-_.~" = ch : urlEncode t
| not (isAscii ch) = P.foldr escape (urlEncode t) (eightBs [] (P.fromEnum ch))
| otherwise = escape (P.fromEnum ch) (urlEncode t)
where
escape :: Int -> String -> String
escape b rs = '%':showH (b `P.div` 16) (showH (b `mod` 16) rs)
showH :: Int -> String -> String
showH x xs
| x <= 9 = toEnum (o_0 + x) : xs
| otherwise = toEnum (o_A + (x-10)) : xs
where
o_0 = P.fromEnum '0'
o_A = P.fromEnum 'A'
where
escape :: Int -> String -> String
escape b rs = '%' : showH (b `P.div` 16) (showH (b `mod` 16) rs)
eightBs :: [Int] -> Int -> [Int]
eightBs acc x
| x <= 0xff = (x:acc)
showH :: Int -> String -> String
showH x xs
| x <= 9 = toEnum (o_0 + x) : xs
| otherwise = toEnum (o_A + (x - 10)) : xs
where
o_0 = P.fromEnum '0'
o_A = P.fromEnum 'A'
eightBs :: [Int] -> Int -> [Int]
eightBs acc x
| x <= 255 = x : acc
| otherwise = eightBs ((x `mod` 256) : acc) (x `P.div` 256)
-- | Search for a query on Hoogle.
-- Return all search results.
-- | Search for a query on Hoogle. Return all search results.
search :: String -> IO [HoogleResult]
search string = do
response <- query string
return $ case response of
Left err -> [NoResult err]
Right json ->
case eitherDecode $ Char.pack json of
Left err -> [NoResult err]
Right results ->
case map SearchResult results of
[] -> [NoResult "no matching identifiers found."]
res -> res
return $
case response of
Left err -> [NoResult err]
Right json ->
case eitherDecode $ Char.pack json of
Left err -> [NoResult err]
Right results ->
case map SearchResult results of
[] -> [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.
document :: String -> IO [HoogleResult]
document string = do
matchingResults <- filter matches <$> search string
let results = map toDocResult matchingResults
return $ case results of
[] -> [NoResult "no matching identifiers found."]
res -> res
return $
case results of
[] -> [NoResult "no matching identifiers found."]
res -> res
where
matches (SearchResult resp) =
case split " " $ self resp of
name:_ -> strip string == strip name
_ -> False
_ -> False
matches _ = False
toDocResult (SearchResult resp) = DocResult resp
@ -130,7 +124,7 @@ document string = do
-- | Render a Hoogle search result into an output format.
render :: OutputFormat -> HoogleResult -> String
render Plain = renderPlain
render HTML = renderHtml
render HTML = renderHtml
-- | Render a Hoogle result to plain text.
renderPlain :: HoogleResult -> String
@ -139,16 +133,10 @@ renderPlain (NoResult res) =
"No response available: " ++ res
renderPlain (SearchResult resp) =
printf "%s\nURL: %s\n%s"
(self resp)
(location resp)
(docs resp)
printf "%s\nURL: %s\n%s" (self resp) (location resp) (docs resp)
renderPlain (DocResult resp) =
printf "%s\nURL: %s\n%s"
(self resp)
(location resp)
(docs resp)
printf "%s\nURL: %s\n%s" (self resp) (location resp) (docs resp)
-- | Render a Hoogle result to HTML.
renderHtml :: HoogleResult -> String
@ -167,37 +155,37 @@ renderHtml (SearchResult resp) =
renderSelf :: String -> String -> String
renderSelf string loc
| startswith "package" string
= pkg ++ " " ++ span "hoogle-package" (link loc $ extractPackage string)
| startswith "package" string =
pkg ++ " " ++ span "hoogle-package" (link loc $ extractPackage string)
| startswith "module" string
= let package = extractPackageName loc in
mod ++ " " ++
span "hoogle-module" (link loc $ extractModule string) ++
packageSub package
| startswith "module" string =
let package = extractPackageName loc
in mod ++ " " ++
span "hoogle-module" (link loc $ extractModule string) ++
packageSub package
| startswith "class" string
= let package = extractPackageName loc in
cls ++ " " ++
span "hoogle-class" (link loc $ extractClass string) ++
packageSub package
| startswith "class" string =
let package = extractPackageName loc
in cls ++ " " ++
span "hoogle-class" (link loc $ extractClass string) ++
packageSub package
| startswith "data" string
= let package = extractPackageName loc in
dat ++ " " ++
span "hoogle-class" (link loc $ extractData string) ++
packageSub package
| startswith "data" string =
let package = extractPackageName loc
in dat ++ " " ++
span "hoogle-class" (link loc $ extractData string) ++
packageSub package
| otherwise
= let [name, args] = split "::" string
| otherwise =
let [name, args] = split "::" string
package = extractPackageName loc
modname = extractModuleName loc in
span "hoogle-name" (unicodeReplace $
link loc (strip name) ++
" :: " ++
strip args)
++ packageAndModuleSub package modname
modname = extractModuleName loc
in span "hoogle-name"
(unicodeReplace $
link loc (strip name) ++
" :: " ++
strip args)
++ packageAndModuleSub package modname
where
extractPackage = strip . replace "package" ""
extractModule = strip . replace "module" ""
@ -210,10 +198,10 @@ renderSelf string loc
unicodeReplace :: String -> String
unicodeReplace =
replace "forall" "&#x2200;" .
replace "=>" "&#x21D2;" .
replace "->" "&#x2192;" .
replace "::" "&#x2237;"
replace "forall" "&#x2200;" .
replace "=>" "&#x21D2;" .
replace "->" "&#x2192;" .
replace "::" "&#x2237;"
packageSub Nothing = ""
packageSub (Just package) =
@ -223,9 +211,9 @@ renderSelf string loc
packageAndModuleSub Nothing _ = ""
packageAndModuleSub (Just package) Nothing = packageSub (Just package)
packageAndModuleSub (Just package) (Just modname) =
span "hoogle-sub" $
"(" ++ pkg ++ " " ++ span "hoogle-package" package ++
", " ++ mod ++ " " ++ span "hoogle-module" modname ++ ")"
span "hoogle-sub" $
"(" ++ pkg ++ " " ++ span "hoogle-package" package ++
", " ++ mod ++ " " ++ span "hoogle-module" modname ++ ")"
renderDocs :: String -> String
renderDocs doc =
@ -237,12 +225,11 @@ renderDocs doc =
isCode (s:_) = startswith ">" $ strip s
makeBlock lines =
if isCode lines
then div "hoogle-code" $ unlines $ nonull lines
else div "hoogle-text" $ unlines $ nonull lines
in
div "hoogle-doc" $ unlines $ map makeBlock groups
then div "hoogle-code" $ unlines $ nonull lines
else div "hoogle-text" $ unlines $ nonull lines
in div "hoogle-doc" $ unlines $ map makeBlock groups
extractPackageName :: String -> Maybe String
extractPackageName :: String -> Maybe String
extractPackageName link = do
let pieces = split "/" link
archiveLoc <- elemIndex "archive" pieces
@ -250,7 +237,7 @@ extractPackageName link = do
guard $ latestLoc - archiveLoc == 2
return $ pieces !! (latestLoc - 1)
extractModuleName :: String -> Maybe String
extractModuleName :: String -> Maybe String
extractModuleName link = do
let pieces = split "/" link
guard $ not $ null pieces

22
src/IHaskell/Eval/Info.hs
View File

@ -1,23 +1,21 @@
{-# 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 Outputable
import Exception
import IHaskell.Eval.Evaluate (typeCleaner, Interpreter)
import GHC
import Outputable
import Exception
info :: String -> Interpreter String
info name = ghandle handler $ do
dflags <- getSessionDynFlags
result <- exprType name
return $ typeCleaner $ showPpr dflags result
where
return $ typeCleaner $ showPpr dflags result
where
handler :: SomeException -> Interpreter String
handler _ = return ""

213
src/IHaskell/Eval/Lint.hs
View File

@ -1,45 +1,44 @@
{-# LANGUAGE NoImplicitPrelude, QuasiQuotes, ViewPatterns #-}
module IHaskell.Eval.Lint (
lint
) where
import Data.String.Utils (replace, startswith, strip, split)
import Prelude (head, tail, last)
import ClassyPrelude hiding (last)
import Control.Monad
import Data.List (findIndex)
import Text.Printf
import Data.String.Here
import Data.Char
import Data.Monoid
import Data.Maybe (mapMaybe)
import System.IO.Unsafe (unsafePerformIO)
module IHaskell.Eval.Lint (lint) where
import Language.Haskell.Exts.Annotated.Syntax hiding (Module)
import Data.String.Utils (replace, startswith, strip, split)
import Prelude (head, tail, last)
import ClassyPrelude hiding (last)
import Control.Monad
import Data.List (findIndex)
import Text.Printf
import Data.String.Here
import Data.Char
import Data.Monoid
import Data.Maybe (mapMaybe)
import System.IO.Unsafe (unsafePerformIO)
import Language.Haskell.Exts.Annotated.Syntax hiding (Module)
import qualified Language.Haskell.Exts.Annotated.Syntax as SrcExts
import Language.Haskell.Exts.Annotated (parseFileContentsWithMode)
import Language.Haskell.Exts.Annotated.Build (doE)
import Language.Haskell.Exts.Annotated hiding (Module)
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.Exts.Annotated (parseFileContentsWithMode)
import Language.Haskell.Exts.Annotated.Build (doE)
import Language.Haskell.Exts.Annotated hiding (Module)
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.HLint as HLint
import Language.Haskell.HLint2
import Language.Haskell.HLint as HLint
import Language.Haskell.HLint2
import IHaskell.Types
import IHaskell.Display
import IHaskell.IPython
import IHaskell.Eval.Parser hiding (line)
import IHaskell.Types
import IHaskell.Display
import IHaskell.IPython
import IHaskell.Eval.Parser hiding (line)
type ExtsModule = SrcExts.Module SrcSpanInfo
data LintSuggestion
= Suggest {
line :: LineNumber,
found :: String,
whyNot :: String,
severity :: Severity,
suggestion :: String
}
data LintSuggestion =
Suggest
{ line :: LineNumber
, found :: String
, whyNot :: String
, severity :: Severity
, suggestion :: String
}
deriving (Eq, Show)
-- Store settings for Hlint once it's initialized.
@ -51,8 +50,8 @@ hlintSettings = unsafePerformIO newEmptyMVar
lintIdent :: String
lintIdent = "lintIdentAEjlkQeh"
-- | Given parsed code chunks, perform linting and output a displayable
-- report on linting warnings and errors.
-- | Given parsed code chunks, perform linting and output a displayable report on linting warnings
-- and errors.
lint :: [Located CodeBlock] -> IO Display
lint blocks = do
-- Initialize hlint settings
@ -66,63 +65,62 @@ lint blocks = do
-- create 'suggestions'
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
return $ Display $
if null suggestions
then []
else
[plain $ concatMap plainSuggestion suggestions,
html $ htmlSuggestions suggestions]
then []
else [plain $ concatMap plainSuggestion suggestions, html $ htmlSuggestions suggestions]
showIdea :: Idea -> Maybe LintSuggestion
showIdea idea =
showIdea idea =
case ideaTo idea of
Nothing -> Nothing
Just whyNot -> Just Suggest {
line = srcSpanStartLine $ ideaSpan idea,
found = showSuggestion $ ideaFrom idea,
whyNot = showSuggestion whyNot,
severity = ideaSeverity idea,
suggestion = ideaHint idea
}
Just whyNot -> Just
Suggest
{ line = srcSpanStartLine $ ideaSpan idea
, found = showSuggestion $ ideaFrom idea
, whyNot = showSuggestion whyNot
, severity = ideaSeverity idea
, suggestion = ideaHint idea
}
createModule :: ParseMode -> Located CodeBlock -> Maybe ExtsModule
createModule mode (Located line block) =
createModule mode (Located line block) =
case block of
Expression expr -> unparse $ exprToModule expr
Declaration decl -> unparse $ declToModule decl
Statement stmt -> unparse $ stmtToModule stmt
Import impt -> unparse $ imptToModule impt
Module mod -> unparse $ parseModule mod
_ -> Nothing
Expression expr -> unparse $ exprToModule expr
Declaration decl -> unparse $ declToModule decl
Statement stmt -> unparse $ stmtToModule stmt
Import impt -> unparse $ imptToModule impt
Module mod -> unparse $ parseModule mod
_ -> Nothing
where
blockStr =
blockStr =
case block of
Expression expr -> expr
Declaration decl -> decl
Statement stmt -> stmt
Import impt -> impt
Module mod -> mod
Expression expr -> expr
Declaration decl -> decl
Statement stmt -> stmt
Import impt -> impt
Module mod -> mod
unparse :: ParseResult a -> Maybe a
unparse (ParseOk a) = Just a
unparse _ = Nothing
srcSpan :: SrcSpan
srcSpan = SrcSpan {
srcSpanFilename = "<interactive>",
srcSpanStartLine = line,
srcSpanStartColumn = 0,
srcSpanEndLine = line + length (lines blockStr),
srcSpanEndColumn = length $ last $ lines blockStr
}
srcSpan = SrcSpan
{ srcSpanFilename = "<interactive>"
, srcSpanStartLine = line
, srcSpanStartColumn = 0
, srcSpanEndLine = line + length (lines blockStr)
, srcSpanEndColumn = length $ last $ lines blockStr
}
loc :: SrcSpanInfo
loc = SrcSpanInfo srcSpan []
moduleWithDecls :: Decl SrcSpanInfo -> ExtsModule
moduleWithDecls :: Decl SrcSpanInfo -> ExtsModule
moduleWithDecls decl = SrcExts.Module loc Nothing [] [] [decl]
parseModule :: String -> ParseResult ExtsModule
@ -135,9 +133,10 @@ createModule mode (Located line block) =
exprToModule exp = moduleWithDecls <$> SpliceDecl loc <$> parseExpWithMode mode exp
stmtToModule :: String -> ParseResult ExtsModule
stmtToModule stmtStr = case parseStmtWithMode mode stmtStr of
ParseOk stmt -> ParseOk mod
ParseFailed a b -> ParseFailed a b
stmtToModule stmtStr =
case parseStmtWithMode mode stmtStr of
ParseOk stmt -> ParseOk mod
ParseFailed a b -> ParseFailed a b
where
mod = moduleWithDecls decl
@ -157,35 +156,31 @@ createModule mode (Located line block) =
imptToModule = parseFileContentsWithMode mode
plainSuggestion :: LintSuggestion -> String
plainSuggestion suggest =
printf "Line %d: %s\nFound:\n%s\nWhy not:\n%s"
(line suggest)
(suggestion suggest)
(found suggest)
plainSuggestion suggest =
printf "Line %d: %s\nFound:\n%s\nWhy not:\n%s" (line suggest) (suggestion suggest) (found suggest)
(whyNot suggest)
htmlSuggestions :: [LintSuggestion] -> String
htmlSuggestions = concatMap toHtml
htmlSuggestions = concatMap toHtml
where
toHtml :: LintSuggestion -> String
toHtml suggest = concat
[
named $ suggestion suggest,
floating "left" $ style severityClass "Found:" ++
-- Things that look like this get highlighted.
styleId "highlight-code" "haskell" (found suggest),
floating "left" $ style severityClass "Why Not:" ++
-- Things that look like this get highlighted.
styleId "highlight-code" "haskell" (whyNot suggest)
]
toHtml suggest = concat
[ named $ suggestion suggest
, floating "left" $ style severityClass "Found:" ++
-- Things that look like this get highlighted.
styleId "highlight-code" "haskell" (found suggest)
, floating "left" $ style severityClass "Why Not:" ++
-- Things that look like this get highlighted.
styleId "highlight-code" "haskell" (whyNot suggest)
]
where
severityClass = case severity suggest of
Error -> "error"
Warning -> "warning"
severityClass =
case severity suggest of
Error -> "error"
Warning -> "warning"
-- Should not occur
_ -> "warning"
-- Should not occur
_ -> "warning"
style :: String -> String -> String
style cls thing = [i| <div class="suggestion-${cls}">${thing}</div> |]
@ -195,37 +190,33 @@ htmlSuggestions = concatMap toHtml
styleId :: String -> String -> String -> String
styleId cls id thing = [i| <div class="${cls}" id="${id}">${thing}</div> |]
floating :: String -> String -> String
floating dir thing = [i| <div class="suggestion-row" style="float: ${dir};">${thing}</div> |]
showSuggestion :: String -> String
showSuggestion = remove lintIdent . dropDo
showSuggestion = remove lintIdent . dropDo
where
remove str = replace str ""
-- Drop leading ' do ', and blank spaces following.
dropDo :: String -> String
dropDo string =
dropDo string =
-- If this is not a statement, we don't need to drop the do statement.
if lintIdent `isInfixOf` string
then unlines . clean . lines $ string
else string
then unlines . clean . lines $ string
else string
clean :: [String] -> [String]
-- If the first line starts with a `do`...
-- Note that hlint always indents by two spaces in its output.
clean ((stripPrefix " do " -> Just a) : as) =
-- Take all indented lines and unindent them.
let unindented = catMaybes
$ takeWhile isJust
$ map (stripPrefix " ") as
fullDo = a:unindented
afterDo = drop (length unindented) as
in
--
fullDo ++ clean afterDo
-- If the first line starts with a `do`... Note that hlint always indents by two spaces in its
-- output.
clean ((stripPrefix " do " -> Just a):as) =
-- Take all indented lines and unindent them.
let unindented = catMaybes $ takeWhile isJust $ map (stripPrefix " ") as
fullDo = a : unindented
afterDo = drop (length unindented) as
in fullDo ++ clean afterDo
-- Ignore other list elements - just proceed onwards.
clean (x:xs) = x : clean xs

45
src/IHaskell/Eval/ParseShell.hs
View File

@ -1,16 +1,15 @@
-- | This module splits a shell command line into a list of strings,
-- one for each command / filename
module IHaskell.Eval.ParseShell (parseShell) where
module IHaskell.Eval.ParseShell (parseShell) where
import Prelude hiding (words)
import Text.ParserCombinators.Parsec hiding (manyTill)
import Control.Applicative hiding ((<|>), many, optional)
import Prelude hiding (words)
import Text.ParserCombinators.Parsec hiding (manyTill)
import Control.Applicative hiding ((<|>), many, optional)
eol :: Parser Char
eol = oneOf "\n\r" <?> "end of line"
quote :: Parser Char
quote :: Parser Char
quote = char '\"'
-- | @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]
manyTill p end = scan
where
scan = end <|> do
x <- p
xs <- scan
return $ x:xs
x <- p
xs <- scan
return $ x : xs
manyTill1 p end = do x <- p
xs <- manyTill p end
return $ x : xs
manyTill1 p end = do
x <- p
xs <- manyTill p end
return $ x : xs
unescapedChar :: Parser Char -> Parser String
unescapedChar p = try $ do
unescapedChar :: Parser Char -> Parser String
unescapedChar p = try $ do
x <- noneOf "\\"
lookAhead p
return [x]
@ -36,8 +36,9 @@ quotedString = do
quote <?> "expected starting quote"
(manyTill anyChar (unescapedChar quote) <* quote) <?> "unexpected in quoted String "
unquotedString = manyTill1 anyChar end
where end = unescapedChar space
unquotedString = manyTill1 anyChar end
where
end = unescapedChar space
<|> (lookAhead eol >> return [])
word = quotedString <|> unquotedString <?> "word"
@ -48,12 +49,12 @@ separator = many1 space <?> "separator"
-- | Input must terminate in a space character (like a \n)
words :: Parser [String]
words = try (eof *> return []) <|> do
x <- word
rest1 <- lookAhead (many anyToken)
ss <- separator
rest2 <- lookAhead (many anyToken)
xs <- words
return $ x : xs
x <- word
rest1 <- lookAhead (many anyToken)
ss <- separator
rest2 <- lookAhead (many anyToken)
xs <- words
return $ x : xs
parseShell :: String -> Either ParseError [String]
parseShell string = parse words "shell" (string ++ "\n")

234
src/IHaskell/Eval/Parser.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
module IHaskell.Eval.Parser (
parseString,
CodeBlock(..),
@ -14,56 +15,55 @@ module IHaskell.Eval.Parser (
PragmaType(..),
) where
import ClassyPrelude hiding (head, liftIO, maximumBy)
import ClassyPrelude hiding (head, liftIO, maximumBy)
import Data.List (maximumBy, inits)
import Data.String.Utils (startswith, strip, split)
import Prelude (head, tail)
import Control.Monad (msum)
import Data.List (maximumBy, inits)
import Data.String.Utils (startswith, strip, split)
import Prelude (head, tail)
import Control.Monad (msum)
import GHC hiding (Located)
import GHC hiding (Located)
import Language.Haskell.GHC.Parser
import IHaskell.Eval.Util
import Language.Haskell.GHC.Parser
import IHaskell.Eval.Util
-- | A block of code to be evaluated.
-- Each block contains a single element - one declaration, statement,
-- expression, etc. If parsing of the block failed, the block is instead
-- a ParseError, which has the error location and error message.
data CodeBlock
= Expression String -- ^ A Haskell expression.
| Declaration String -- ^ A data type or function declaration.
| Statement String -- ^ A Haskell statement (as if in a `do` block).
| Import String -- ^ An import statement.
| TypeSignature String -- ^ A lonely type signature (not above a function declaration).
| Directive DirectiveType String -- ^ An IHaskell directive.
| Module String -- ^ A full Haskell module, to be compiled and loaded.
| ParseError StringLoc ErrMsg -- ^ An error indicating that parsing the code block failed.
| Pragma PragmaType [String] -- ^ A list of GHC pragmas (from a {-# LANGUAGE ... #-} block)
-- | A block of code to be evaluated. Each block contains a single element - one declaration,
-- statement, expression, etc. If parsing of the block failed, the block is instead a ParseError,
-- which has the error location and error message.
data CodeBlock = Expression String -- ^ A Haskell expression.
| Declaration String -- ^ A data type or function declaration.
| Statement String -- ^ A Haskell statement (as if in a `do` block).
| Import String -- ^ An import statement.
| TypeSignature String -- ^ A lonely type signature (not above a function
-- declaration).
| Directive DirectiveType String -- ^ An IHaskell directive.
| Module String -- ^ A full Haskell module, to be compiled and loaded.
| ParseError StringLoc ErrMsg -- ^ An error indicating that parsing the code block
-- failed.
| Pragma PragmaType [String] -- ^ A list of GHC pragmas (from a {-# LANGUAGE ... #-}
-- block)
deriving (Show, Eq)
-- | Directive types. Each directive is associated with a string in the
-- directive code block.
data DirectiveType
= GetType -- ^ Get the type of an expression via ':type' (or unique prefixes)
| GetInfo -- ^ Get info about the identifier via ':info' (or unique prefixes)
| SetDynFlag -- ^ Enable or disable an extensions, packages etc. via `:set`. Emulates GHCi's `:set`
| LoadFile -- ^ Load a Haskell module.
| SetOption -- ^ Set IHaskell kernel option `:option`.
| SetExtension -- ^ `:extension Foo` is a shortcut for `:set -XFoo`
| ShellCmd -- ^ Execute a shell command.
| GetHelp -- ^ General help via ':?' or ':help'.
| SearchHoogle -- ^ Search for something via Hoogle.
| GetDoc -- ^ Get documentation for an identifier via Hoogle.
| GetKind -- ^ Get the kind of a type via ':kind'.
| LoadModule -- ^ Load and unload modules via ':module'.
-- | Directive types. Each directive is associated with a string in the directive code block.
data DirectiveType = GetType -- ^ Get the type of an expression via ':type' (or unique prefixes)
| GetInfo -- ^ Get info about the identifier via ':info' (or unique prefixes)
| SetDynFlag -- ^ Enable or disable an extensions, packages etc. via `:set`.
-- Emulates GHCi's `:set`
| LoadFile -- ^ Load a Haskell module.
| SetOption -- ^ Set IHaskell kernel option `:option`.
| SetExtension -- ^ `:extension Foo` is a shortcut for `:set -XFoo`
| ShellCmd -- ^ Execute a shell command.
| GetHelp -- ^ General help via ':?' or ':help'.
| SearchHoogle -- ^ Search for something via Hoogle.
| GetDoc -- ^ Get documentation for an identifier via Hoogle.
| GetKind -- ^ Get the kind of a type via ':kind'.
| LoadModule -- ^ Load and unload modules via ':module'.
deriving (Show, Eq)
-- | Pragma types. Only LANGUAGE pragmas are currently supported.
-- Other pragma types are kept around as a string for error reporting.
data PragmaType
= PragmaLanguage
| PragmaUnsupported String
-- | Pragma types. Only LANGUAGE pragmas are currently supported. Other pragma types are kept around
-- as a string for error reporting.
data PragmaType = PragmaLanguage
| PragmaUnsupported String
deriving (Show, Eq)
-- | Parse a string into code blocks.
@ -73,18 +73,18 @@ parseString codeString = do
flags <- getSessionDynFlags
let output = runParser flags parserModule codeString
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
-- Split input into chunks based on indentation.
let chunks = layoutChunks $ removeComments codeString
result <- joinFunctions <$> processChunks [] chunks
-- Return to previous flags. When parsing, flags can be set to make
-- sure parsing works properly. But we don't want those flags to be
-- set during evaluation until the right time.
-- Return to previous flags. When parsing, flags can be set to make sure parsing works properly. But
-- we don't want those flags to be set during evaluation until the right time.
_ <- setSessionDynFlags flags
return result
otherwise -> error "parseString failed, output was neither Parsed nor Failure"
where
parseChunk :: GhcMonad m => String -> LineNumber -> m (Located CodeBlock)
parseChunk chunk line = Located line <$> handleChunk chunk line
@ -101,7 +101,7 @@ parseString codeString = do
[] -> return $ reverse accum
-- 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
activateExtensions $ unloc block
processChunks (block : accum) remaining
@ -119,7 +119,7 @@ activateExtensions (Directive SetExtension ext) = void $ setExtension ext
activateExtensions (Directive SetDynFlag flags) =
case stripPrefix "-X" flags of
Just ext -> void $ setExtension ext
Nothing -> return ()
Nothing -> return ()
activateExtensions (Pragma PragmaLanguage extensions) = void $ setAll extensions
where
setAll :: GhcMonad m => [String] -> m (Maybe String)
@ -131,20 +131,21 @@ activateExtensions _ = return ()
-- | Parse a single chunk of code, as indicated by the layout of the code.
parseCodeChunk :: GhcMonad m => String -> LineNumber -> m CodeBlock
parseCodeChunk code startLine = do
flags <- getSessionDynFlags
let
-- Try each parser in turn.
rawResults = map (tryParser code) (parsers flags)
flags <- getSessionDynFlags
let
-- Try each parser in turn.
rawResults = map (tryParser code) (parsers flags)
-- Convert statements into expressions where we can
results = map (statementToExpression flags) rawResults in
case successes results of
-- If none of them succeeded, choose the best error message to
-- display. Only one of the error messages is actually relevant.
[] -> return $ bestError $ failures results
-- Convert statements into expressions where we can
results = map (statementToExpression flags) rawResults
case successes results of
-- If none of them succeeded, choose the best error message to display. Only one of the error
-- messages is actually relevant.
[] -> return $ bestError $ failures results
-- If one of the parsers succeeded
result:_ -> return result
-- If one of the parsers succeeded
result:_ -> return result
where
successes :: [ParseOutput a] -> [a]
successes [] = []
@ -164,47 +165,50 @@ parseCodeChunk code startLine = do
statementToExpression :: DynFlags -> ParseOutput CodeBlock -> ParseOutput CodeBlock
statementToExpression flags (Parsed (Statement stmt)) = Parsed result
where result = if isExpr flags stmt
then Expression stmt
else Statement stmt
where
result = if isExpr flags stmt
then Expression stmt
else Statement stmt
statementToExpression _ other = other
-- Check whether a string is a valid expression.
isExpr :: DynFlags -> String -> Bool
isExpr flags str = case runParser flags parserExpression str of
Parsed {} -> True
_ -> False
isExpr flags str =
case runParser flags parserExpression str of
Parsed{} -> True
_ -> False
tryParser :: String -> (String -> CodeBlock, String -> ParseOutput String) -> ParseOutput CodeBlock
tryParser string (blockType, parser) = case parser string of
Parsed res -> Parsed (blockType res)
Failure err loc -> Failure err loc
otherwise -> error "tryParser failed, output was neither Parsed nor Failure"
tryParser string (blockType, parser) =
case parser string of
Parsed res -> Parsed (blockType res)
Failure err loc -> Failure err loc
otherwise -> error "tryParser failed, output was neither Parsed nor Failure"
parsers :: DynFlags -> [(String -> CodeBlock, String -> ParseOutput String)]
parsers flags =
[ (Import, unparser parserImport)
[ (Import, unparser parserImport)
, (TypeSignature, unparser parserTypeSignature)
, (Statement, unparser parserStatement)
, (Declaration, unparser parserDeclaration)
, (Statement, unparser parserStatement)
, (Declaration, unparser parserDeclaration)
]
where
unparser :: Parser a -> String -> ParseOutput String
unparser parser code =
case runParser flags parser code of
Parsed out -> Parsed code
Parsed out -> Parsed code
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
-- a single declaration. These declarations may also include a type
-- signature, which is also joined with the subsequent declarations.
-- | Find consecutive declarations of the same function and join them into a single declaration.
-- These declarations may also include a type signature, which is also joined with the subsequent
-- declarations.
joinFunctions :: [Located CodeBlock] -> [Located CodeBlock]
joinFunctions [] = []
joinFunctions blocks =
if signatureOrDecl $ unloc $ head blocks
then Located lnum (conjoin $ map unloc decls) : joinFunctions rest
else head blocks : joinFunctions (tail blocks)
then Located lnum (conjoin $ map unloc decls) : joinFunctions rest
else head blocks : joinFunctions (tail blocks)
where
decls = takeWhile (signatureOrDecl . unloc) blocks
rest = drop (length decls) blocks
@ -229,10 +233,11 @@ parsePragma :: String -- ^ Pragma string.
parsePragma ('{':'-':'#':pragma) line =
let commaToSpace :: Char -> Char
commaToSpace ',' = ' '
commaToSpace x = x
pragmas = words $ takeWhile (/= '#') $ map commaToSpace pragma in
case pragmas of
[] -> Pragma (PragmaUnsupported "") [] --empty string pragmas are unsupported
commaToSpace x = x
pragmas = words $ takeWhile (/= '#') $ map commaToSpace pragma
in case pragmas of
--empty string pragmas are unsupported
[] -> Pragma (PragmaUnsupported "") []
"LANGUAGE":xs -> Pragma PragmaLanguage xs
x:xs -> Pragma (PragmaUnsupported x) xs
@ -241,47 +246,50 @@ parseDirective :: String -- ^ Directive string.
-> Int -- ^ Line number at which the directive appears.
-> CodeBlock -- ^ Directive code block or a parse error.
parseDirective (':':'!':directive) line = Directive ShellCmd $ '!':directive
parseDirective (':':directive) line = case find rightDirective directives of
Just (directiveType, _) -> Directive directiveType arg
where arg = unwords restLine
_:restLine = words directive
Nothing ->
let directiveStart = case words directive of
[] -> ""
first:_ -> first in
ParseError (Loc line 1) $ "Unknown directive: '" ++ directiveStart ++ "'."
parseDirective (':':'!':directive) line = Directive ShellCmd $ '!' : directive
parseDirective (':':directive) line =
case find rightDirective directives of
Just (directiveType, _) -> Directive directiveType arg
where arg = unwords restLine
_:restLine = words directive
Nothing ->
let directiveStart =
case words directive of
[] -> ""
first:_ -> first
in ParseError (Loc line 1) $ "Unknown directive: '" ++ directiveStart ++ "'."
where
rightDirective (_, dirname) = case words directive of
[] -> False
dir:_ -> dir `elem` tail (inits dirname)
rightDirective (_, dirname) =
case words directive of
[] -> False
dir:_ -> dir `elem` tail (inits dirname)
directives =
[ (LoadModule, "module")
, (GetType, "type")
, (GetKind, "kind")
, (GetInfo, "info")
[ (LoadModule, "module")
, (GetType, "type")
, (GetKind, "kind")
, (GetInfo, "info")
, (SearchHoogle, "hoogle")
, (GetDoc, "documentation")
, (SetDynFlag, "set")
, (LoadFile, "load")
, (SetOption, "option")
, (GetDoc, "documentation")
, (SetDynFlag, "set")
, (LoadFile, "load")
, (SetOption, "option")
, (SetExtension, "extension")
, (GetHelp, "?")
, (GetHelp, "help")
, (GetHelp, "?")
, (GetHelp, "help")
]
parseDirective _ _ = error "Directive must start with colon!"
-- | Parse a module and return the name declared in the 'module X where'
-- line. That line is required, and if it does not exist, this will error.
-- Names with periods in them are returned piece y piece.
-- | Parse a module and return the name declared in the 'module X where' line. That line is
-- required, and if it does not exist, this will error. Names with periods in them are returned
-- piece y piece.
getModuleName :: GhcMonad m => String -> m [String]
getModuleName moduleSrc = do
flags <- getSessionDynFlags
let output = runParser flags parserModule moduleSrc
case output of
Failure {} -> error "Module parsing failed."
Failure{} -> error "Module parsing failed."
Parsed mod ->
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
otherwise -> error "getModuleName failed, output was neither Parsed nor Failure"

328
src/IHaskell/Eval/Util.hs
View File

@ -1,26 +1,27 @@
{-# LANGUAGE CPP, NoImplicitPrelude #-}
module IHaskell.Eval.Util (
-- * Initialization
initGhci,
-- * Initialization
initGhci,
-- * Flags and extensions
-- ** Set and unset flags.
extensionFlag, setExtension,
ExtFlag(..),
setFlags,
-- * Flags and extensions ** Set and unset flags.
extensionFlag,
setExtension,
ExtFlag(..),
setFlags,
-- * Code Evaluation
evalImport,
removeImport,
evalDeclarations,
getType,
getDescription,
-- * Code Evaluation
evalImport,
removeImport,
evalDeclarations,
getType,
getDescription,
-- * Pretty printing
doc,
pprDynFlags,
pprLanguages
) where
-- * Pretty printing
doc,
pprDynFlags,
pprLanguages,
) where
import ClassyPrelude hiding ((<>))
@ -50,20 +51,17 @@ import Data.String.Utils (replace)
import Data.List (nubBy)
-- | A extension flag that can be set or unset.
data ExtFlag
= SetFlag ExtensionFlag
| UnsetFlag ExtensionFlag
data ExtFlag = SetFlag ExtensionFlag
| UnsetFlag ExtensionFlag
-- | Find the extension that corresponds to a given flag. Create the
-- corresponding 'ExtFlag' via @SetFlag@ or @UnsetFlag@.
-- If no such extension exist, yield @Nothing@.
-- | Find the extension that corresponds to a given flag. Create the corresponding 'ExtFlag' via
-- @SetFlag@ or @UnsetFlag@. If no such extension exist, yield @Nothing@.
extensionFlag :: String -- Extension name, such as @"DataKinds"@
-> Maybe ExtFlag
extensionFlag ext =
case find (flagMatches ext) xFlags of
Just fs -> Just $ SetFlag $ flagSpecFlag fs
-- If it doesn't match an extension name, try matching against
-- disabling an extension.
-- If it doesn't match an extension name, try matching against disabling an extension.
Nothing ->
case find (flagMatchesNo ext) xFlags of
Just fs -> Just $ UnsetFlag $ flagSpecFlag fs
@ -72,18 +70,12 @@ extensionFlag ext =
-- Check if a FlagSpec matches an extension name.
flagMatches ext fs = ext == flagSpecName fs
-- Check if a FlagSpec matches "No<ExtensionName>".
-- In that case, we disable the extension.
-- Check if a FlagSpec matches "No<ExtensionName>". In that case, we disable the extension.
flagMatchesNo ext fs = ext == "No" ++ flagSpecName fs
#if !MIN_VERSION_ghc(7,10,0)
flagSpecName (name,_,_) = name
flagSpecFlag (_,flag,_) = flag
#endif
#if !MIN_VERSION_ghc(7,10,0)
flagSpecName (name,_,_) = name
flagSpecFlag (_,flag,_) = flag
flagSpecName (name, _, _) = name
flagSpecFlag (_, flag, _) = flag
#endif
-- | Pretty-print dynamic flags (taken from 'InteractiveUI' module of `ghc-bin`)
@ -91,84 +83,80 @@ pprDynFlags :: Bool -- ^ Whether to include flags which are on by default
-> DynFlags
-> SDoc
pprDynFlags show_all dflags =
vcat [
#if MIN_VERSION_ghc(7,8,0)
text "GHCi-specific dynamic flag settings:" $$
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
text "GHCi-specific dynamic flag settings:" $$
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
]
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
setting test flag
| quiet = empty
| is_on = fstr name
| otherwise = fnostr name
where name = flagSpecName flag
f = flagSpecFlag flag
is_on = test f dflags
quiet = not show_all && test f default_dflags == is_on
default_dflags = defaultDynFlags (settings dflags)
fstr str = text "-f" <> text str
fnostr str = text "-fno-" <> text str
(ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs)
DynFlags.fFlags
flgs = [
Opt_PrintExplicitForalls
#if MIN_VERSION_ghc(7,8,0)
, Opt_PrintExplicitKinds
opt = gopt
#else
opt = dopt
#endif
, Opt_PrintBindResult
, Opt_BreakOnException
, Opt_BreakOnError
, Opt_PrintEvldWithShow
]
setting test flag
| quiet = empty
| is_on = fstr name
| otherwise = fnostr name
where
name = flagSpecName flag
f = flagSpecFlag flag
is_on = test f dflags
quiet = not show_all && test f default_dflags == is_on
default_dflags = defaultDynFlags (settings dflags)
fstr str = text "-f" <> text str
fnostr str = text "-fno-" <> text str
(ghciFlags, others) = partition (\f -> flagSpecFlag f `elem` flgs) DynFlags.fFlags
flgs = concat [flgs1, flgs2, flgs3]
flgs1 = [Opt_PrintExplicitForalls]
#if MIN_VERSION_ghc(7,8,0)
flgs2 = [Opt_PrintExplicitKinds]
#else
flgs2 = []
#endif
flgs3 = [Opt_PrintBindResult, 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
-> DynFlags
-> SDoc
pprLanguages show_all dflags =
vcat
[ text "base language is: " <>
case language dflags of
Nothing -> text "Haskell2010"
Just Haskell98 -> text "Haskell98"
Just Haskell2010 -> text "Haskell2010"
, (if show_all then text "all active language options:"
else text "with the following modifiers:") $$
nest 2 (vcat (map (setting xopt) DynFlags.xFlags))
]
[text "base language is: " <>
case language dflags of
Nothing -> text "Haskell2010"
Just Haskell98 -> text "Haskell98"
Just Haskell2010 -> text "Haskell2010", (if show_all
then text "all active language options:"
else text "with the following modifiers:") $$
nest 2 (vcat (map (setting xopt) DynFlags.xFlags))]
where
setting test flag
| quiet = empty
| is_on = text "-X" <> text name
| otherwise = text "-XNo" <> text name
where name = flagSpecName flag
f = flagSpecFlag flag
is_on = test f dflags
quiet = not show_all && test f default_dflags == is_on
setting test flag
| quiet = empty
| is_on = text "-X" <> text name
| otherwise = text "-XNo" <> text name
where
name = flagSpecName flag
f = flagSpecFlag flag
is_on = test f dflags
quiet = not show_all && test f default_dflags == is_on
default_dflags =
defaultDynFlags (settings dflags) `lang_set`
case language dflags of
Nothing -> Just Haskell2010
other -> other
default_dflags =
defaultDynFlags (settings dflags) `lang_set`
case language dflags of
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 ext = do
flags <- getSessionDynFlags
@ -177,37 +165,35 @@ setExtension ext = do
Just flag -> do
setSessionDynFlags $
case flag of
SetFlag ghcFlag -> xopt_set flags ghcFlag
SetFlag ghcFlag -> xopt_set flags ghcFlag
UnsetFlag ghcFlag -> xopt_unset flags ghcFlag
return Nothing
-- | Set a list of flags, as per GHCi's `:set`.
-- This was adapted from GHC's InteractiveUI.hs (newDynFlags).
-- It returns a list of error messages.
-- | Set a list of flags, as per GHCi's `:set`. This was adapted from GHC's InteractiveUI.hs
-- (newDynFlags). It returns a list of error messages.
setFlags :: GhcMonad m => [String] -> m [String]
setFlags ext = do
-- Try to parse flags.
flags <- getSessionDynFlags
(flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext)
-- Try to parse flags.
flags <- getSessionDynFlags
(flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext)
-- First, try to check if this flag matches any extension name.
let restorePkg x = x { packageFlags = packageFlags flags }
let restoredPkgs = flags' { packageFlags = packageFlags flags}
GHC.setProgramDynFlags restoredPkgs
GHC.setInteractiveDynFlags restoredPkgs
-- First, try to check if this flag matches any extension name.
let restorePkg x = x { packageFlags = packageFlags flags }
let restoredPkgs = flags' { packageFlags = packageFlags flags }
GHC.setProgramDynFlags restoredPkgs
GHC.setInteractiveDynFlags restoredPkgs
-- Create the parse errors.
let noParseErrs = map (("Could not parse: " ++) . unLoc) unrecognized
allWarns = map unLoc warnings ++
["-package not supported yet" | packageFlags flags /= packageFlags flags']
warnErrs = map ("Warning: " ++) allWarns
return $ noParseErrs ++ warnErrs
-- Create the parse errors.
let noParseErrs = map (("Could not parse: " ++) . unLoc) unrecognized
allWarns = map unLoc warnings ++
["-package not supported yet" | packageFlags flags /= packageFlags flags']
warnErrs = map ("Warning: " ++) allWarns
return $ noParseErrs ++ warnErrs
-- | Convert an 'SDoc' into a string. This is similar to the family of
-- 'showSDoc' functions, but does not impose an arbitrary width limit on
-- the output (in terms of number of columns). Instead, it respsects the
-- 'pprCols' field in the structure returned by 'getSessionDynFlags', and
-- thus gives a configurable width of output.
-- | Convert an 'SDoc' into a string. This is similar to the family of 'showSDoc' functions, but
-- does not impose an arbitrary width limit on the output (in terms of number of columns). Instead,
-- it respsects the 'pprCols' field in the structure returned by 'getSessionDynFlags', and thus
-- gives a configurable width of output.
doc :: GhcMonad m => SDoc -> m String
doc sdoc = do
flags <- getSessionDynFlags
@ -216,15 +202,16 @@ doc sdoc = do
let cols = pprCols flags
d = runSDoc sdoc (initSDocContext flags style)
return $ Pretty.fullRender Pretty.PageMode cols 1.5 string_txt "" d
where
string_txt :: Pretty.TextDetails -> String -> String
string_txt (Pretty.Chr c) s = c:s
string_txt (Pretty.Str s1) s2 = s1 ++ s2
string_txt (Pretty.Chr c) s = c : s
string_txt (Pretty.Str s1) s2 = s1 ++ s2
string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2
string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2
-- | Initialize the GHC API. Run this as the first thing in the `runGhc`.
-- This initializes some dyn flags (@ExtendedDefaultRules@,
-- | Initialize the GHC API. Run this as the first thing in the `runGhc`. This initializes some dyn
-- flags (@ExtendedDefaultRules@,
-- @NoMonomorphismRestriction@), sets the target to interpreted, link in
-- memory, sets a reasonable output width, and potentially a few other
-- things. It should be invoked before other functions from this module.
@ -234,27 +221,28 @@ doc sdoc = do
-- (and only the first time) it is called.
initGhci :: GhcMonad m => Maybe String -> m ()
initGhci sandboxPackages = do
-- Initialize dyn flags.
-- Start with -XExtendedDefaultRules and -XNoMonomorphismRestriction.
-- Initialize dyn flags. Start with -XExtendedDefaultRules and -XNoMonomorphismRestriction.
originalFlags <- getSessionDynFlags
let flag = flip xopt_set
unflag = flip xopt_unset
dflags = flag Opt_ExtendedDefaultRules . unflag Opt_MonomorphismRestriction $ originalFlags
pkgConfs = case sandboxPackages of
Nothing -> extraPkgConfs originalFlags
Just path ->
let pkg = PkgConfFile path in
(pkg:) . extraPkgConfs originalFlags
pkgConfs =
case sandboxPackages of
Nothing -> extraPkgConfs originalFlags
Just path ->
let pkg = PkgConfFile path
in (pkg :) . extraPkgConfs originalFlags
void $ setSessionDynFlags $ dflags { hscTarget = HscInterpreted,
ghcLink = LinkInMemory,
pprCols = 300,
extraPkgConfs = pkgConfs }
void $ setSessionDynFlags $ dflags
{ hscTarget = HscInterpreted
, ghcLink = LinkInMemory
, pprCols = 300
, extraPkgConfs = pkgConfs
}
-- | 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.
-- | 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 imports = do
importDecl <- parseImportDecl imports
@ -265,8 +253,8 @@ evalImport imports = do
-- If this is a `hiding` import, remove previous non-`hiding` imports.
oldImps = if isHiddenImport importDecl
then filter (not . importOf importDecl) context
else noImplicit
then filter (not . importOf importDecl) context
else noImplicit
-- Replace the context.
setContext $ IIDecl importDecl : oldImps
@ -285,9 +273,10 @@ evalImport imports = do
-- Check whether an import is hidden.
isHiddenImport :: ImportDecl RdrName -> Bool
isHiddenImport imp = case ideclHiding imp of
Just (True, _) -> True
_ -> False
isHiddenImport imp =
case ideclHiding imp of
Just (True, _) -> True
_ -> False
removeImport :: GhcMonad m => String -> m ()
removeImport moduleName = do
@ -301,8 +290,7 @@ removeImport moduleName = do
isImportOf name (IIModule modName) = name == modName
isImportOf name (IIDecl impDecl) = name == unLoc (ideclName impDecl)
-- | Evaluate a series of declarations.
-- Return all names which were bound by these declarations.
-- | Evaluate a series of declarations. Return all names which were bound by these declarations.
evalDeclarations :: GhcMonad m => String -> m [String]
evalDeclarations decl = do
names <- runDecls decl
@ -321,16 +309,17 @@ cleanUpDuplicateInstances = modifySession $ \hscEnv ->
in hscEnv { hsc_IC = ic { ic_instances = (clsInsts', famInsts) } }
where
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)
-- Only support replacing instances on GHC 7.8 and up
let tpl_tv_set = mkVarSet tpl_tvs
in cls == cls' && isJust (tcMatchTys tpl_tv_set tpl_tys tpl_tys')
-- Only support replacing instances on GHC 7.8 and up
instEq c1 c2
| 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
False
instEq _ _ = False
#endif
-- | Get the type of an expression and convert it to a string.
getType :: GhcMonad m => String -> m String
getType expr = do
@ -342,21 +331,23 @@ getType expr = do
-- | A wrapper around @getInfo@. Return info about each name in the string.
getDescription :: GhcMonad m => String -> m [String]
getDescription str = do
names <- parseName str
names <- parseName str
maybeInfos <- mapM getInfo' names
-- Filter out types that have parents in the same set.
-- GHCi also does this.
-- Filter out types that have parents in the same set. GHCi also does this.
let infos = catMaybes maybeInfos
allNames = mkNameSet $ map (getName . getType) infos
hasParent info = case tyThingParent_maybe (getType info) of
Just parent -> getName parent `elemNameSet` allNames
Nothing -> False
hasParent info =
case tyThingParent_maybe (getType info) of
Just parent -> getName parent `elemNameSet` allNames
Nothing -> False
filteredOutput = filter (not . hasParent) infos
-- Print nicely
mapM (doc . printInfo) filteredOutput
where
#if MIN_VERSION_ghc(7,8,0)
getInfo' = getInfo False
#else
@ -371,15 +362,16 @@ getDescription str = do
#if MIN_VERSION_ghc(7,8,0)
printInfo (thing, fixity, classInstances, famInstances) =
pprTyThingInContextLoc thing $$
showFixity thing fixity $$
vcat (map GHC.pprInstance classInstances) $$
vcat (map GHC.pprFamInst famInstances)
pprTyThingInContextLoc thing $$
showFixity thing fixity $$
vcat (map GHC.pprInstance classInstances) $$
vcat (map GHC.pprFamInst famInstances)
#else
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
showFixity thing fixity =
if fixity == GHC.defaultFixity
then empty
else ppr fixity <+> pprInfixName (getName thing)
then empty
else ppr fixity <+> pprInfixName (getName thing)

37
src/IHaskell/Flags.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE NoImplicitPrelude, DeriveFunctor #-}
module IHaskell.Flags (
IHaskellMode(..),
Argument(..),
@ -16,8 +17,7 @@ import System.Console.CmdArgs.Text
import Data.List (findIndex)
import IHaskell.Types
-- Command line arguments to IHaskell. A set of aruments is annotated with
-- the mode being invoked.
-- Command line arguments to IHaskell. A set of arguments is annotated with the mode being invoked.
data Args = Args IHaskellMode [Argument]
deriving Show
@ -33,13 +33,15 @@ data Argument = ConfFile String -- ^ A file with commands to load at startup
| ConvertLhsStyle (LhsStyle String)
deriving (Eq, Show)
data LhsStyle string = LhsStyle { lhsCodePrefix :: string -- ^ @>@
, lhsOutputPrefix :: string -- ^ @<<@
, lhsBeginCode :: string -- ^ @\\begin{code}@
, lhsEndCode :: string -- ^ @\\end{code}@
, lhsBeginOutput :: string -- ^ @\\begin{verbatim}@
, lhsEndOutput :: string -- ^ @\\end{verbatim}@
}
data LhsStyle string =
LhsStyle
{ lhsCodePrefix :: string -- ^ @>@
, lhsOutputPrefix :: string -- ^ @<<@
, lhsBeginCode :: string -- ^ @\\begin{code}@
, lhsEndCode :: string -- ^ @\\end{code}@
, lhsBeginOutput :: string -- ^ @\\begin{verbatim}@
, lhsEndOutput :: string -- ^ @\\end{verbatim}@
}
deriving (Eq, Functor, Show)
@ -48,15 +50,13 @@ data NotebookFormat = LhsMarkdown
deriving (Eq, Show)
-- Which mode IHaskell is being invoked in.
-- `None` means no mode was specified.
data IHaskellMode = ShowHelp String
| InstallKernelSpec
| ConvertLhs
| Kernel (Maybe String)
deriving (Eq, Show)
-- | Given a list of command-line arguments, return the IHaskell mode and
-- arguments to process.
-- | Given a list of command-line arguments, return the IHaskell mode and arguments to process.
parseFlags :: [String] -> Either String Args
parseFlags flags =
let modeIndex = findIndex (`elem` modeFlags) flags
@ -111,7 +111,8 @@ installKernelSpec =
[ghcLibFlag, kernelDebugFlag, confFlag, helpFlag]
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
kernelArg = flagArg update "<json-kernel-file>"
update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags
@ -154,16 +155,16 @@ convert = mode "convert" (Args ConvertLhs []) description unnamedArg convertFlag
lhsStyleBird, lhsStyleTex :: LhsStyle String
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 =
let descr = "Haskell for Interactive Computing."
let descr = "Haskell for Interactive Computing."
helpStr = showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs
onlyHelp = [flagHelpSimple (add Help)]
noMode = mode "IHaskell" (Args (ShowHelp helpStr) []) descr noArgs onlyHelp in
noMode { modeGroupModes = toGroup allModes }
where
noMode = mode "IHaskell" (Args (ShowHelp helpStr) []) descr noArgs onlyHelp
in noMode { modeGroupModes = toGroup allModes }
where
add flag (Args mode flags) = Args mode $ flag : flags
noArgs = flagArg unexpected ""

59
src/IHaskell/IPython.hs
View File

@ -40,17 +40,20 @@ import qualified GHC.Paths
import IHaskell.Types
import System.Posix.Signals
data KernelSpecOptions = KernelSpecOptions { kernelSpecGhcLibdir :: String -- ^ GHC libdir.
, kernelSpecDebug :: Bool -- ^ Spew debugging output?
, kernelSpecConfFile :: IO (Maybe String) -- ^ Filename of profile JSON file.
}
data KernelSpecOptions =
KernelSpecOptions
{ kernelSpecGhcLibdir :: String -- ^ GHC libdir.
, kernelSpecDebug :: Bool -- ^ Spew debugging output?
, kernelSpecConfFile :: IO (Maybe String) -- ^ Filename of profile JSON file.
}
defaultKernelSpecOptions :: KernelSpecOptions
defaultKernelSpecOptions = KernelSpecOptions { kernelSpecGhcLibdir = GHC.Paths.libdir
, kernelSpecDebug = False
, kernelSpecConfFile = defaultConfFile
}
defaultKernelSpecOptions = KernelSpecOptions
{ kernelSpecGhcLibdir = GHC.Paths.libdir
, kernelSpecDebug = False
, kernelSpecConfFile = defaultConfFile
}
-- | The IPython kernel name.
kernelName :: IsString a => a
kernelName = "haskell"
@ -133,6 +136,7 @@ verifyIPythonVersion = do
Just (1:_) -> oldIPython
Just (0:_) -> oldIPython
_ -> badIPython "Detected IPython, but could not parse version number."
where
badIPython :: Text -> Sh ()
badIPython message = liftIO $ do
@ -140,8 +144,8 @@ verifyIPythonVersion = do
exitFailure
oldIPython = badIPython "Detected old version of IPython. IHaskell requires 3.0.0 or up."
-- | Install an IHaskell kernelspec into the right location.
-- The right location is determined by using `ipython kernelspec install --user`.
-- | Install an IHaskell kernelspec into the right location. The right location is determined by
-- using `ipython kernelspec install --user`.
installKernelspec :: Bool -> KernelSpecOptions -> Sh ()
installKernelspec replace opts = void $ do
ihaskellPath <- getIHaskellPath
@ -155,13 +159,14 @@ installKernelspec replace opts = void $ do
Just file -> ["--conf", file])
++ ["--ghclib", kernelSpecGhcLibdir opts]
let kernelSpec = KernelSpec { kernelDisplayName = "Haskell"
, kernelLanguage = kernelName
, kernelCommand = [ihaskellPath, "kernel", "{connection_file}"] ++ kernelFlags
}
let kernelSpec = KernelSpec
{ kernelDisplayName = "Haskell"
, kernelLanguage = kernelName
, kernelCommand = [ihaskellPath, "kernel", "{connection_file}"] ++ kernelFlags
}
-- Create a temporary directory. Use this temporary directory to make a kernelspec
-- directory; then, shell out to IPython to install this kernelspec directory.
-- Create a temporary directory. Use this temporary directory to make a kernelspec directory; then,
-- shell out to IPython to install this kernelspec directory.
withTmpDir $ \tmp -> do
let kernelDir = tmp </> kernelName
let filename = kernelDir </> "kernel.json"
@ -180,21 +185,20 @@ installKernelspec replace opts = void $ do
kernelSpecCreated :: Sh Bool
kernelSpecCreated = do
Just ipython <- which "ipython"
out <- silently $ run ipython ["kernelspec", "list"]
let kernelspecs = map T.strip $ lines out
return $ kernelName `elem` kernelspecs
Just ipython <- which "ipython"
out <- silently $ run ipython ["kernelspec", "list"]
let kernelspecs = map T.strip $ lines out
return $ kernelName `elem` kernelspecs
-- | Replace "~" with $HOME if $HOME is defined.
-- Otherwise, do nothing.
-- | Replace "~" with $HOME if $HOME is defined. Otherwise, do nothing.
subHome :: String -> IO String
subHome path = shelly $ do
home <- unpack <$> fromMaybe "~" <$> get_env "HOME"
return $ replace "~" home path
-- | Get the path to an executable. If it doensn't exist, fail with an
-- error message complaining about it.
-- | Get the path to an executable. If it doensn't exist, fail with an error message complaining
-- about it.
path :: Text -> Sh FilePath
path exe = do
path <- which $ fromText exe
@ -229,9 +233,8 @@ getIHaskellPath = do
if FS.absolute f
then return $ FS.encodeString f
else
-- Check whether this is a relative path, or just 'IHaskell' with $PATH
-- resolution done by the shell. If it's just 'IHaskell', use the $PATH
-- variable to find where IHaskell lives.
-- Check whether this is a relative path, or just 'IHaskell' with $PATH resolution done by
-- the shell. If it's just 'IHaskell', use the $PATH variable to find where IHaskell lives.
if FS.filename f == f
then do
ihaskellPath <- which "ihaskell"

165
src/IHaskell/Types.hs
View File

@ -1,33 +1,34 @@
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric, ExistentialQuantification #-}
-- | Description : All message type definitions.
module IHaskell.Types (
Message (..),
MessageHeader (..),
MessageType(..),
Username,
Metadata(..),
replyType,
ExecutionState (..),
StreamType(..),
MimeType(..),
DisplayData(..),
EvaluationResult(..),
ExecuteReplyStatus(..),
KernelState(..),
LintStatus(..),
Width, Height,
Display(..),
defaultKernelState,
extractPlain,
kernelOpts,
KernelOpt(..),
IHaskellDisplay(..),
IHaskellWidget(..),
Widget(..),
CommInfo(..),
KernelSpec(..),
) where
Message(..),
MessageHeader(..),
MessageType(..),
Username,
Metadata(..),
replyType,
ExecutionState(..),
StreamType(..),
MimeType(..),
DisplayData(..),
EvaluationResult(..),
ExecuteReplyStatus(..),
KernelState(..),
LintStatus(..),
Width,
Height,
Display(..),
defaultKernelState,
extractPlain,
kernelOpts,
KernelOpt(..),
IHaskellDisplay(..),
IHaskellWidget(..),
Widget(..),
CommInfo(..),
KernelSpec(..),
) where
import ClassyPrelude
import qualified Data.ByteString.Char8 as Char
@ -90,11 +91,11 @@ instance Show Widget where
show _ = "<Widget>"
-- | Wrapper for ipython-kernel's DisplayData which allows sending multiple
-- results from the same expression.
-- | Wrapper for ipython-kernel's DisplayData which allows sending multiple results from the same
-- expression.
data Display = Display [DisplayData]
| ManyDisplay [Display]
deriving (Show, Typeable, Generic)
deriving (Show, Typeable, Generic)
instance Serialize Display
instance Monoid Display where
@ -108,67 +109,73 @@ instance Semigroup Display where
a <> b = a `mappend` b
-- | All state stored in the kernel between executions.
data KernelState = KernelState { getExecutionCounter :: Int
, getLintStatus :: LintStatus -- Whether to use hlint, and what arguments to pass it.
, useSvg :: Bool
, useShowErrors :: Bool
, useShowTypes :: Bool
, usePager :: Bool
, openComms :: Map UUID Widget
, kernelDebug :: Bool
}
data KernelState =
KernelState
{ getExecutionCounter :: Int
, getLintStatus :: LintStatus -- Whether to use hlint, and what arguments to pass it.
, useSvg :: Bool
, useShowErrors :: Bool
, useShowTypes :: Bool
, usePager :: Bool
, openComms :: Map UUID Widget
, kernelDebug :: Bool
}
deriving Show
defaultKernelState :: KernelState
defaultKernelState = KernelState { getExecutionCounter = 1
, getLintStatus = LintOn
, useSvg = True
, useShowErrors = False
, useShowTypes = False
, usePager = True
, openComms = empty
, kernelDebug = False
}
defaultKernelState = KernelState
{ getExecutionCounter = 1
, getLintStatus = LintOn
, useSvg = True
, useShowErrors = False
, useShowTypes = False
, usePager = True
, openComms = empty
, kernelDebug = False
}
-- | Kernel options to be set via `:set` and `:option`.
data KernelOpt = KernelOpt {
getOptionName :: [String], -- ^ Ways to set this option via `:option`
getSetName :: [String], -- ^ Ways to set this option via `:set`
getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel state.
}
data KernelOpt =
KernelOpt
{ getOptionName :: [String] -- ^ Ways to set this option via `:option`
, getSetName :: [String] -- ^ Ways to set this option via `:set`
, getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel
-- state.
}
kernelOpts :: [KernelOpt]
kernelOpts =
[ KernelOpt ["lint"] [] $ \state -> state { getLintStatus = LintOn }
, KernelOpt ["no-lint"] [] $ \state -> state { getLintStatus = LintOff }
, KernelOpt ["svg"] [] $ \state -> state { useSvg = True }
, KernelOpt ["no-svg"] [] $ \state -> state { useSvg = False }
, KernelOpt ["show-types"] ["+t"] $ \state -> state { useShowTypes = True }
, KernelOpt ["no-show-types"] ["-t"] $ \state -> state { useShowTypes = False }
, KernelOpt ["show-errors"] [] $ \state -> state { useShowErrors = True }
, KernelOpt ["no-show-errors"] [] $ \state -> state { useShowErrors = False }
, KernelOpt ["pager"] [] $ \state -> state { usePager = True }
, KernelOpt ["no-pager"] [] $ \state -> state { usePager = False }
[ KernelOpt ["lint"] [] $ \state -> state { getLintStatus = LintOn }
, KernelOpt ["no-lint"] [] $ \state -> state { getLintStatus = LintOff }
, KernelOpt ["svg"] [] $ \state -> state { useSvg = True }
, KernelOpt ["no-svg"] [] $ \state -> state { useSvg = False }
, KernelOpt ["show-types"] ["+t"] $ \state -> state { useShowTypes = True }
, KernelOpt ["no-show-types"] ["-t"] $ \state -> state { useShowTypes = False }
, KernelOpt ["show-errors"] [] $ \state -> state { useShowErrors = True }
, KernelOpt ["no-show-errors"] [] $ \state -> state { useShowErrors = False }
, KernelOpt ["pager"] [] $ \state -> state { usePager = True }
, KernelOpt ["no-pager"] [] $ \state -> state { usePager = False }
]
-- | Current HLint status.
data LintStatus
= LintOn
| LintOff
deriving (Eq, Show)
data LintStatus = LintOn
| LintOff
deriving (Eq, Show)
data CommInfo = CommInfo Widget UUID String deriving Show
data CommInfo = CommInfo Widget UUID String
deriving Show
-- | Output of evaluation.
data EvaluationResult =
-- | An intermediate result which communicates what has been printed thus
-- far.
IntermediateResult {
outputs :: Display -- ^ Display outputs.
}
| FinalResult {
outputs :: Display, -- ^ Display outputs.
pagerOut :: String, -- ^ Text to display in the IPython pager.
startComms :: [CommInfo] -- ^ Comms to start.
}
-- | An intermediate result which communicates what has been printed thus
-- far.
IntermediateResult
{ outputs :: Display -- ^ Display outputs.
}
|
FinalResult
{ outputs :: Display -- ^ Display outputs.
, pagerOut :: String -- ^ Text to display in the IPython pager.
, startComms :: [CommInfo] -- ^ Comms to start.
}
deriving Show

97
src/Main.hs
View File

@ -1,7 +1,8 @@
{-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables, QuasiQuotes #-}
-- | Description : Argument parsing and basic messaging loop, using Haskell
-- Chans to communicate with the ZeroMQ sockets.
module Main where
module Main (main) where
-- Prelude imports.
import ClassyPrelude hiding (last, liftIO, readChan, writeChan)
@ -71,7 +72,7 @@ ihaskell (Args (Kernel (Just filename)) args) = do
showingHelp :: IHaskellMode -> [Argument] -> IO () -> IO ()
showingHelp mode flags act =
case find (==Help) flags of
case find (== Help) flags of
Just _ ->
putStrLn $ pack $ help mode
Nothing ->
@ -114,13 +115,11 @@ runKernel kernelOpts profileSrc = do
-- Receive and reply to all messages on the shell socket.
interpret libdir True $ do
-- Ignore Ctrl-C the first time. This has to go inside the
-- `interpret`, because GHC API resets the signal handlers for some
-- reason (completely unknown to me).
-- Ignore Ctrl-C the first time. This has to go inside the `interpret`, because GHC API resets the
-- signal handlers for some reason (completely unknown to me).
liftIO ignoreCtrlC
-- Initialize the context by evaluating everything we got from the
-- command line flags.
-- Initialize the context by evaluating everything we got from the command line flags.
let noPublish _ = return ()
evaluator line = void $ do
-- Create a new state each time.
@ -131,7 +130,7 @@ runKernel kernelOpts profileSrc = do
confFile <- liftIO $ kernelSpecConfFile kernelOpts
case confFile of
Just filename -> liftIO (readFile $ fpFromString filename) >>= evaluator
Nothing -> return ()
Nothing -> return ()
forever $ do
-- Read the request from the request channel.
@ -140,9 +139,8 @@ runKernel kernelOpts profileSrc = do
-- Create a header for the reply.
replyHeader <- createReplyHeader (header request)
-- We handle comm messages and normal ones separately.
-- The normal ones are a standard request/response style, while comms
-- can be anything, and don't necessarily require a response.
-- We handle comm messages and normal ones separately. The normal ones are a standard
-- request/response style, while comms can be anything, and don't necessarily require a response.
if isCommMessage request
then liftIO $ do
oldState <- takeMVar state
@ -185,35 +183,36 @@ createReplyHeader parent = do
let repType = fromMaybe err (replyType $ msgType parent)
err = error $ "No reply for message " ++ show (msgType parent)
return MessageHeader {
identifiers = identifiers parent,
parentHeader = Just parent,
metadata = Map.fromList [],
messageId = newMessageId,
sessionId = sessionId parent,
username = username parent,
msgType = repType
}
return
MessageHeader
{ identifiers = identifiers parent
, parentHeader = Just parent
, metadata = Map.fromList []
, messageId = newMessageId
, sessionId = sessionId parent
, username = username parent
, msgType = repType
}
-- | Compute a reply to a 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 kernel info reply is a static object (all info is
-- hard coded into the representation of that message type).
-- Reply to kernel info requests with a kernel info reply. No computation needs to be done, as a
-- kernel info reply is a static object (all info is hard coded into the representation of that
-- message type).
replyTo _ KernelInfoRequest{} replyHeader state =
return (state, KernelInfoReply {
header = replyHeader,
language = "haskell",
versionList = ghcVersionInts
})
return
(state, KernelInfoReply
{ header = replyHeader
, 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
-- is happening.
replyTo interface ShutdownRequest{restartPending = restartPending} replyHeader _ = liftIO $ do
writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader restartPending
exitSuccess
-- Reply to a shutdown request by exiting the main thread. Before shutdown, reply to the request to
-- let the frontend know shutdown is happening.
replyTo interface ShutdownRequest { restartPending = restartPending } replyHeader _ = liftIO $ do
writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader restartPending
exitSuccess
-- Reply to an execution request. The reply itself does not require
-- computation, but this causes messages to be sent to the IOPub socket
@ -254,7 +253,8 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
convertSvgToHtml x = x
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
startComm :: CommInfo -> IO ()
@ -334,27 +334,28 @@ replyTo _ req@CompleteRequest{} replyHeader state = do
let start = pos - length matchedText
end = pos
reply = CompleteReply replyHeader (map pack completions) start end Map.empty True
return (state, reply)
reply = CompleteReply replyHeader (map pack completions) start end Map.empty True
return (state, reply)
-- Reply to the object_info_request message. Given an object name, return
-- the associated type calculated by GHC.
replyTo _ ObjectInfoRequest{objectName = oname} replyHeader state = do
-- Reply to the object_info_request message. Given an object name, return the associated type
-- calculated by GHC.
replyTo _ ObjectInfoRequest { objectName = oname } replyHeader state = do
docs <- pack <$> info (unpack oname)
let reply = ObjectInfoReply {
header = replyHeader,
objectName = oname,
objectFound = strip docs /= "",
objectTypeString = docs,
objectDocString = docs
}
let reply = ObjectInfoReply
{ header = replyHeader
, objectName = oname
, objectFound = strip docs /= ""
, objectTypeString = docs
, objectDocString = docs
}
return (state, reply)
-- TODO: Implement history_reply.
replyTo _ HistoryRequest{} replyHeader state = do
let reply = HistoryReply {
header = replyHeader,
historyReply = [] -- FIXME
-- FIXME
historyReply = []
}
return (state, reply)

27
verify_formatting.py
View File

@ -8,8 +8,9 @@ import subprocess
def hindent(contents):
return subprocess.check_output(["hindent", "--style", "gibiansky"],
input=bytes(contents, 'utf-8'))
output = subprocess.check_output(["hindent", "--style", "gibiansky"],
input=bytes(contents, 'utf-8'))
return output.decode('utf-8')
def diff(src1, src2):
@ -20,7 +21,11 @@ def diff(src1, src2):
with open(".tmp2", "w") as f2:
f2.write(src2)
return subprocess.check_output(["diff", ".tmp1", ".tmp2"])
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:
@ -35,6 +40,8 @@ for root, dirnames, filenames in os.walk("src"):
for filename in filenames:
if filename.endswith(".hs"):
sources.append(os.path.join(root, filename))
break
break
hindent_outputs = {}
@ -47,9 +54,15 @@ for source_file in sources:
hindent_outputs[source_file] = (original_source, formatted_source)
diffs = {filename: diff(original, formatted)
for (filename, (original, formatted)) in hindent_outputs.values()}
for (filename, (original, formatted)) in hindent_outputs.items()}
incorrect_formatting = False
for filename, diff in diffs.items():
print(filename)
print('=' * 10)
print(diff)
if diff:
incorrect_formatting = True
print('Incorrect formatting in', filename)
print('=' * 10)
print(diff)
if incorrect_formatting:
sys.exit(1)