diff --git a/.gitignore b/.gitignore index 258b6f35..6e63b9eb 100644 --- a/.gitignore +++ b/.gitignore @@ -16,3 +16,5 @@ todo profile/profile.tar .cabal-sandbox cabal.sandbox.config +.tmp1 +.tmp2 diff --git a/src/IHaskell/BrokenPackages.hs b/src/IHaskell/BrokenPackages.hs index 82ffb2d5..1eb6cb63 100644 --- a/src/IHaskell/BrokenPackages.hs +++ b/src/IHaskell/BrokenPackages.hs @@ -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 " diff --git a/src/IHaskell/Convert.hs b/src/IHaskell/Convert.hs index 26da99d5..872e799d 100644 --- a/src/IHaskell/Convert.hs +++ b/src/IHaskell/Convert.hs @@ -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 - - diff --git a/src/IHaskell/Convert/Args.hs b/src/IHaskell/Convert/Args.hs index 0320e73b..99dee256 100644 --- a/src/IHaskell/Convert/Args.hs +++ b/src/IHaskell/Convert/Args.hs @@ -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 diff --git a/src/IHaskell/Convert/IpynbToLhs.hs b/src/IHaskell/Convert/IpynbToLhs.hs index 6f21d14c..0944be54 100644 --- a/src/IHaskell/Convert/IpynbToLhs.hs +++ b/src/IHaskell/Convert/IpynbToLhs.hs @@ -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 diff --git a/src/IHaskell/Convert/LhsToIpynb.hs b/src/IHaskell/Convert/LhsToIpynb.hs index 96124361..fc9b6671 100644 --- a/src/IHaskell/Convert/LhsToIpynb.hs +++ b/src/IHaskell/Convert/LhsToIpynb.hs @@ -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 _ [] = [] - diff --git a/src/IHaskell/Display.hs b/src/IHaskell/Display.hs index df09434a..10a66cb4 100644 --- a/src/IHaskell/Display.hs +++ b/src/IHaskell/Display.hs @@ -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 . +-- An example of creating a display is provided in the +-- . -- 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 - diff --git a/src/IHaskell/Eval/Completion.hs b/src/IHaskell/Eval/Completion.hs index 7d3f20e2..55afd2a3 100644 --- a/src/IHaskell/Eval/Completion.hs +++ b/src/IHaskell/Eval/Completion.hs @@ -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 diff --git a/src/IHaskell/Eval/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs index fcf7a8dc..ebd20a7b 100644 --- a/src/IHaskell/Eval/Evaluate.hs +++ b/src/IHaskell/Eval/Evaluate.hs @@ -145,49 +145,54 @@ interpret libdir allowedStdin action = runGhc (Just libdir) $ do -- Run the rest of the interpreter action +#if MIN_VERSION_ghc(7,10,0) +packageIdString' dflags = packageKeyPackageIdString dflags +#else +packageIdString' dflags = packageIdString +#endif + -- | Initialize our GHC session with imports and a value for 'it'. initializeImports :: Interpreter () initializeImports = do - -- Load packages that start with ihaskell-*, aren't just IHaskell, - -- and depend directly on the right version of the ihaskell library. - -- Also verify that the packages we load are not broken. + -- Load packages that start with ihaskell-*, aren't just IHaskell, and depend directly on the right + -- version of the ihaskell library. Also verify that the packages we load are not broken. dflags <- getSessionDynFlags broken <- liftIO getBrokenPackages displayPackages <- liftIO $ do - (dflags, _) <- initPackages dflags - let Just db = pkgDatabase dflags -#if MIN_VERSION_ghc(7,10,0) - packageIdString = packageKeyPackageIdString dflags -#endif - packageNames = map (packageIdString . packageConfigId) db + (dflags, _) <- initPackages dflags + let Just db = pkgDatabase dflags + packageNames = map (packageIdString' dflags . packageConfigId) db - initStr = "ihaskell-" + initStr = "ihaskell-" - -- Name of the ihaskell package, e.g. "ihaskell-1.2.3.4" - iHaskellPkgName = initStr ++ intercalate "." (map show (versionBranch version)) + -- Name of the ihaskell package, e.g. "ihaskell-1.2.3.4" + iHaskellPkgName = initStr ++ intercalate "." + (map show (versionBranch version)) - dependsOnRight pkg = not $ null $ do - pkg <- db - depId <- depends pkg - dep <- filter ((== depId) . installedPackageId) db - guard (iHaskellPkgName `isPrefixOf` packageIdString (packageConfigId dep)) + dependsOnRight pkg = not $ null $ do + pkg <- db + depId <- depends pkg + dep <- filter ((== depId) . installedPackageId) db + guard + (iHaskellPkgName `isPrefixOf` packageIdString (packageConfigId dep)) - -- ideally the Paths_ihaskell module could provide a way to get the - -- hash too (ihaskell-0.2.0.5-f2bce922fa881611f72dfc4a854353b9), - -- for now. Things will end badly if you also happen to have an - -- ihaskell-0.2.0.5-ce34eadc18cf2b28c8d338d0f3755502 installed. - iHaskellPkg = case filter (== iHaskellPkgName) packageNames of - [x] -> x - [] -> error ("cannot find required haskell library: " ++ iHaskellPkgName) - _ -> error ("multiple haskell packages " ++ iHaskellPkgName ++ " found") + -- ideally the Paths_ihaskell module could provide a way to get the hash too + -- (ihaskell-0.2.0.5-f2bce922fa881611f72dfc4a854353b9), for now. Things will end badly if you also + -- happen to have an ihaskell-0.2.0.5-ce34eadc18cf2b28c8d338d0f3755502 installed. + iHaskellPkg = + case filter (== iHaskellPkgName) packageNames of + [x] -> x + [] -> error + ("cannot find required haskell library: " ++ iHaskellPkgName) + _ -> error + ("multiple haskell packages " ++ iHaskellPkgName ++ " found") - displayPkgs = [ pkgName - | pkgName <- packageNames, - Just (x:_) <- [stripPrefix initStr pkgName], - pkgName `notElem` broken, - isAlpha x] + displayPkgs = [pkgName | pkgName <- packageNames + , Just (x:_) <- [stripPrefix initStr pkgName] + , pkgName `notElem` broken + , isAlpha x] - return displayPkgs + return displayPkgs -- Generate import statements all Display modules. let capitalize :: String -> String @@ -218,21 +223,24 @@ initializeItVariable = do -- statements - if it doesn't exist, the first statement will fail. void $ runStmt "let it = ()" RunToCompletion --- | Publisher for IHaskell outputs. The first argument indicates whether --- this output is final (true) or intermediate (false). +-- | Publisher for IHaskell outputs. The first argument indicates whether this output is final +-- (true) or intermediate (false). type Publisher = (EvaluationResult -> IO ()) -- | Output of a command evaluation. -data EvalOut = EvalOut { - evalStatus :: ErrorOccurred, - evalResult :: Display, - evalState :: KernelState, - evalPager :: String, - evalComms :: [CommInfo] - } +data EvalOut = + EvalOut + { evalStatus :: ErrorOccurred + , evalResult :: Display + , evalState :: KernelState + , evalPager :: String + , evalComms :: [CommInfo] + } cleanString :: String -> String -cleanString x = if allBrackets then clean else str +cleanString x = if allBrackets + then clean + else str where str = strip x l = lines str @@ -242,7 +250,7 @@ cleanString x = if allBrackets then clean else str removeBracket ('>':xs) = xs removeBracket [] = [] -- should never happen: - removeBracket other = error $ "Expected bracket as first char, but got string: " ++ other + removeBracket other = error $ "Expected bracket as first char, but got string: " ++ other -- | Evaluate some IPython input code. evaluate :: KernelState -- ^ The kernel state. @@ -259,24 +267,23 @@ evaluate kernelState code output = do errs = mapMaybe (justError . unloc) cmds updated <- case errs of - -- Only run things if there are no parse errors. - [] -> do - when (getLintStatus kernelState /= LintOff) $ liftIO $ do - lintSuggestions <- lint cmds - unless (noResults lintSuggestions) $ - output $ FinalResult lintSuggestions "" [] + -- Only run things if there are no parse errors. + [] -> do + when (getLintStatus kernelState /= LintOff) $ liftIO $ do + lintSuggestions <- lint cmds + unless (noResults lintSuggestions) $ + output $ FinalResult lintSuggestions "" [] - runUntilFailure kernelState (map unloc cmds ++ [storeItCommand execCount]) - -- Print all parse errors. - errs -> do - forM_ errs $ \err -> do - out <- evalCommand output err kernelState - liftIO $ output $ FinalResult (evalResult out) "" [] - return kernelState + runUntilFailure kernelState (map unloc cmds ++ [storeItCommand execCount]) + -- Print all parse errors. + errs -> do + forM_ errs $ \err -> do + out <- evalCommand output err kernelState + liftIO $ output $ FinalResult (evalResult out) "" [] + return kernelState + + return updated { getExecutionCounter = execCount + 1 } - return updated { - getExecutionCounter = execCount + 1 - } where noResults (Display res) = null res noResults (ManyDisplay res) = all noResults res @@ -286,13 +293,12 @@ evaluate kernelState code output = do runUntilFailure state (cmd:rest) = do evalOut <- evalCommand output cmd state - -- Get displayed channel outputs. - -- Merge them with normal display outputs. + -- Get displayed channel outputs. Merge them with normal display outputs. dispsIO <- extractValue "IHaskell.Display.displayFromChan" dispsMay <- liftIO dispsIO let result = case dispsMay of - Nothing -> evalResult evalOut + Nothing -> evalResult evalOut Just disps -> evalResult evalOut <> disps helpStr = evalPager evalOut @@ -314,7 +320,7 @@ evaluate kernelState code output = do extractValue expr = do compiled <- dynCompileExpr expr case fromDynamic compiled of - Nothing -> error "Expecting value!" + Nothing -> error "Expecting value!" Just result -> return result safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut @@ -322,46 +328,49 @@ safely state = ghandle handler . ghandle sourceErrorHandler where handler :: SomeException -> Interpreter EvalOut handler exception = - return EvalOut { - evalStatus = Failure, - evalResult = displayError $ show exception, - evalState = state, - evalPager = "", - evalComms = [] - } + return + EvalOut + { evalStatus = Failure + , evalResult = displayError $ show exception + , evalState = state + , evalPager = "" + , evalComms = [] + } sourceErrorHandler :: SourceError -> Interpreter EvalOut sourceErrorHandler srcerr = do let msgs = bagToList $ srcErrorMessages srcerr errStrs <- forM msgs $ \msg -> do - shortStr <- doc $ errMsgShortDoc msg - contextStr <- doc $ errMsgExtraInfo msg - return $ unlines [shortStr, contextStr] + shortStr <- doc $ errMsgShortDoc msg + contextStr <- doc $ errMsgExtraInfo msg + return $ unlines [shortStr, contextStr] let fullErr = unlines errStrs - return EvalOut { - evalStatus = Failure, - evalResult = displayError fullErr, - evalState = state, - evalPager = "", - evalComms = [] - } + return + EvalOut + { evalStatus = Failure + , evalResult = displayError fullErr + , evalState = state + , evalPager = "" + , evalComms = [] + } wrapExecution :: KernelState -> Interpreter Display -> Interpreter EvalOut -wrapExecution state exec = safely state $ exec >>= \res -> - return EvalOut { - evalStatus = Success, - evalResult = res, - evalState = state, - evalPager = "", - evalComms = [] - } +wrapExecution state exec = safely state $ + exec >>= \res -> + return + EvalOut + { evalStatus = Success + , evalResult = res + , evalState = state + , evalPager = "" + , evalComms = [] + } --- | Return the display data for this command, as well as whether it --- resulted in an error. +-- | Return the display data for this command, as well as whether it resulted in an error. evalCommand :: Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut evalCommand _ (Import importStr) state = wrapExecution state $ do write state $ "Import: " ++ importStr @@ -369,9 +378,9 @@ evalCommand _ (Import importStr) state = wrapExecution state $ do -- Warn about `it` variable. return $ if "Test.Hspec" `isInfixOf` importStr - then displayError $ "Warning: Hspec is unusable in IHaskell until the resolution of GHC bug #8639." ++ - "\nThe variable `it` is shadowed and cannot be accessed, even in qualified form." - else mempty + then displayError $ "Warning: Hspec is unusable in IHaskell until the resolution of GHC bug #8639." ++ + "\nThe variable `it` is shadowed and cannot be accessed, even in qualified form." + else mempty evalCommand _ (Module contents) state = wrapExecution state $ do write state $ "Module:\n" ++ contents @@ -393,21 +402,21 @@ evalCommand _ (Module contents) state = wrapExecution state $ do -- Remember which modules we've loaded before. importedModules <- getContext - let -- Get the dot-delimited pieces of the module name. + let + -- Get the dot-delimited pieces of the module name. moduleNameOf :: InteractiveImport -> [String] moduleNameOf (IIDecl decl) = split "." . moduleNameString . unLoc . ideclName $ decl moduleNameOf (IIModule imp) = split "." . moduleNameString $ imp - -- Return whether this module prevents the loading of the one we're - -- trying to load. If a module B exist, we cannot load A.B. All - -- modules must have unique last names (where A.B has last name B). + -- Return whether this module prevents the loading of the one we're trying to load. If a module B + -- exist, we cannot load A.B. All modules must have unique last names (where A.B has last name B). -- However, we *can* just reload a module. preventsLoading mod = - let pieces = moduleNameOf mod in - last namePieces == last pieces && namePieces /= pieces + let pieces = moduleNameOf mod + in last namePieces == last pieces && namePieces /= pieces - -- If we've loaded anything with the same last name, we can't use this. - -- Otherwise, GHC tries to load the original *.hs fails and then fails. + -- If we've loaded anything with the same last name, we can't use this. Otherwise, GHC tries to load + -- the original *.hs fails and then fails. case find preventsLoading importedModules of -- If something prevents loading this module, return an error. Just previous -> do @@ -425,7 +434,8 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do -- Find which flags are IHaskell flags, and which are GHC flags let flags = words flagsStr - -- Get the kernel state updater for any IHaskell flag; Nothing for things that aren't IHaskell flags. + -- Get the kernel state updater for any IHaskell flag; Nothing for things that aren't IHaskell + -- flags. ihaskellFlagUpdater :: String -> Maybe (KernelState -> KernelState) ihaskellFlagUpdater flag = getUpdateKernelState <$> find (elem flag . getSetName) kernelOpts @@ -435,41 +445,47 @@ evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do write state $ "GHC Flags: " ++ unwords ghcFlags if null flags - then do + then do flags <- getSessionDynFlags - return EvalOut { - evalStatus = Success, - evalResult = Display [plain $ showSDoc flags $ vcat [pprDynFlags False flags, pprLanguages False flags]], - evalState = state, - evalPager = "", - evalComms = [] - } - else do - -- Apply all IHaskell flag updaters to the state to get the new state - let state' = (foldl' (.) id (map (fromJust . ihaskellFlagUpdater) ihaskellFlags)) state - errs <- setFlags ghcFlags - let display = case errs of - [] -> mempty - _ -> displayError $ intercalate "\n" errs + return + EvalOut + { evalStatus = Success + , evalResult = Display + [ plain $ showSDoc flags $ vcat + [ pprDynFlags False flags + , pprLanguages False flags + ] + ] + , evalState = state + , evalPager = "" + , evalComms = [] + } + else do + -- Apply all IHaskell flag updaters to the state to get the new state + let state' = (foldl' (.) id (map (fromJust . ihaskellFlagUpdater) ihaskellFlags)) state + errs <- setFlags ghcFlags + let display = + case errs of + [] -> mempty + _ -> displayError $ intercalate "\n" errs - -- For -XNoImplicitPrelude, remove the Prelude import. - -- For -XImplicitPrelude, add it back in. - if "-XNoImplicitPrelude" `elem` flags - then evalImport "import qualified Prelude as Prelude" - else - when ("-XImplicitPrelude" `elem` flags) $ do - importDecl <- parseImportDecl "import Prelude" - let implicitPrelude = importDecl { ideclImplicit = True } - imports <- getContext - setContext $ IIDecl implicitPrelude : imports + -- For -XNoImplicitPrelude, remove the Prelude import. For -XImplicitPrelude, add it back in. + if "-XNoImplicitPrelude" `elem` flags + then evalImport "import qualified Prelude as Prelude" + else when ("-XImplicitPrelude" `elem` flags) $ do + importDecl <- parseImportDecl "import Prelude" + let implicitPrelude = importDecl { ideclImplicit = True } + imports <- getContext + setContext $ IIDecl implicitPrelude : imports - return EvalOut { - evalStatus = Success, - evalResult = display, - evalState = state', - evalPager = "", - evalComms = [] - } + return + EvalOut + { evalStatus = Success + , evalResult = display + , evalState = state' + , evalPager = "" + , evalComms = [] + } evalCommand output (Directive SetExtension opts) state = do write state $ "Extension: " ++ opts @@ -546,123 +562,132 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $ "cd":dirs -> do -- Get home so we can replace '~` with it. homeEither <- liftIO (try $ getEnv "HOME" :: IO (Either SomeException String)) - let home = case homeEither of - Left _ -> "~" - Right val -> val + let home = + case homeEither of + Left _ -> "~" + Right val -> val let directory = replace "~" home $ unwords dirs exists <- liftIO $ doesDirectoryExist directory if exists - then do - -- Set the directory in IHaskell native code, for future shell - -- commands. This doesn't set it for user code, though. - liftIO $ setCurrentDirectory directory + then do + -- Set the directory in IHaskell native code, for future shell commands. This doesn't set it for + -- user code, though. + liftIO $ setCurrentDirectory directory - -- Set the directory for user code. - let cmd = printf "IHaskellDirectory.setCurrentDirectory \"%s\"" $ - replace " " "\\ " $ + -- Set the directory for user code. + let cmd = printf "IHaskellDirectory.setCurrentDirectory \"%s\"" $ + replace " " "\\ " $ replace "\"" "\\\"" directory - runStmt cmd RunToCompletion - return mempty - else - return $ displayError $ printf "No such directory: '%s'" directory + runStmt cmd RunToCompletion + return mempty + else return $ displayError $ printf "No such directory: '%s'" directory cmd -> liftIO $ do -#if MIN_VERSION_base(4,8,0) - (pipe, handle) <- createPipe -#else - (readEnd, writeEnd) <- createPipe - handle <- fdToHandle writeEnd - pipe <- fdToHandle readEnd -#endif + (pipe, handle) <- createPipe' let initProcSpec = shell $ unwords cmd - procSpec = initProcSpec { - std_in = Inherit, - std_out = UseHandle handle, - std_err = UseHandle handle - } + procSpec = initProcSpec + { std_in = Inherit + , std_out = UseHandle handle + , std_err = UseHandle handle + } (_, _, _, process) <- createProcess procSpec -- Accumulate output from the process. outputAccum <- liftIO $ newMVar "" -- Start a loop to publish intermediate results. - let - -- Compute how long to wait between reading pieces of the output. - -- `threadDelay` takes an argument of microseconds. - ms = 1000 - delay = 100 * ms + let + -- Compute how long to wait between reading pieces of the output. `threadDelay` takes an + -- argument of microseconds. + ms = 1000 + delay = 100 * ms - -- Maximum size of the output (after which we truncate). - maxSize = 100 * 1000 - incSize = 200 - output str = publish $ IntermediateResult $ Display [plain str] + -- Maximum size of the output (after which we truncate). + maxSize = 100 * 1000 + incSize = 200 + output str = publish $ IntermediateResult $ Display [plain str] - loop = do - -- Wait and then check if the computation is done. - threadDelay delay + loop = do + -- Wait and then check if the computation is done. + threadDelay delay - -- Read next chunk and append to accumulator. - nextChunk <- readChars pipe "\n" incSize - modifyMVar_ outputAccum (return . (++ nextChunk)) - - -- Check if we're done. - exitCode <- getProcessExitCode process - let computationDone = isJust exitCode - - when computationDone $ do - nextChunk <- readChars pipe "" maxSize + -- Read next chunk and append to accumulator. + nextChunk <- readChars pipe "\n" incSize modifyMVar_ outputAccum (return . (++ nextChunk)) - if not computationDone - then do - -- Write to frontend and repeat. - readMVar outputAccum >>= output - loop - else do - out <- readMVar outputAccum - case fromJust exitCode of - ExitSuccess -> return $ Display [plain out] - ExitFailure code -> do - let errMsg = "Process exited with error code " ++ show code - htmlErr = printf "%s" errMsg - return $ Display [plain $ out ++ "\n" ++ errMsg, - html $ printf "%s" out ++ htmlErr] + -- Check if we're done. + exitCode <- getProcessExitCode process + let computationDone = isJust exitCode + + when computationDone $ do + nextChunk <- readChars pipe "" maxSize + modifyMVar_ outputAccum (return . (++ nextChunk)) + + if not computationDone + then do + -- Write to frontend and repeat. + readMVar outputAccum >>= output + loop + else do + out <- readMVar outputAccum + case fromJust exitCode of + ExitSuccess -> return $ Display [plain out] + ExitFailure code -> do + let errMsg = "Process exited with error code " ++ show code + htmlErr = printf "%s" errMsg + return $ Display + [ plain $ out ++ "\n" ++ errMsg + , html $ printf "%s" out ++ htmlErr + ] loop + where +#if MIN_VERSION_base(4,8,0) + createPipe' = createPipe +#else + createPipe' = do + (readEnd, writeEnd) <- createPipe + handle <- fdToHandle writeEnd + pipe <- fdToHandle readEnd + return (pipe, handle) +#endif -- This is taken largely from GHCi's info section in InteractiveUI. evalCommand _ (Directive GetHelp _) state = do write state "Help via :help or :?." - return EvalOut { - evalStatus = Success, - evalResult = Display [out], - evalState = state, - evalPager = "", - evalComms = [] - } - where out = plain $ intercalate "\n" - ["The following commands are available:" - ," :extension - Enable a GHC extension." - ," :extension No - Disable a GHC extension." - ," :type - Print expression type." - ," :info - Print all info for a name." - ," :hoogle - Search for a query on Hoogle." - ," :doc - Get documentation for an identifier via Hogole." - ," :set -XFlag -Wall - Set an option (like ghci)." - ," :option - Set an option." - ," :option no- - Unset an option." - ," :?, :help - Show this help text." - ,"" - ,"Any prefix of the commands will also suffice, e.g. use :ty for :type." - ,"" - ,"Options:" - ," lint – enable or disable linting." - ," svg – use svg output (cannot be resized)." - ," show-types – show types of all bound names" - ," show-errors – display Show instance missing errors normally." - ," pager – use the pager to display results of :info, :doc, :hoogle, etc." - ] + return + EvalOut + { evalStatus = Success + , evalResult = Display [out] + , evalState = state + , evalPager = "" + , evalComms = [] + } + + where + out = plain $ intercalate "\n" + [ "The following commands are available:" + , " :extension - Enable a GHC extension." + , " :extension No - Disable a GHC extension." + , " :type - Print expression type." + , " :info - Print all info for a name." + , " :hoogle - Search for a query on Hoogle." + , " :doc - Get documentation for an identifier via Hogole." + , " :set -XFlag -Wall - Set an option (like ghci)." + , " :option - Set an option." + , " :option no- - Unset an option." + , " :?, :help - Show this help text." + , "" + , "Any prefix of the commands will also suffice, e.g. use :ty for :type." + , "" + , "Options:" + , " lint – enable or disable linting." + , " svg – use svg output (cannot be resized)." + , " show-types – show types of all bound names" + , " show-errors – display Show instance missing errors normally." + , " pager – use the pager to display results of :info, :doc, :hoogle, etc." + ] -- This is taken largely from GHCi's info section in InteractiveUI. evalCommand _ (Directive GetInfo str) state = safely state $ do @@ -673,18 +698,21 @@ evalCommand _ (Directive GetInfo str) state = safely state $ do -- TODO: Make pager work without html by porting to newer architecture let output = unlines (map htmlify strings) htmlify str = - printf "
" str + printf + "
" + str ++ script script = "" - return EvalOut { - evalStatus = Success, - evalResult = mempty, - evalState = state, - evalPager = output, - evalComms = [] - } + return + EvalOut + { evalStatus = Success + , evalResult = mempty + , evalState = state + , evalPager = output + , evalComms = [] + } evalCommand _ (Directive SearchHoogle query) state = safely state $ do results <- liftIO $ Hoogle.search query @@ -711,27 +739,24 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do write state $ "Names: " ++ show allNames - -- Display the types of all bound names if the option is on. - -- This is similar to GHCi :set +t. + -- Display the types of all bound names if the option is on. This is similar to GHCi :set +t. if not $ useShowTypes state - then return $ Display output - else do - -- Get all the type strings. - types <- forM nonItNames $ \name -> do - theType <- showSDocUnqual dflags . ppr <$> exprType name - return $ name ++ " :: " ++ theType + then return $ Display output + else do + -- Get all the type strings. + types <- forM nonItNames $ \name -> do + theType <- showSDocUnqual dflags . ppr <$> exprType name + return $ name ++ " :: " ++ theType - let joined = unlines types - htmled = unlines $ map formatGetType types + let joined = unlines types + htmled = unlines $ map formatGetType types - return $ case extractPlain output of - "" -> Display [html htmled] + return $ + case extractPlain output of + "" -> Display [html htmled] - -- Return plain and html versions. - -- Previously there was only a plain version. - text -> Display - [plain $ joined ++ "\n" ++ text, - html $ htmled ++ mono text] + -- Return plain and html versions. Previously there was only a plain version. + text -> Display [plain $ joined ++ "\n" ++ text, html $ htmled ++ mono text] RunException exception -> throw exception RunBreak{} -> error "Should not break." @@ -739,10 +764,9 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do evalCommand output (Expression expr) state = do write state $ "Expression:\n" ++ expr - -- Try to use `display` to convert our type into the output - -- Dislay If typechecking fails and there is no appropriate - -- typeclass instance, this will throw an exception and thus `attempt` will - -- return False, and we just resort to plaintext. + -- Try to use `display` to convert our type into the output Dislay If typechecking fails and there + -- is no appropriate typeclass instance, this will throw an exception and thus `attempt` will return + -- False, and we just resort to plaintext. let displayExpr = printf "(IHaskell.Display.display (%s))" expr :: String canRunDisplay <- attempt $ exprType displayExpr @@ -751,90 +775,89 @@ evalCommand output (Expression expr) state = do isWidget <- attempt $ exprType widgetExpr -- Check if this is a template haskell declaration - let declExpr = printf "((id :: IHaskellTH.DecsQ -> IHaskellTH.DecsQ) (%s))" expr::String + let declExpr = printf "((id :: IHaskellTH.DecsQ -> IHaskellTH.DecsQ) (%s))" expr :: String let anyExpr = printf "((id :: IHaskellPrelude.Int -> IHaskellPrelude.Int) (%s))" expr :: String isTHDeclaration <- liftM2 (&&) (attempt $ exprType declExpr) (not <$> attempt (exprType anyExpr)) write state $ "Can Display: " ++ show canRunDisplay - write state $ "Is Widget: " ++ show isWidget - write state $ "Is Declaration: " ++ show isTHDeclaration + write state $ "Is Widget: " ++ show isWidget + write state $ "Is Declaration: " ++ show isTHDeclaration - if isTHDeclaration - -- If it typechecks as a DecsQ, we do not want to display the DecsQ, - -- we just want the declaration made. - then do - write state $ "Suppressing display for template haskell declaration" - GHC.runDecls expr - return EvalOut { - evalStatus = Success, - evalResult = mempty, - evalState = state, - evalPager = "", - evalComms = [] - } - else do + if isTHDeclaration + then + -- If it typechecks as a DecsQ, we do not want to display the DecsQ, we just want the + -- declaration made. + do + write state $ "Suppressing display for template haskell declaration" + GHC.runDecls expr + return + EvalOut + { evalStatus = Success + , evalResult = mempty + , evalState = state + , evalPager = "" + , evalComms = [] + } + else do if canRunDisplay - then do - -- Use the display. As a result, `it` is set to the output. - out <- useDisplay displayExpr + then do + -- Use the display. As a result, `it` is set to the output. + out <- useDisplay displayExpr - -- Register the `it` object as a widget. - if isWidget - then registerWidget out - else return out - else do - -- Evaluate this expression as though it's just a statement. - -- The output is bound to 'it', so we can then use it. - evalOut <- evalCommand output (Statement expr) state + -- Register the `it` object as a widget. + if isWidget + then registerWidget out + else return out + else do + -- Evaluate this expression as though it's just a statement. The output is bound to 'it', so we can + -- then use it. + evalOut <- evalCommand output (Statement expr) state - let out = evalResult evalOut - showErr = isShowError out + let out = evalResult evalOut + showErr = isShowError out - -- If evaluation failed, return the failure. If it was successful, we - -- may be able to use the IHaskellDisplay typeclass. - return $ if not showErr || useShowErrors state - then evalOut - else postprocessShowError evalOut + -- If evaluation failed, return the failure. If it was successful, we may be able to use the + -- IHaskellDisplay typeclass. + return $ if not showErr || useShowErrors state + then evalOut + else postprocessShowError evalOut where - -- Try to evaluate an action. Return True if it succeeds and False if - -- it throws an exception. The result of the action is discarded. + -- Try to evaluate an action. Return True if it succeeds and False if it throws an exception. The + -- result of the action is discarded. attempt :: Interpreter a -> Interpreter Bool attempt action = gcatch (action >> return True) failure - where failure :: SomeException -> Interpreter Bool - failure _ = return False + where + failure :: SomeException -> Interpreter Bool + failure _ = return False - -- Check if the error is due to trying to print something that doesn't - -- implement the Show typeclass. + -- Check if the error is due to trying to print something that doesn't implement the Show typeclass. isShowError (ManyDisplay _) = False isShowError (Display errs) = - -- Note that we rely on this error message being 'type cleaned', so - -- that `Show` is not displayed as GHC.Show.Show. This is also very fragile! - startswith "No instance for (Show" msg && - isInfixOf "print it" msg - where msg = extractPlain errs + -- Note that we rely on this error message being 'type cleaned', so that `Show` is not displayed as + -- GHC.Show.Show. This is also very fragile! + startswith "No instance for (Show" msg && + isInfixOf "print it" msg + where + msg = extractPlain errs isSvg (DisplayData mime _) = mime == MimeSvg - + removeSvg :: Display -> Display removeSvg (Display disps) = Display $ filter (not . isSvg) disps removeSvg (ManyDisplay disps) = ManyDisplay $ map removeSvg disps useDisplay displayExpr = do - -- If there are instance matches, convert the object into - -- a Display. We also serialize it into a bytestring. We get - -- the bytestring IO action as a dynamic and then convert back to - -- a bytestring, which we promptly unserialize. Note that - -- attempting to do this without the serialization to binary and - -- back gives very strange errors - all the types match but it - -- refuses to decode back into a Display. - -- Suppress output, so as not to mess up console. - - -- First, evaluate the expression in such a way that we have access to `it`. + -- If there are instance matches, convert the object into a Display. We also serialize it into a + -- bytestring. We get the bytestring IO action as a dynamic and then convert back to a bytestring, + -- which we promptly unserialize. Note that attempting to do this without the serialization to + -- binary and back gives very strange errors - all the types match but it refuses to decode back + -- into a Display. Suppress output, so as not to mess up console. First, evaluate the expression in + -- such a way that we have access to `it`. io <- isIO expr let stmtTemplate = if io - then "it <- (%s)" - else "let { it = %s }" + then "it <- (%s)" + else "let { it = %s }" evalOut <- evalCommand output (Statement $ printf stmtTemplate expr) state case evalStatus evalOut of Failure -> return evalOut @@ -842,7 +865,7 @@ evalCommand output (Expression expr) state = do -- Compile the display data into a bytestring. let compileExpr = "fmap IHaskell.Display.serializeDisplay (IHaskell.Display.display it)" displayedBytestring <- dynCompileExpr compileExpr - + -- Convert from the bytestring into a display. case fromDynamic displayedBytestring of Nothing -> error "Expecting lazy Bytestring" @@ -853,8 +876,8 @@ evalCommand output (Expression expr) state = do Right display -> return $ if useSvg state - then display :: Display - else removeSvg display + then display :: Display + else removeSvg display registerWidget :: EvalOut -> Ghc EvalOut registerWidget evalOut = @@ -872,10 +895,15 @@ evalCommand output (Expression expr) state = do state' = state { openComms = newComms } -- Store the fact that we should start this comm. - return evalOut { - evalComms = CommInfo widget uuid (targetName widget) : evalComms evalOut, - evalState = state' - } + return evalOut + { evalComms = CommInfo + widget + uuid + (targetName + widget) : evalComms + evalOut + , evalState = state' + } isIO expr = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr @@ -884,18 +912,22 @@ evalCommand output (Expression expr) state = do where Display disps = evalResult evalOut text = extractPlain disps - - postprocess (DisplayData MimeHtml _) = html $ printf fmt unshowableType (formatErrorWithClass "err-msg collapse" text) script + + postprocess (DisplayData MimeHtml _) = html $ printf + fmt + unshowableType + (formatErrorWithClass "err-msg collapse" text) + script where fmt = "
Unshowable:%s%s
" - script = unlines [ - "$('#unshowable').on('click', function(e) {", - " e.preventDefault();", - " var $this = $(this);", - " var $collapse = $this.closest('.collapse-group').find('.err-msg');", - " $collapse.collapse('toggle');", - "});" - ] + script = unlines + [ "$('#unshowable').on('click', function(e) {" + , " e.preventDefault();" + , " var $this = $(this);" + , " var $collapse = $this.closest('.collapse-group').find('.err-msg');" + , " $collapse.collapse('toggle');" + , "});" + ] postprocess other = other @@ -903,12 +935,11 @@ evalCommand output (Expression expr) state = do let pieces = words text before = takeWhile (/= "arising") pieces after = init $ unwords $ tail $ dropWhile (/= "(Show") before - + firstChar <- headMay after return $ if firstChar == '(' - then init $ tail after - else after - + then init $ tail after + else after evalCommand _ (Declaration decl) state = wrapExecution state $ do @@ -916,76 +947,73 @@ evalCommand _ (Declaration decl) state = wrapExecution state $ do boundNames <- evalDeclarations decl let nonDataNames = filter (not . isUpper . head) boundNames - -- Display the types of all bound names if the option is on. - -- This is similar to GHCi :set +t. + -- Display the types of all bound names if the option is on. This is similar to GHCi :set +t. if not $ useShowTypes state - then return mempty - else do - -- Get all the type strings. - dflags <- getSessionDynFlags - types <- forM nonDataNames $ \name -> do - theType <- showSDocUnqual dflags . ppr <$> exprType name - return $ name ++ " :: " ++ theType + then return mempty + else do + -- Get all the type strings. + dflags <- getSessionDynFlags + types <- forM nonDataNames $ \name -> do + theType <- showSDocUnqual dflags . ppr <$> exprType name + return $ name ++ " :: " ++ theType - return $ Display [html $ unlines $ map formatGetType types] + return $ Display [html $ unlines $ map formatGetType types] evalCommand _ (TypeSignature sig) state = wrapExecution state $ - -- We purposefully treat this as a "success" because that way execution - -- continues. Empty type signatures are likely due to a parse error later - -- on, and we want that to be displayed. - return $ displayError $ "The type signature " ++ sig ++ - "\nlacks an accompanying binding." + -- We purposefully treat this as a "success" because that way execution continues. Empty type + -- signatures are likely due to a parse error later on, and we want that to be displayed. + return $ displayError $ "The type signature " ++ sig ++ "\nlacks an accompanying binding." evalCommand _ (ParseError loc err) state = do write state "Parse Error." - return EvalOut { - evalStatus = Failure, - evalResult = displayError $ formatParseError loc err, - evalState = state, - evalPager = "", - evalComms = [] - } + return + EvalOut + { evalStatus = Failure + , evalResult = displayError $ formatParseError loc err + , evalState = state + , evalPager = "" + , evalComms = [] + } evalCommand _ (Pragma (PragmaUnsupported pragmaType) pragmas) state = wrapExecution state $ - return $ displayError $ "Pragmas of type " ++ pragmaType ++ - "\nare not supported." + return $ displayError $ "Pragmas of type " ++ pragmaType ++ "\nare not supported." evalCommand output (Pragma PragmaLanguage pragmas) state = do write state $ "Got LANGUAGE pragma " ++ show pragmas evalCommand output (Directive SetExtension $ unwords pragmas) state hoogleResults :: KernelState -> [Hoogle.HoogleResult] -> EvalOut -hoogleResults state results = EvalOut { - evalStatus = Success, - evalResult = mempty, - evalState = state, - evalPager = output, - evalComms = [] - } +hoogleResults state results = + EvalOut + { evalStatus = Success + , evalResult = mempty + , evalState = state + , evalPager = output + , evalComms = [] + } where -- TODO: Make pager work with plaintext fmt = Hoogle.HTML output = unlines $ map (Hoogle.render fmt) results --- Read from a file handle until we hit a delimiter or until we've read --- as many characters as requested +-- Read from a file handle until we hit a delimiter or until we've read as many characters as +-- requested readChars :: Handle -> String -> Int -> IO String -- If we're done reading, return nothing. readChars handle delims 0 = return [] readChars handle delims nchars = do - -- Try reading a single character. It will throw an exception if the - -- handle is already closed. + -- Try reading a single character. It will throw an exception if the handle is already closed. tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char) case tryRead of Right char -> -- If this is a delimiter, stop reading. if char `elem` delims - then return [char] - else do - next <- readChars handle delims (nchars - 1) - return $ char:next + then return [char] + else do + next <- readChars handle delims (nchars - 1) + return $ char : next -- An error occurs at the end of the stream, so just stop reading. Left _ -> return [] @@ -998,13 +1026,7 @@ doLoadModule name modName = do flip gcatch (unload importedModules) $ do -- Compile loaded modules. flags <- getSessionDynFlags -#if MIN_VERSION_ghc(7,8,0) - let objTarget = defaultObjectTarget platform - platform = targetPlatform flags -#else - let objTarget = defaultObjectTarget -#endif - setSessionDynFlags flags{ hscTarget = objTarget } + setSessionDynFlags flags { hscTarget = objTarget flags } -- Clear old targets to be sure. setTargets [] @@ -1025,12 +1047,19 @@ doLoadModule name modName = do -- Switch back to interpreted mode. flags <- getSessionDynFlags - setSessionDynFlags flags{ hscTarget = HscInterpreted } + setSessionDynFlags flags { hscTarget = HscInterpreted } case result of Succeeded -> return mempty - Failed -> return $ displayError $ "Failed to load module " ++ modName + Failed -> return $ displayError $ "Failed to load module " ++ modName + where +#if MIN_VERSION_ghc(7,8,0) + objTarget flags = defaultObjectTarget $ targetPlatform flags +#else + objTarget flags = defaultObjectTarget +#endif + unload :: [InteractiveImport] -> SomeException -> Ghc Display unload imported exception = do print $ show exception @@ -1213,14 +1242,14 @@ formatError = formatErrorWithClass "err-msg" formatErrorWithClass :: String -> ErrMsg -> String formatErrorWithClass cls = - printf "%s" cls . - replace "\n" "
" . - replace useDashV "" . - replace "Ghci" "IHaskell" . - replace "‘interactive:" "‘" . - fixDollarSigns . - rstrip . - typeCleaner + printf "%s" cls . + replace "\n" "
" . + replace useDashV "" . + replace "Ghci" "IHaskell" . + replace "‘interactive:" "‘" . + fixDollarSigns . + rstrip . + typeCleaner where fixDollarSigns = replace "$" "$" useDashV = "\nUse -v to see a list of the files searched for." @@ -1237,7 +1266,7 @@ formatGetType :: String -> String formatGetType = printf "%s" formatType :: String -> Display -formatType typeStr = Display [plain typeStr, html $ formatGetType typeStr] +formatType typeStr = Display [plain typeStr, html $ formatGetType typeStr] displayError :: ErrMsg -> Display displayError msg = Display [plain . typeCleaner $ msg, html $ formatError msg] diff --git a/src/IHaskell/Eval/Hoogle.hs b/src/IHaskell/Eval/Hoogle.hs index bea06598..efb6de33 100644 --- a/src/IHaskell/Eval/Hoogle.hs +++ b/src/IHaskell/Eval/Hoogle.hs @@ -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" "∀" . - replace "=>" "⇒" . - replace "->" "→" . - replace "::" "∷" + replace "forall" "∀" . + replace "=>" "⇒" . + replace "->" "→" . + replace "::" "∷" 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 diff --git a/src/IHaskell/Eval/Info.hs b/src/IHaskell/Eval/Info.hs index e18bafbe..499170a8 100644 --- a/src/IHaskell/Eval/Info.hs +++ b/src/IHaskell/Eval/Info.hs @@ -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 "" diff --git a/src/IHaskell/Eval/Lint.hs b/src/IHaskell/Eval/Lint.hs index 3a3c27e6..bc6ba7ec 100644 --- a/src/IHaskell/Eval/Lint.hs +++ b/src/IHaskell/Eval/Lint.hs @@ -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 = "", - srcSpanStartLine = line, - srcSpanStartColumn = 0, - srcSpanEndLine = line + length (lines blockStr), - srcSpanEndColumn = length $ last $ lines blockStr - } + srcSpan = SrcSpan + { srcSpanFilename = "" + , 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|
${thing}
|] @@ -195,37 +190,33 @@ htmlSuggestions = concatMap toHtml styleId :: String -> String -> String -> String styleId cls id thing = [i|
${thing}
|] - + floating :: String -> String -> String floating dir thing = [i|
${thing}
|] 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 diff --git a/src/IHaskell/Eval/ParseShell.hs b/src/IHaskell/Eval/ParseShell.hs index 87048df9..c6efcabc 100644 --- a/src/IHaskell/Eval/ParseShell.hs +++ b/src/IHaskell/Eval/ParseShell.hs @@ -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") diff --git a/src/IHaskell/Eval/Parser.hs b/src/IHaskell/Eval/Parser.hs index e1757045..9ff9b250 100644 --- a/src/IHaskell/Eval/Parser.hs +++ b/src/IHaskell/Eval/Parser.hs @@ -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" diff --git a/src/IHaskell/Eval/Util.hs b/src/IHaskell/Eval/Util.hs index a3f56f08..e54e590b 100644 --- a/src/IHaskell/Eval/Util.hs +++ b/src/IHaskell/Eval/Util.hs @@ -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". - -- In that case, we disable the extension. + -- Check if a FlagSpec matches "No". 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) diff --git a/src/IHaskell/Flags.hs b/src/IHaskell/Flags.hs index db5bc3d4..5d7604d4 100644 --- a/src/IHaskell/Flags.hs +++ b/src/IHaskell/Flags.hs @@ -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 "" 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 "" diff --git a/src/IHaskell/IPython.hs b/src/IHaskell/IPython.hs index 980fbee8..4bb7f229 100644 --- a/src/IHaskell/IPython.hs +++ b/src/IHaskell/IPython.hs @@ -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" diff --git a/src/IHaskell/Types.hs b/src/IHaskell/Types.hs index 0448b503..97f78974 100644 --- a/src/IHaskell/Types.hs +++ b/src/IHaskell/Types.hs @@ -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 _ = "" --- | 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 diff --git a/src/Main.hs b/src/Main.hs index eb6927a2..c825d0cc 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 $ "" - prependCss (DisplayData MimeHtml html) = DisplayData MimeHtml $ concat ["", html] + prependCss (DisplayData MimeHtml html) = + DisplayData MimeHtml $concat ["", 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) diff --git a/verify_formatting.py b/verify_formatting.py index 4ee482b5..6b5c3c93 100755 --- a/verify_formatting.py +++ b/verify_formatting.py @@ -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)