Commit 67e98e69 authored by Andrew Gibiansky's avatar Andrew Gibiansky

Adding parser... Modified code from @avogt

parent c0d97abb
...@@ -82,6 +82,7 @@ executable IHaskell ...@@ -82,6 +82,7 @@ executable IHaskell
IHaskell.Eval.Completion IHaskell.Eval.Completion
IHaskell.Eval.Info IHaskell.Eval.Info
IHaskell.Eval.Evaluate IHaskell.Eval.Evaluate
IHaskell.Eval.Parser
IHaskell.IPython IHaskell.IPython
IHaskell.Message.Parser IHaskell.Message.Parser
IHaskell.Message.UUID IHaskell.Message.UUID
...@@ -118,7 +119,8 @@ executable IHaskell ...@@ -118,7 +119,8 @@ executable IHaskell
directory, directory,
here, here,
system-filepath, system-filepath,
text ==0.11.* text ==0.11.*,
mtl == 2.1.*
Test-Suite doctests Test-Suite doctests
Type: exitcode-stdio-1.0 Type: exitcode-stdio-1.0
......
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module IHaskell.Display (
IHaskellDisplay(..),
MimeType(..),
DisplayData(..),
) where
import IHaskell.Types
-- | A class for displayable Haskell types.
class IHaskellDisplay a where
display :: a -> [DisplayData]
...@@ -11,11 +11,12 @@ module IHaskell.Eval.Evaluate ( ...@@ -11,11 +11,12 @@ module IHaskell.Eval.Evaluate (
) where ) where
import ClassyPrelude hiding (liftIO, hGetContents) import ClassyPrelude hiding (liftIO, hGetContents)
import Prelude(putChar, tail, init) import Prelude(putChar, tail, init, (!!))
import Data.List.Utils import Data.List.Utils
import Data.List(findIndex) import Data.List(findIndex)
import Data.String.Utils import Data.String.Utils
import Text.Printf import Text.Printf
import Data.Char as Char
import Language.Haskell.Exts.Parser hiding (parseType) import Language.Haskell.Exts.Parser hiding (parseType)
import Language.Haskell.Exts.Pretty import Language.Haskell.Exts.Pretty
...@@ -27,8 +28,10 @@ import GhcMonad (liftIO) ...@@ -27,8 +28,10 @@ import GhcMonad (liftIO)
import GHC hiding (Stmt, TypeSig) import GHC hiding (Stmt, TypeSig)
import GHC.Paths import GHC.Paths
import Exception hiding (evaluate) import Exception hiding (evaluate)
import Outputable import Outputable
import Packages
import Module
import qualified System.IO.Strict as StrictIO import qualified System.IO.Strict as StrictIO
import IHaskell.Types import IHaskell.Types
...@@ -36,7 +39,7 @@ import IHaskell.Types ...@@ -36,7 +39,7 @@ import IHaskell.Types
data ErrorOccurred = Success | Failure data ErrorOccurred = Success | Failure
debug :: Bool debug :: Bool
debug = False debug = True
ignoreTypePrefixes :: [String] ignoreTypePrefixes :: [String]
ignoreTypePrefixes = ["GHC.Types", "GHC.Base", "GHC.Show", "System.IO", ignoreTypePrefixes = ["GHC.Types", "GHC.Base", "GHC.Show", "System.IO",
...@@ -110,14 +113,35 @@ interpret action = runGhc (Just libdir) $ do ...@@ -110,14 +113,35 @@ interpret action = runGhc (Just libdir) $ do
dflags <- getSessionDynFlags dflags <- getSessionDynFlags
void $ setSessionDynFlags $ dflags { hscTarget = HscInterpreted, ghcLink = LinkInMemory } void $ setSessionDynFlags $ dflags { hscTarget = HscInterpreted, ghcLink = LinkInMemory }
-- Load packages that start with ihaskell-* and aren't just IHaskell.
displayPackages <- liftIO $ do
(dflags, _) <- initPackages dflags
let Just db = pkgDatabase dflags
packageNames = map (packageIdString . packageConfigId) db
initStr = "ihaskell-"
ihaskellPkgs = filter (startswith initStr) packageNames
displayPkgs = filter (isAlpha . (!! (length initStr + 1))) ihaskellPkgs
return displayPkgs
-- Generate import statements all Display modules.
let capitalize :: String -> String
capitalize (first:rest) = Char.toUpper first : rest
importFmt = "import IHaskell.Display.%s"
toImportStmt :: String -> String
toImportStmt = printf importFmt . capitalize . (!! 1) . split "-"
displayImports = map toImportStmt displayPackages
-- Import modules. -- Import modules.
imports <- mapM parseImportDecl globalImports imports <- mapM parseImportDecl $ globalImports ++ displayImports
setContext $ map IIDecl imports setContext $ map IIDecl imports
-- Give a value for `it`. This is required due to the way we handle `it` -- Give a value for `it`. This is required due to the way we handle `it`
-- in the wrapper statements - if it doesn't exist, the first statement -- in the wrapper statements - if it doesn't exist, the first statement
-- will fail. -- will fail.
runStmt "()" RunToCompletion runStmt "putStrLn \"\"" RunToCompletion
-- Run the rest of the interpreter -- Run the rest of the interpreter
action action
...@@ -148,7 +172,7 @@ joinDisplays displays = ...@@ -148,7 +172,7 @@ joinDisplays displays =
plains = filter isPlain displays plains = filter isPlain displays
other = filter (not . isPlain) displays other = filter (not . isPlain) displays
getText (Display PlainText text) = text getText (Display PlainText text) = text
joinedPlains = Display PlainText $ concat $ map getText plains in joinedPlains = Display PlainText $ concatMap getText plains in
case length plains of case length plains of
0 -> other 0 -> other
_ -> joinedPlains : other _ -> joinedPlains : other
...@@ -192,7 +216,7 @@ parseCommands code = joinMultilineDeclarations $ concatMap makeCommands pieces ...@@ -192,7 +216,7 @@ parseCommands code = joinMultilineDeclarations $ concatMap makeCommands pieces
makeCommands str makeCommands str
| isDirective str = [createDirective str] | isDirective str = [createDirective str]
| isImport str = [Import $ strip str] | isImport str = [Import $ strip str]
| length rest > 0 && isTypeDeclaration first = | not (null rest) && isTypeDeclaration first =
let (firstStmt:restStmts) = makeCommands $ unlines rest in let (firstStmt:restStmts) = makeCommands $ unlines rest in
case firstStmt of case firstStmt of
Declaration decl -> Declaration (first ++ decl) : restStmts Declaration decl -> Declaration (first ++ decl) : restStmts
......
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment