ghcid (empty) → 0.1

raw patch · 8 files changed

+278/−0 lines, 8 filesdep +basedep +cmdargsdep +directorysetup-changed

Dependencies added: base, cmdargs, directory, filepath, process, time

Files

CHANGES.txt +4/−0
GHCi.hs +105/−0
LICENSE +30/−0
Main.hs +79/−0
README.md +4/−0
Setup.hs +2/−0
Util.hs +16/−0
ghcid.cabal +38/−0

+ CHANGES.txt view

@@ -0,0 +1,4 @@+Changelog for GHCiD++0.1+    Initial version

+ GHCi.hs view

@@ -0,0 +1,105 @@+
+module GHCi(
+    ghci,
+    parseShowModules,
+    Severity(..), Load(..), isMessage, parseLoad
+    ) where
+
+import System.IO
+import System.Process
+import Control.Concurrent
+import Control.Monad
+import Data.Char
+import Data.List
+import Data.Maybe
+import System.FilePath
+import System.Console.CmdArgs.Verbosity
+import Util
+
+
+---------------------------------------------------------------------
+-- IO INTERACTION WITH GHCI
+
+ghci :: String -> IO (String -> IO [String])
+ghci cmd = do
+    (inp, out, err, pid) <- runInteractiveProcess cmd [] Nothing Nothing
+    hSetBuffering out LineBuffering
+    hSetBuffering err LineBuffering
+    hSetBuffering inp LineBuffering
+
+    lock <- newMVar () -- ensure only one person talks to ghci at a time
+    outs <- newMVar [] -- result that is buffering up
+    errs <- newMVar []
+    flush <- newEmptyMVar -- result is moved to push once we see separate
+
+    let prefix = "#~GHCID-PREFIX~#"
+    let separate = "#~GHCID-SEPARATE~#"
+    hPutStrLn inp $ ":set prompt " ++ prefix
+
+    forM_ [(out,outs,"GHCOUT"),(err,errs,"GHCERR")] $ \(h,buf,strm) -> forkIO $ forever $ do
+        s <- hGetLine h
+        whenLoud $ outStrLn $ "%" ++ strm ++ ": " ++ s
+        if s == separate then do
+            outs <- modifyMVar outs $ \s -> return ([], reverse s)
+            errs <- modifyMVar errs $ \s -> return ([], reverse s)
+            putMVar flush $ outs ++ errs
+        else
+            modifyMVar_ buf $ return . (fromMaybe s (stripPrefix prefix s):)
+
+    return $ \s -> withMVar lock $ const $ do
+        whenLoud $ outStrLn $ "%GHCINP: " ++ s
+        hPutStrLn inp $ s ++ "\nputStrLn \"\\n" ++ separate ++ "\""
+        res <- takeMVar flush
+        return res
+
+
+---------------------------------------------------------------------
+-- PARSING THE OUTPUT
+
+-- Main             ( Main.hs, interpreted )
+-- GHCi             ( GHCi.hs, interpreted )
+parseShowModules :: [String] -> [(String, FilePath)]
+parseShowModules xs =
+    [ (takeWhile (not . isSpace) $ dropWhile isSpace a, takeWhile (/= ',') b)
+    | x <- xs, (a,'(':' ':b) <- [break (== '(') x]]
+
+data Severity = Warning | Error deriving (Show,Eq)
+
+data Load
+    = Loading {loadModule :: String, loadFile :: FilePath}
+    | Message
+        {loadSeverity :: Severity
+        ,loadFile :: FilePath
+        ,loadFilePos :: (Int,Int)
+        ,loadMessage :: [String]
+        }
+      deriving Show
+
+isMessage Message{} = True; isMessage _ = False
+
+-- [1 of 2] Compiling GHCi             ( GHCi.hs, interpreted )
+-- GHCi.hs:70:1: Parse error: naked expression at top level
+-- GHCi.hs:72:13:
+--     No instance for (Num ([String] -> [String]))
+--       arising from the literal `1'
+--     Possible fix:
+--       add an instance declaration for (Num ([String] -> [String]))
+--     In the expression: 1
+--     In an equation for `parseLoad': parseLoad = 1
+-- GHCi.hs:81:1: Warning: Defined but not used: `foo'
+parseLoad :: [String] -> [Load]
+parseLoad (('[':xs):rest) =
+    map (uncurry Loading) (parseShowModules [drop 11 $ dropWhile (/= ']') xs]) ++
+    parseLoad rest
+parseLoad (x:xs)
+    | not $ " " `isPrefixOf` x
+    , (file,':':rest) <- break (== ':') x
+    , takeExtension file `elem` [".hs",".lhs"]
+    , (pos,rest) <- span (\x -> x == ':' || isDigit x) rest
+    , [p1,p2] <- map read $ words $ map (\x -> if x == ':' then ' ' else x) pos 
+    , (msg,xs) <- span (isPrefixOf " ") xs
+    , rest <- dropWhile isSpace rest
+    , sev <- if "Warning:" `isPrefixOf` rest then Warning else Error
+    = Message sev file (p1,p2) (x:msg) : parseLoad xs
+parseLoad (x:xs) = parseLoad xs
+parseLoad [] = []

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Neil Mitchell 2014.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Neil Mitchell nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Main.hs view

@@ -0,0 +1,79 @@+{-# LANGUAGE RecordWildCards, DeriveDataTypeable, CPP #-}
+
+module Main(main) where
+
+import Control.Concurrent
+import Control.Monad
+import System.Directory
+import Data.Time.Clock
+import Data.List
+import GHCi
+import Util
+import System.Console.CmdArgs
+
+data Options = Options
+    {command :: String
+    ,height :: Int
+    }
+    deriving (Data,Typeable,Show)
+
+options = cmdArgsMode $ Options
+    {command = "ghci" &= help "Command to run (defaults to ghci)"
+    ,height = 8 &= help "Number of lines to show"
+    } &= verbosity
+
+#if defined(mingw32_HOST_OS)
+foreign import stdcall unsafe "windows.h GetConsoleWindow"
+    c_GetConsoleWindow :: IO Int
+
+foreign import stdcall unsafe "windows.h SetWindowPos"
+    c_SetWindowPos :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> IO Int
+
+c_HWND_TOPMOST = -1
+#endif
+
+main :: IO ()
+main = do
+    Options{..} <- cmdArgsRun options
+#if defined(mingw32_HOST_OS)
+    wnd <- c_GetConsoleWindow
+    c_SetWindowPos wnd c_HWND_TOPMOST 0 0 0 0 3
+#endif
+    ghci <- ghci command
+    let fire msg warnings = do
+            start <- getCurrentTime
+            load <- fmap parseLoad $ ghci msg
+            modsActive <- fmap (map snd . parseShowModules) $ ghci ":show modules"
+            modsLoad <- return $ nub $ map loadFile load
+            whenLoud $ do
+                outStrLn $ "%ACTIVE: " ++ show modsActive
+                outStrLn $ "%LOAD: " ++ show load
+            warn <- return [w | w <- warnings, loadFile w `elem` modsActive, loadFile w `notElem` modsLoad]
+            let msg = prettyOutput height $ filter isMessage load ++ warn
+            outStr $ unlines $ take height $ msg ++ replicate height "" 
+            awaitFiles start $ nub $ modsLoad ++ modsActive
+            fire ":reload" [m | m@Message{..} <- warn ++ load, loadSeverity == Warning]
+    fire "" []
+
+
+prettyOutput :: Int -> [Load] -> [String]
+prettyOutput height [] = ["All good"]
+prettyOutput height xs = take (height - (length msgs * 2)) msg1 ++ concatMap (take 2) msgs
+    where (err, warn) = partition ((==) Error . loadSeverity) xs
+          msg1:msgs = map loadMessage err ++ map loadMessage warn
+
+
+awaitFiles :: UTCTime -> [FilePath] -> IO ()
+awaitFiles base files = do
+    whenLoud $ outStrLn $ "% WAITING: " ++ unwords files
+    new <- mapM getModificationTime files
+    when (all (< base) new) $ recheck new
+    where
+        recheck old = do
+            sleep 0.1
+            new <- mapM getModificationTime files
+            when (old == new) $ recheck new
+
+
+sleep :: Double -> IO ()
+sleep x = threadDelay $ ceiling $ x * 1000000

+ README.md view

@@ -0,0 +1,4 @@+ghcid+=====++Very low feature GHCi based IDE

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ Util.hs view

@@ -0,0 +1,16 @@+
+module Util(outStrLn, outStr) where
+
+import Control.Concurrent
+import System.IO.Unsafe
+
+
+{-# NOINLINE lock #-}
+lock :: MVar ()
+lock = unsafePerformIO $ newMVar ()
+
+outStr :: String -> IO ()
+outStr = withMVar lock . const . putStr
+
+outStrLn :: String -> IO ()
+outStrLn s = outStr $ s ++ "\n"

+ ghcid.cabal view

@@ -0,0 +1,38 @@+cabal-version:      >= 1.10+build-type:         Simple+name:               ghcid+version:            0.1+license:            BSD3+license-file:       LICENSE+category:           Development+author:             Neil Mitchell <ndmitchell@gmail.com>+maintainer:         Neil Mitchell <ndmitchell@gmail.com>+copyright:          Neil Mitchell 2014+synopsis:           GHCi based bare bones IDE+description:+    Bare bones IDE.+homepage:           https://github.com/ndmitchell/ghcid#readme+bug-reports:        https://github.com/ndmitchell/ghcid/issues+tested-with:        GHC==7.8.2, GHC==7.6.3+extra-source-files:+    CHANGES.txt+    README.md++source-repository head+    type:     git+    location: https://github.com/ndmitchell/ghcid.git++executable ghcid+    default-language: Haskell2010+    main-is: Main.hs+    build-depends:+        base == 4.*,+        filepath,+        time,+        directory,+        process >= 1.1,+        cmdargs >= 0.10++    other-modules:+        GHCi+        Util