integrating flymake.

Browse.hs

@@ -0,0 +1,131 @@
+module Browse (browseModule) where
+
+import Data.Char
+import Data.List
+import Language.Haskell.Exts.Extension
+import Language.Haskell.Exts.Parser hiding (parse)
+import Language.Haskell.Exts.Syntax
+import System.IO
+import System.Process
+import Text.ParserCombinators.Parsec
+
+----------------------------------------------------------------
+
+browseModule :: String -> IO [String]
+browseModule mname = do
+    xs <- getSyntax mname
+    let ys = preprocess xs
+    return $ parseSyntax ys
+
+getSyntax :: String -> IO String
+getSyntax mname  = do
+    (inp,out,_,_) <- runInteractiveProcess "ghci" [] Nothing Nothing
+    mapM_ setFD [inp,out]
+    hPutStrLn inp ":set prompt \"\""
+    hPutStrLn inp "1"
+    hPutStrLn inp $ ":browse " ++ mname
+    hPutStrLn inp ":set prompt \"Prelude>\""
+    hPutStrLn inp ":quit"
+    cs <- hGetContents out
+    return $ unlines $ dropTailer $ dropHeader $ lines $ cs
+  where
+    isNotPrefixOf x y = not (x `isPrefixOf` y)
+    dropHeader xs = tail $ dropWhile (isNotPrefixOf "Prelude>") xs
+    dropTailer = takeWhile (isNotPrefixOf "Prelude>")
+    setFD h = do
+        hSetBinaryMode h False
+        hSetBuffering h LineBuffering
+
+parseSyntax :: String -> [String]
+parseSyntax xs = do
+    let mode = defaultParseMode { extensions = NewQualifiedOperators : ExplicitForall : glasgowExts }
+        res = parseModuleWithMode mode xs
+    case res of
+      ParseOk x       -> identifiers x
+--      e               -> error $ show e
+      _               -> []
+
+
+----------------------------------------------------------------
+
+preprocess :: String -> String
+preprocess cs = case parse remove "remove" cs of
+                  Right a -> a
+                  Left  e -> error $ show e
+
+modName :: Parser String
+modName = do c <- oneOf ['A'..'Z']
+             cs <- many1 $ oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'#"
+             return $ c:cs
+
+anyName :: Parser String
+anyName = many1 $ oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'#"
+
+manyBefore :: Show tok => GenParser tok st a -> GenParser tok st [tok] -> GenParser tok st [a]
+manyBefore p anchor = manyTill p (eof <|> try anc)
+    where
+      anc = do pos <- getPosition
+               s <- anchor
+               ss <- getInput
+               setInput $ s ++ ss
+               setPosition pos
+               return ()
+
+keyword :: Parser String
+keyword = do ms <- modName
+             char '.'
+             return $ ms ++ ['.']
+
+ghcName :: Parser String
+ghcName = do keyword
+             try sep <|> end
+  where
+   sep = do
+       ws <- sepBy1 anyName (char '.')
+       return $ last ws
+   end = do
+       endBy1 anyName (char '.')
+       return ""
+
+nonGhcName :: Parser String
+nonGhcName = do c <- anyChar  -- making this func non-empty
+                cs <- manyBefore anyChar keyword
+                return $ c:cs
+
+remove :: Parser String
+remove = do l1 <- try ghcName <|> return ""
+            l2 <- nonGhcName
+            ll <- many (do x <- ghcName
+                           y <- nonGhcName
+                           return $ x ++ y)
+            return $ concat $ l1 : l2 : ll
+
+----------------------------------------------------------------
+
+identifiers :: Module -> [String]
+identifiers (Module _ _ _ _ _ _ x) = filter hid $ concatMap decl x
+  where
+    hid = all (\c -> isAlphaNum c || elem c "_'")
+
+decl :: Decl -> [String]
+decl (TypeSig _ [x] _) = [name x]
+decl (DataDecl _ _ _ x _ y _) = name x : (map qualConDecl y)
+decl (ClassDecl _ _ x _ _ y) = name x : (map classDecl y)
+decl (TypeDecl _ x _ _) = [name x]
+decl x = [show x]
+
+qualConDecl :: QualConDecl -> String
+qualConDecl (QualConDecl _ _ _ x) = conDecl x
+
+conDecl :: ConDecl -> String
+conDecl (ConDecl (Ident x) _) = x
+conDecl (InfixConDecl _ (Ident x) _) = x
+conDecl x = show x
+
+classDecl :: ClassDecl -> String
+classDecl (ClsDecl x) = concat $ decl x -- xxx
+classDecl x = show x
+
+name :: Name -> String
+name (Symbol x) = x
+name (Ident x) = x

Check.hs

@@ -0,0 +1,25 @@
+module Check (checkSyntax) where
+
+import Control.Applicative
+import Data.Char
+import Data.List
+import System.IO
+import System.Process
+
+----------------------------------------------------------------
+
+checkSyntax :: String -> IO String
+checkSyntax file = do
+    (_,_,herr,_) <- runInteractiveProcess "ghc" ["--make","-Wall",file] Nothing Nothing
+    refine <$> hGetContents herr
+  where
+   refine = unfoldLines start . map (dropWhile isSpace) . filter (/="") . lines
+   start = (file `isPrefixOf`)
+
+unfoldLines :: (String -> Bool) -> [String] -> String
+unfoldLines p = drop 1 . unfold
+  where
+    unfold [] = "\n"
+    unfold (l:ls)
+      | p l       = ('\n':l) ++ unfold ls
+      | otherwise = l ++ " " ++ unfold ls

GHCMod.hs

@@ -1,25 +1,27 @@
 module Main where
 
+import Browse
+import Check
+import Control.Applicative
 import Control.Exception hiding (try)
-import Data.Char
 import Data.List
-import Language.Haskell.Exts.Extension
+import List
-import Language.Haskell.Exts.Parser hiding (parse)
-import Language.Haskell.Exts.Syntax
 import Prelude hiding (catch)
 import System.Console.GetOpt
-import System.Environment
+import System.Directory
+import System.Environment (getArgs)
+import System.FilePath
 import System.IO
-import System.Process
+import System.Posix.Env
-import Text.ParserCombinators.Parsec
 
 ----------------------------------------------------------------
 
 usage :: String
-usage =    "ghc-mod version 0.1.0\n"
+usage =    "ghc-mod version 0.2.0\n"
         ++ "Usage:\n"
         ++ "\t ghc-mod list\n"
         ++ "\t ghc-mod browse <module>\n"
+        ++ "\t ghc-mod check <HaskellFile>\n"
         ++ "\t ghc-mod help\n"
 
 ----------------------------------------------------------------
@@ -41,105 +43,39 @@ parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])
 parseArgs spec argv
     = case getOpt Permute spec argv of
         (o,n,[]  ) -> (foldl (flip id) defaultOptions o, n)
-        (_,_,errs) -> error (concat errs ++ usageInfo usage argspec)
+        (_,_,errs) -> error $ concat errs ++ usageInfo usage argspec
 
 ----------------------------------------------------------------
 
 main :: IO ()
 main = flip catch handler $ do
     args <- getArgs
+    setPath
     let (opt,cmdArg) = parseArgs argspec args
         transform = if optToLisp opt then toLisp else toPlain
-    ll <- case cmdArg !! 0 of
+        refine = transform . nub . sort
-            cmd | cmd == "browse" -> browseModule $ cmdArg !! 1
+    case cmdArg !! 0 of
-                | cmd == "list"   -> listModules
+      cmd | cmd == "browse" -> refine <$> browseModule (cmdArg !! 1) >>= putStr
-            _                     -> error usage
+          | cmd == "list"   -> refine <$> listModules >>= putStr
-    putStr $ transform $ nub $ sort $ ll
+          | cmd == "check"  -> checkSyntax (cmdArg !! 1) >>= putStr
+      _                     -> error usage
+    hFlush stdout
   where
     handler :: ErrorCall -> IO ()
     handler _ = putStr usage
 
-----------------------------------------------------------------
+setPath :: IO ()
-
+setPath = do
-browseModule :: String -> IO [String]
+  home <- getHomeDirectory
-browseModule mname = do
+  mpath <- getEnv "PATH"
-    xs <- getSyntax mname
+  let path = maybe "/usr/bin:/bin" id mpath
-    let ys = preprocess xs
+      newpath = "/usr/local/bin:/opt/local/bin:"
-    return $ parseSyntax ys
+             ++ (home </> ".cabal/bin") ++ ":"
-
+             ++ (home </> "bin") ++ ":"
-getSyntax :: String -> IO String
+             ++ path
-getSyntax mname  = do
+  setEnv "PATH" newpath True
-    (inp,out,_,_) <- runInteractiveProcess "ghci" [] Nothing Nothing
-    mapM_ setFD [inp,out]
-    hPutStrLn inp ":set prompt \"\""
-    hPutStrLn inp "1"
-    hPutStrLn inp $ ":browse " ++ mname
-    hPutStrLn inp ":set prompt \"Prelude>\""
-    hPutStrLn inp ":quit"
-    cs <- hGetContents out
-    return $ unlines $ dropTailer $ dropHeader $ lines $ cs
-  where
-    isNotPrefixOf x y = not (x `isPrefixOf` y)
-    dropHeader xs = tail $ dropWhile (isNotPrefixOf "Prelude>") xs
-    dropTailer = takeWhile (isNotPrefixOf "Prelude>")
-    setFD h = do
-        hSetBinaryMode h False
-        hSetBuffering h LineBuffering
-
-parseSyntax :: String -> [String]
-parseSyntax xs = do
-    let mode = defaultParseMode { extensions = NewQualifiedOperators : ExplicitForall : glasgowExts }
-        res = parseModuleWithMode mode xs
-    case res of
-      ParseOk x       -> identifiers x
---      e               -> error $ show e
-      _               -> []
 
 ----------------------------------------------------------------
-
-listModules :: IO [String]
-listModules = do
-  cs <- getDump
-  return $ exposedModules cs
-
-getDump :: IO String
-getDump = do
-  (_,hout,_,_) <- runInteractiveProcess "ghc-pkg" ["dump"] Nothing Nothing
-  hGetContents hout
-
-exposedModules :: String -> [String]
-exposedModules cs = let ls = unfoldLines cs
-                        ns = values "name: " ls
-                        ms = values "exposed-modules: " ls
-                        zs = zip ns ms
-                        xs = filter (\(nm,_) -> nm `notElem` ["ghc", "ghc-prim", "rts", "integer"]) zs
-                        ss = map snd xs
-                    in filter (\x -> not ("GHC" `isPrefixOf` x)) $ concatMap words ss
-
-values :: String -> [String] -> [String]
-values tag ls = let len = length tag
-                    fs = filter (tag `isPrefixOf`) ls
-                in map (drop len) fs
-
-----------------------------------------------------------------
-
-unfoldLines :: String -> [String]
-unfoldLines xs = self xs
-    where
-      splitNL = break (== '\n')
-      self "" = []
-      self s  = let (l, s') = splitNL s
-                in case s' of
-                     []          -> [l]
-                     (_:' ':s'') -> cont s'' l
-                     (_:s'')     -> l : self s''
-      cont s a = let (l, s') = splitNL $ dropWhile (== ' ') s
-                     a' = a ++ " " ++ l
-                 in case s' of
-                      []          -> [a']
-                      (_:' ':s'') -> cont s'' a'
-                      (_:s'')     -> a' : self s''
-
 toLisp :: [String] -> String
 toLisp ms = "(" ++ unwords quoted ++ ")\n"
     where
@@ -148,87 +84,3 @@ toLisp ms = "(" ++ unwords quoted ++ ")\n"
 
 toPlain :: [String] -> String
 toPlain = unlines
-
-----------------------------------------------------------------
-
-preprocess :: String -> String
-preprocess cs = case parse remove "remove" cs of
-                  Right a -> a
-                  Left  e -> error $ show e
-
-modName :: Parser String
-modName = do c <- oneOf ['A'..'Z']
-             cs <- many1 $ oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'#"
-             return $ c:cs
-
-anyName :: Parser String
-anyName = many1 $ oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'#"
-
-manyBefore :: Show tok => GenParser tok st a -> GenParser tok st [tok] -> GenParser tok st [a]
-manyBefore p anchor = manyTill p (eof <|> try anc)
-    where
-      anc = do pos <- getPosition
-               s <- anchor
-               ss <- getInput
-               setInput $ s ++ ss
-               setPosition pos
-               return ()
-
-keyword :: Parser String
-keyword = do ms <- modName
-             char '.'
-             return $ ms ++ ['.']
-
-ghcName :: Parser String
-ghcName = do keyword
-             try sep <|> end
-  where
-   sep = do
-       ws <- sepBy1 anyName (char '.')
-       return $ last ws
-   end = do
-       endBy1 anyName (char '.')
-       return ""
-
-nonGhcName :: Parser String
-nonGhcName = do c <- anyChar  -- making this func non-empty
-                cs <- manyBefore anyChar keyword
-                return $ c:cs
-
-remove :: Parser String
-remove = do l1 <- try ghcName <|> return ""
-            l2 <- nonGhcName
-            ll <- many (do x <- ghcName
-                           y <- nonGhcName
-                           return $ x ++ y)
-            return $ concat $ l1 : l2 : ll
-
-----------------------------------------------------------------
-
-identifiers :: Module -> [String]
-identifiers (Module _ _ _ _ _ _ x) = filter hid $ concatMap decl x
-  where
-    hid = all (\c -> isAlphaNum c || elem c "_'")
-
-decl :: Decl -> [String]
-decl (TypeSig _ [x] _) = [name x]
-decl (DataDecl _ _ _ x _ y _) = name x : (map qualConDecl y)
-decl (ClassDecl _ _ x _ _ y) = name x : (map classDecl y)
-decl (TypeDecl _ x _ _) = [name x]
-decl x = [show x]
-
-qualConDecl :: QualConDecl -> String
-qualConDecl (QualConDecl _ _ _ x) = conDecl x
-
-conDecl :: ConDecl -> String
-conDecl (ConDecl (Ident x) _) = x
-conDecl (InfixConDecl _ (Ident x) _) = x
-conDecl x = show x
-
-classDecl :: ClassDecl -> String
-classDecl (ClsDecl x) = concat $ decl x -- xxx
-classDecl x = show x
-
-name :: Name -> String
-name (Symbol x) = x
-name (Ident x) = x

List.hs

@@ -0,0 +1,54 @@
+module List (listModules) where
+
+import Control.Applicative
+import Data.Char
+import Data.List
+import System.IO
+import System.Process
+
+----------------------------------------------------------------
+
+listModules :: IO [String]
+listModules = exposedModules <$> getDump
+
+getDump :: IO String
+getDump = do
+  (_,hout,_,_) <- runInteractiveProcess "ghc-pkg" ["dump"] Nothing Nothing
+  hGetContents hout
+
+exposedModules :: String -> [String]
+exposedModules cs = results
+  where
+    ls = unfoldLines cs
+    ns = values "name: " ls
+    ms = values "exposed-modules: " ls
+    zs = zip ns ms
+    xs = filter (\(nm,_) -> nm `notElem` ["ghc", "ghc-prim", "rts", "integer"]) zs
+    ss = map snd xs
+    results = filter (\x -> not ("GHC" `isPrefixOf` x)) $ concatMap words ss
+
+values :: String -> [String] -> [String]
+values tag ls = value
+  where
+    value = map (drop len) fs
+    len = length tag
+    fs = filter (tag `isPrefixOf`) ls
+
+----------------------------------------------------------------
+
+unfoldLines :: String -> [String]
+unfoldLines xs = self xs
+  where
+    splitNL = break (== '\n')
+    self "" = []
+    self s  = let (l, s') = splitNL s
+              in case s' of
+                []          -> [l]
+                (_:' ':s'') -> cont s'' l
+                (_:s'')     -> l : self s''
+    cont s a = let (l, s') = splitNL $ dropWhile (== ' ') s
+                   a' = a ++ " " ++ l
+               in case s' of
+                 []          -> [a']
+                 (_:' ':s'') -> cont s'' a'
+                 (_:s'')     -> a' : self s''

elisp/Makefile

@@ -1,7 +1,6 @@
-SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el
+SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-flymake.el
 EMACS = emacs
 
-
 TEMPFILE  = temp.el
 
 all: $(TEMPFILE) ghc.el

elisp/ghc-comp.el

@@ -66,8 +66,7 @@
      (lambda ()
        (let ((msg (mapconcat 'identity (cons ghc-module-command args) " ")))
 	 (message "Executing \"%s\"..." msg)
-	 (apply 'call-process-shell-command
+	 (apply 'call-process ghc-module-command nil t nil (cons "-l" args))
-		ghc-module-command nil t nil (cons "-l" args))
 	 (message "Executing \"%s\"...done" msg))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

elisp/ghc-flymake.el

@@ -0,0 +1,23 @@
+(require 'flymake)
+
+(defvar ghc-flymake-allowed-file-name-masks
+  '("\\.l?hs$" ghc-flymake-init flymake-simple-cleanup flymake-get-real-file-name))
+
+(defvar ghc-flymake-err-line-patterns
+  '("^\\(.*\\.l?hs\\):\\([0-9]+\\):\\([0-9]+\\):\\(.+\\)" 1 2 3 4))
+
+(add-to-list 'flymake-allowed-file-name-masks
+	     ghc-flymake-allowed-file-name-masks)
+
+(add-to-list 'flymake-err-line-patterns
+	     ghc-flymake-err-line-patterns)
+
+(defun ghc-flymake-init ()
+  (let* ((temp-file (flymake-init-create-temp-buffer-copy
+                     'flymake-create-temp-inplace))
+         (local-file (file-relative-name
+                      temp-file
+                      (file-name-directory buffer-file-name))))
+    (list "ghc-mod" (list "check" local-file))))
+
+(provide 'ghc-flymake)

elisp/ghc.el

@@ -14,11 +14,14 @@
 
 ;;; Code:
 
-(defvar ghc-version "0.1")
+(defvar ghc-version "0.2.0")
+
+;; (eval-when-compile
+;;  (require 'haskell-mode))
 
-;; (require 'haskell-mode)
 (require 'ghc-comp)
 (require 'ghc-doc)
+(require 'ghc-flymake)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
@@ -28,6 +31,10 @@
 (defvar ghc-completion-key "\e\t")
 (defvar ghc-document-key   "\e\C-d")
 (defvar ghc-import-key     "\e\C-m")
+(defvar ghc-check-key      "\e\C-c")
+(defvar ghc-previous-key   "\e\C-p")
+(defvar ghc-next-key       "\e\C-n")
+(defvar ghc-help-key       "\e?")
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
@@ -41,5 +48,11 @@
     (define-key haskell-mode-map ghc-completion-key 'ghc-complete)
     (define-key haskell-mode-map ghc-document-key   'ghc-browse-document)
     (define-key haskell-mode-map ghc-import-key     'ghc-load-module-buffer)
+    (define-key haskell-mode-map ghc-check-key      'flymake-start-syntax-check)
+    (define-key haskell-mode-map ghc-previous-key   'flymake-goto-prev-error)
+    (define-key haskell-mode-map ghc-next-key       'flymake-goto-next-error)
+    (define-key haskell-mode-map ghc-help-key       'flymake-display-err-menu-for-current-line)
     (ghc-comp-init)
     (setq ghc-initialized t)))
+
+(provide 'ghc)

ghc-mod.cabal

@@ -21,9 +21,11 @@ Data-Dir:               elisp
 Data-Files:             Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el
 Executable ghc-mod
   Main-Is:              GHCMod.hs
+  Other-Modules:        List Browse
   GHC-Options:          -Wall
   Build-Depends:        base >= 4.0 && < 10,
-                        parsec, process, haskell-src-exts
+                        parsec, process, haskell-src-exts,
+                        unix, directory, filepath
 Source-Repository head
   Type:                 git
   Location:             git://github.com/kazu-yamamoto/ghc-mod.git