diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -15,7 +15,8 @@ import Data.Maybe (catMaybes) import Data.Typeable import Text.Read (readMaybe) -import System.Environment as System +import System.Environment as System +import System.FilePath.Posix as System -- Haskell interpreter import Language.Haskell.Interpreter hiding (eval, setImports) @@ -28,12 +29,12 @@ import Data.Aeson (toJSON, (.=)) import qualified Data.Aeson as JSON import qualified Data.ByteString.Char8 as B -import Data.Text as T (Text, concat) +import Data.Text as T (Text, concat, pack) import Data.String (fromString) import Web.Scotty -- Interpreter -import Hyper.Internal +import Hyper.Internal as Hyper say = putStrLn @@ -73,6 +74,10 @@ json . result =<< liftIO . setExtensions hint =<< param "query" post "/setImports" $ json . result =<< liftIO . setImports hint =<< param "query" + post "/setSearchPath" $ do + x <- param "query" + y <- param "dir" + json . result =<< (liftIO $ setSearchPath hint x y) post "/loadFiles" $ json . result =<< liftIO . loadFiles hint =<< param "query" post "/eval" $ do @@ -96,14 +101,13 @@ {----------------------------------------------------------------------------- Exported interpreter functions ------------------------------------------------------------------------------} -setImports :: Hint -> [String] -> IO (Result ()) setExtensions :: Hint -> [String] -> IO (Result ()) +setImports :: Hint -> [String] -> IO (Result ()) +setSearchPath :: Hint -> String -> FilePath -> IO (Result ()) loadFiles :: Hint -> [FilePath] -> IO (Result ()) eval :: Hint -> String -> IO (Result Graphic) - -- NOTE: We implicitely load the Prelude and Hyper modules -setImports hint = run hint . Hint.setImports - . (++ ["Prelude", "Hyper"]) . filter (not . null) +-- | Set Haskell language extensions used in the current interpreter session. setExtensions hint xs = run hint $ Hint.set [Hint.languageExtensions Hint.:= ys] where readExtension :: String -> Extension @@ -112,44 +116,88 @@ Just x -> x ys = map readExtension $ filter (not . null) xs -loadFiles hint = run hint . Hint.loadModules . filter (not . null) --- | Evalute an input cell. +-- | Set module imports used in the current interpreter session. +-- NOTE: We implicitly always load the Prelude and Hyper modules +setImports hint = run hint . Hint.setImportsF + . (++ map simpleImport ["Prelude", "Hyper"]) + . map (parseImport . words) + . filter (not . null) + +moduleImport m q = Hint.ModuleImport m q NoImportList + +simpleImport :: String -> Hint.ModuleImport +simpleImport m = moduleImport m NotQualified + +parseImport :: [String] -> Hint.ModuleImport +parseImport (x:xs) = if x == "import" then parse xs else parse (x:xs) + where + parse ("qualified":m:"as":alias:[]) = moduleImport m (QualifiedAs $ Just alias) + parse ("qualified":m:[]) = moduleImport m (QualifiedAs Nothing) + parse (m:"as":alias:[]) = moduleImport m (ImportAs alias) + parse (m:[]) = moduleImport m NotQualified + + +-- | Set search path for loading `.hs` source files +setSearchPath hint xs dir = run hint $ Hint.set [Hint.searchPath Hint.:= paths] + where paths = [if isRelative x then dir x else x | x <- splitSearchPath xs] + +-- | Load `.hs` source files. +loadFiles hint xs = run hint $ do + -- liftIO . print =<< Hint.get Hint.searchPath + Main.finalizeSession -- finalize the old session + Hint.loadModules $ filter (not . null) xs + +-- | Evaluate an input cell. eval hint input = run hint $ do extensions <- Hint.get Hint.languageExtensions - mgs <- forM (parseStmts extensions input) $ \(code, stmt) -> case stmt of - Just (Haskell.Qualifier _ _) -> do - -- NOTE: If it's a simple expression, - -- we wrap results into an implicit call to Hyper.display - m <- Hint.interpret ("Hyper.displayIO " ++ Hint.parens code) (as :: IO Graphic) + mgs <- forM (parsePrompts extensions input) $ \prompt -> case prompt of + Expr code -> do + -- To show the result of an expression, + -- we wrap results into an implicit call to Hyper.display + m <- Hint.interpret ("Hyper.displayIO " ++ Hint.parens code) + (as :: IO Graphic) liftIO $ do g <- m x <- evaluate (force g) -- See NOTE [EvaluateToNF] return $ Just x - _ -> do - -- In all other cases, we simply pass the code on to GHC + Other code -> do + -- Otherwise, there is nothing to show and we pass the code on to GHC Hint.runStmt code return Nothing + TypeOf code -> do + -- Query type information + let pre s = "
" ++ code ++ " :: "++ s ++ "
" + Just . Hyper.html . T.pack . pre <$> Hint.typeOf code + Unknown code -> do + return . Just . string $ "Unknown interpreter command :" ++ code return . combineGraphics $ catMaybes mgs combineGraphics :: [Graphic] -> Graphic combineGraphics xs = Graphic { gHtml = T.concat $ map gHtml xs } -- | Statements that we can evaluate. -type Stmt = Haskell.Stmt Haskell.SrcSpanInfo +type Stmt = Haskell.Stmt Haskell.SrcSpanInfo --- | Parse an input cell into a list of statements to evaluate. -parseStmts :: [Hint.Extension] -> String -> [(String, Maybe Stmt)] -parseStmts extensions = - map parseStmt . map unlines . groupByIndent . stripIndent . lines +data Prompt = Expr String | TypeOf String | Other String | Unknown String + +-- | Parse an input cell into a list of prompts to evaluate +parsePrompts :: [Hint.Extension] -> String -> [Prompt] +parsePrompts extensions = + map parsePrompt . map unlines . groupByIndent . stripIndent . lines where indent xs = if null xs then 0 else length . takeWhile (== ' ') $ head xs stripIndent xs = map (drop $ indent xs) xs groupByIndent = groupBy (\x y -> indent [y] > 0) - parseStmt s = (s, case Haskell.parseStmtWithMode mode s of - Haskell.ParseOk x -> Just x - _ -> Nothing) + parsePrompt code@(':':command) = case words command of + ("type":xs) -> TypeOf $ unwords xs + (x:_) -> Unknown x + [] -> Unknown "(empty)" + parsePrompt code = + case Haskell.parseStmtWithMode mode code :: Haskell.ParseResult Stmt of + Haskell.ParseOk (Haskell.Qualifier _ _) -> Expr code + _ -> Other code exts = map (Haskell.parseExtension . show) extensions mode = Haskell.defaultParseMode { Haskell.extensions = exts } @@ -167,7 +215,34 @@ -} {----------------------------------------------------------------------------- - Interpreter Backend + Internal interpreter functions +------------------------------------------------------------------------------} +-- | +finalizeSession :: Interpreter () +finalizeSession = do + Main.setImportsInternal + Hint.runStmt ("Hyper.Internal.finalizeSession") + +-- | Clear imports and import only the "Hyper.Internal" module qualified. +setImportsInternal :: Interpreter () +setImportsInternal = do + let name = "Hyper.Internal" + Hint.setImportsF [Hint.ModuleImport name (QualifiedAs $ Just name) NoImportList] + +{- +-- | Run an interpreter action with only the "Hyper.Internal" module loaded. +withInternal :: Interpreter a -> Interpreter a +withInternal m = do + xs <- Hint.getLoadedModules + let name = "Hyper.Internal" + Hint.setImportsQ [Hint.ModuleImport name (QualifiedAs $ Just name) NoImportList] + a <- m + Hint.setImportsQ xs + return a +-} + +{----------------------------------------------------------------------------- + Interpreter Thread ------------------------------------------------------------------------------} type Result a = Either InterpreterError a diff --git a/hyper-haskell-server.cabal b/hyper-haskell-server.cabal --- a/hyper-haskell-server.cabal +++ b/hyper-haskell-server.cabal @@ -1,5 +1,5 @@ Name: hyper-haskell-server -Version: 0.2.1.0 +Version: 0.2.3.0 Synopsis: Server back-end for the HyperHaskell graphical Haskell interpreter Description: This package is part of the /HyperHaskell/ project and provides @@ -11,9 +11,9 @@ License-file: LICENSE Author: Heinrich Apfelmus Maintainer: Heinrich Apfelmus -Copyright: (c) Heinrich Apfelmus 2016-2018 +Copyright: (c) Heinrich Apfelmus 2016-2020 -Cabal-version: >= 1.8 +Cabal-version: >= 1.10 Build-type: Simple Source-repository head @@ -22,17 +22,19 @@ subdir: haskell/hyper-haskell-server/ Executable hyper-haskell-server - build-depends: base >= 4.6 && < 4.13 - , aeson (>= 0.7 && < 0.10) || == 0.11.* || (>= 1.0 && < 1.3) - , bytestring >= 0.9 && < 0.11 + build-depends: base >= 4.6 && < 4.15 + , aeson (>= 0.7 && < 0.10) || == 0.11.* || (>= 1.0 && < 1.6) + , bytestring >= 0.9 && < 0.12 , deepseq >= 1.2 && < 1.5 , exceptions >= 0.6 && < 0.11 - , haskell-src-exts >= 1.17 && < 1.21 - , hint >= 0.8 && < 0.9 - , hyper == 0.1.* + , filepath >= 1.0 && < 1.5 + , haskell-src-exts >= 1.17 && < 1.24 + , hint >= 0.8 && < 0.10 + , hyper == 0.2.* , text >= 0.11 && < 1.3 , transformers >= 0.3 && < 0.6 - , scotty >= 0.6 && < 0.12 + , scotty >= 0.6 && < 0.13 ghc-options: -threaded cpp-Options: -DCABAL main-is: Main.hs + default-language: Haskell2010