From 1cc97db24f8cbeb24891d90669cb8313ace4360d Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 8 Feb 2016 22:34:20 +0200 Subject: [PATCH 01/19] Move the CLI parser definitions into the lib So they can be used by library clients to parse and pass in the appropriate ghc-mod Options. --- .../Haskell/GhcMod}/Options/Commands.hs | 6 +++--- .../Haskell/GhcMod}/Options/DocUtils.hs | 2 +- .../Haskell/GhcMod}/Options/Help.hs | 2 +- .../Haskell/GhcMod/Options}/Options.hs | 12 ++++++------ .../Haskell/GhcMod}/Options/ShellParse.hs | 2 +- .../Haskell/GhcMod/Options}/Version.hs | 2 +- ghc-mod.cabal | 15 ++++++++------- src/GHCMod.hs | 2 +- 8 files changed, 22 insertions(+), 21 deletions(-) rename {src/GHCMod => Language/Haskell/GhcMod}/Options/Commands.hs (98%) rename {src/GHCMod => Language/Haskell/GhcMod}/Options/DocUtils.hs (96%) rename {src/GHCMod => Language/Haskell/GhcMod}/Options/Help.hs (97%) rename {src/GHCMod => Language/Haskell/GhcMod/Options}/Options.hs (95%) rename {src/GHCMod => Language/Haskell/GhcMod}/Options/ShellParse.hs (95%) rename {src/GHCMod => Language/Haskell/GhcMod/Options}/Version.hs (95%) diff --git a/src/GHCMod/Options/Commands.hs b/Language/Haskell/GhcMod/Options/Commands.hs similarity index 98% rename from src/GHCMod/Options/Commands.hs rename to Language/Haskell/GhcMod/Options/Commands.hs index 2e1f60a..b39663a 100644 --- a/src/GHCMod/Options/Commands.hs +++ b/Language/Haskell/GhcMod/Options/Commands.hs @@ -16,15 +16,15 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -module GHCMod.Options.Commands where +module Language.Haskell.GhcMod.Options.Commands where import Options.Applicative import Options.Applicative.Types import Options.Applicative.Builder.Internal import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Read -import GHCMod.Options.DocUtils -import GHCMod.Options.Help +import Language.Haskell.GhcMod.Options.DocUtils +import Language.Haskell.GhcMod.Options.Help type Symbol = String type Expr = String diff --git a/src/GHCMod/Options/DocUtils.hs b/Language/Haskell/GhcMod/Options/DocUtils.hs similarity index 96% rename from src/GHCMod/Options/DocUtils.hs rename to Language/Haskell/GhcMod/Options/DocUtils.hs index 95fad26..c81dec8 100644 --- a/src/GHCMod/Options/DocUtils.hs +++ b/Language/Haskell/GhcMod/Options/DocUtils.hs @@ -14,7 +14,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -module GHCMod.Options.DocUtils ( +module Language.Haskell.GhcMod.Options.DocUtils ( ($$), ($$$), (<=>), diff --git a/src/GHCMod/Options/Help.hs b/Language/Haskell/GhcMod/Options/Help.hs similarity index 97% rename from src/GHCMod/Options/Help.hs rename to Language/Haskell/GhcMod/Options/Help.hs index 9e33194..d43b6fb 100644 --- a/src/GHCMod/Options/Help.hs +++ b/Language/Haskell/GhcMod/Options/Help.hs @@ -15,7 +15,7 @@ -- along with this program. If not, see . {-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-} -module GHCMod.Options.Help where +module Language.Haskell.GhcMod.Options.Help where import Options.Applicative import Options.Applicative.Help.Pretty (Doc) diff --git a/src/GHCMod/Options.hs b/Language/Haskell/GhcMod/Options/Options.hs similarity index 95% rename from src/GHCMod/Options.hs rename to Language/Haskell/GhcMod/Options/Options.hs index 0a2a73e..6f95e02 100644 --- a/src/GHCMod/Options.hs +++ b/Language/Haskell/GhcMod/Options/Options.hs @@ -16,7 +16,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -module GHCMod.Options ( +module Language.Haskell.GhcMod.Options.Options ( parseArgs, parseArgsInteractive, GhcModCommands(..) @@ -29,11 +29,11 @@ import Control.Arrow import Data.Char (toUpper, toLower) import Data.List (intercalate) import Language.Haskell.GhcMod.Read -import GHCMod.Options.Commands -import GHCMod.Version -import GHCMod.Options.DocUtils -import GHCMod.Options.Help -import GHCMod.Options.ShellParse +import Language.Haskell.GhcMod.Options.Commands +import Language.Haskell.GhcMod.Options.Version +import Language.Haskell.GhcMod.Options.DocUtils +import Language.Haskell.GhcMod.Options.Help +import Language.Haskell.GhcMod.Options.ShellParse parseArgs :: IO (Options, GhcModCommands) parseArgs = diff --git a/src/GHCMod/Options/ShellParse.hs b/Language/Haskell/GhcMod/Options/ShellParse.hs similarity index 95% rename from src/GHCMod/Options/ShellParse.hs rename to Language/Haskell/GhcMod/Options/ShellParse.hs index acd609b..a807932 100644 --- a/src/GHCMod/Options/ShellParse.hs +++ b/Language/Haskell/GhcMod/Options/ShellParse.hs @@ -13,7 +13,7 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -module GHCMod.Options.ShellParse (parseCmdLine) where +module Language.Haskell.GhcMod.Options.ShellParse (parseCmdLine) where import Data.Char import Data.List diff --git a/src/GHCMod/Version.hs b/Language/Haskell/GhcMod/Options/Version.hs similarity index 95% rename from src/GHCMod/Version.hs rename to Language/Haskell/GhcMod/Options/Version.hs index 2bf6db2..72d7371 100644 --- a/src/GHCMod/Version.hs +++ b/Language/Haskell/GhcMod/Options/Version.hs @@ -14,7 +14,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -module GHCMod.Version where +module Language.Haskell.GhcMod.Options.Version where import Paths_ghc_mod import Data.Version (showVersion) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 01358b5..def5ce7 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -152,6 +152,13 @@ Library Language.Haskell.GhcMod.Types Language.Haskell.GhcMod.Utils Language.Haskell.GhcMod.World + + Language.Haskell.GhcMod.Options.Options + Language.Haskell.GhcMod.Options.Commands + Language.Haskell.GhcMod.Options.Version + Language.Haskell.GhcMod.Options.DocUtils + Language.Haskell.GhcMod.Options.ShellParse + Language.Haskell.GhcMod.Options.Help Other-Modules: Paths_ghc_mod Utils Data.Binary.Generic @@ -187,6 +194,7 @@ Library , extra == 1.4.* , pipes == 4.1.* , safe < 0.4 && >= 0.3.9 + , optparse-applicative >=0.11.0 && <0.13.0 if impl(ghc < 7.8) Build-Depends: convertible if impl(ghc < 7.5) @@ -198,12 +206,6 @@ Executable ghc-mod Default-Language: Haskell2010 Main-Is: GHCMod.hs Other-Modules: Paths_ghc_mod - , GHCMod.Options - , GHCMod.Options.Commands - , GHCMod.Version - , GHCMod.Options.DocUtils - , GHCMod.Options.ShellParse - , GHCMod.Options.Help GHC-Options: -Wall -fno-warn-deprecations -threaded Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src @@ -217,7 +219,6 @@ Executable ghc-mod , ghc < 7.11 , monad-control ==1.0.* , fclabels ==2.0.* - , optparse-applicative >=0.11.0 && <0.13.0 , ghc-mod Executable ghc-modi diff --git a/src/GHCMod.hs b/src/GHCMod.hs index fdade72..23e40d4 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -19,7 +19,7 @@ import System.Directory (setCurrentDirectory, getAppUserDataDirectory, import System.IO import System.Exit import Text.PrettyPrint hiding ((<>)) -import GHCMod.Options +import Language.Haskell.GhcMod.Options.Options import Prelude ghcModStyle :: Style From b1d123c4b6df5c4edc3c012f968b7cf8204ae06c Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 8 Feb 2016 23:02:31 +0200 Subject: [PATCH 02/19] Fix tests, export parser spec --- Language/Haskell/GhcMod/Options/Options.hs | 3 ++- test/ShellParseSpec.hs | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/Options/Options.hs b/Language/Haskell/GhcMod/Options/Options.hs index 6f95e02..82bbda8 100644 --- a/Language/Haskell/GhcMod/Options/Options.hs +++ b/Language/Haskell/GhcMod/Options/Options.hs @@ -19,7 +19,8 @@ module Language.Haskell.GhcMod.Options.Options ( parseArgs, parseArgsInteractive, - GhcModCommands(..) + GhcModCommands(..), + globalArgSpec ) where import Options.Applicative diff --git a/test/ShellParseSpec.hs b/test/ShellParseSpec.hs index 2c5cefe..5111217 100644 --- a/test/ShellParseSpec.hs +++ b/test/ShellParseSpec.hs @@ -1,7 +1,7 @@ module ShellParseSpec where -import GHCMod.Options.ShellParse +import Language.Haskell.GhcMod.Options.ShellParse import Test.Hspec From 8105f14f2cd08f146f4e978ae05226199ec473a9 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Tue, 9 Feb 2016 12:37:56 +0300 Subject: [PATCH 03/19] Add option for stdio encoding, set stdin encoding --- Language/Haskell/GhcMod/Types.hs | 2 ++ src/GHCMod.hs | 10 ++++++---- src/GHCMod/Options.hs | 6 ++++++ 3 files changed, 14 insertions(+), 4 deletions(-) diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 779c5c9..42dac13 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -105,6 +105,7 @@ data Options = Options { -- | GHC command line options set on the @ghc-mod@ command line , optGhcUserOptions :: [GHCOption] , optFileMappings :: [(FilePath, Maybe FilePath)] + , optEncoding :: String } deriving (Show) -- | A default 'Options'. @@ -124,6 +125,7 @@ defaultOptions = Options { } , optGhcUserOptions = [] , optFileMappings = [] + , optEncoding = "UTF-8" } ---------------------------------------------------------------- diff --git a/src/GHCMod.hs b/src/GHCMod.hs index fdade72..531f7de 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -34,9 +34,12 @@ handler = flip gcatches ] main :: IO () -main = do - hSetEncoding stdout utf8 - parseArgs >>= \res@(globalOptions, _) -> +main = + parseArgs >>= \res@(globalOptions, _) -> do + enc <- mkTextEncoding $ optEncoding globalOptions + hSetEncoding stdout enc + hSetEncoding stderr enc + hSetEncoding stdin enc catches (progMain res) [ Handler $ \(e :: GhcModError) -> runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e) @@ -107,7 +110,6 @@ getFileSourceFromStdin = do then fmap (x:) readStdin' else return [] --- Someone please already rewrite the cmdline parsing code *weep* :'( wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m () wrapGhcCommands _opts CmdRoot = gmPutStr =<< rootInfo wrapGhcCommands opts cmd = diff --git a/src/GHCMod/Options.hs b/src/GHCMod/Options.hs index 0a2a73e..40c8fdd 100644 --- a/src/GHCMod/Options.hs +++ b/src/GHCMod/Options.hs @@ -174,6 +174,12 @@ globalArgSpec = Options <=> metavar "OPT" <=> help "Option to be passed to GHC" <*> many fileMappingSpec + <*> strOption + $$ long "encoding" + <=> short 'e' + <=> value "UTF-8" + <=> showDefault + <=> help "I/O encoding" where fileMappingSpec = getFileMapping . splitOn '=' <$> strOption From 98b2e4dac265086447ba20f381f6d97cc1c4db46 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Tue, 9 Feb 2016 12:42:47 +0300 Subject: [PATCH 04/19] Since a backend option, remove encoding short opt --- src/GHCMod/Options.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/GHCMod/Options.hs b/src/GHCMod/Options.hs index 40c8fdd..e654c7e 100644 --- a/src/GHCMod/Options.hs +++ b/src/GHCMod/Options.hs @@ -176,7 +176,6 @@ globalArgSpec = Options <*> many fileMappingSpec <*> strOption $$ long "encoding" - <=> short 'e' <=> value "UTF-8" <=> showDefault <=> help "I/O encoding" From 1c668f20ba195da58692e0308f3cfa963a7b02b3 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Tue, 9 Feb 2016 12:51:28 +0300 Subject: [PATCH 05/19] [Tests] HLint changed some Errors to Warnings --- test/FileMappingSpec.hs | 8 ++++---- test/LintSpec.hs | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/test/FileMappingSpec.hs b/test/FileMappingSpec.hs index 943465a..d6ba1bb 100644 --- a/test/FileMappingSpec.hs +++ b/test/FileMappingSpec.hs @@ -123,13 +123,13 @@ spec = do res <- runD $ do loadMappedFile "File.hs" "File_Redir_Lint.hs" lint defaultLintOpts "File.hs" - res `shouldBe` "File.hs:4:1: Error: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n" + res `shouldBe` "File.hs:4:1: Warning: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n" it "lints in-memory file if one is specified and outputs original filename" $ do withDirectory_ "test/data/file-mapping" $ do res <- runD $ do loadMappedFileSource "File.hs" "func a b = (++) a b\n" lint defaultLintOpts "File.hs" - res `shouldBe` "File.hs:1:1: Error: Eta reduce\NULFound:\NUL func a b = (++) a b\NULWhy not:\NUL func = (++)\n" + res `shouldBe` "File.hs:1:1: Warning: Eta reduce\NULFound:\NUL func a b = (++) a b\NULWhy not:\NUL func = (++)\n" it "shows types of the expression for redirected files" $ do let tdir = "test/data/file-mapping" res <- runD' tdir $ do @@ -184,14 +184,14 @@ spec = do res <- runD $ do loadMappedFile "File.hs" "File_Redir_Lint.hs" lint defaultLintOpts "File.hs" - res `shouldBe` "File.hs:6:1: Error: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n" + res `shouldBe` "File.hs:6:1: Warning: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n" it "lints in-memory file if one is specified and outputs original filename" $ do withDirectory_ "test/data/file-mapping/preprocessor" $ do src <- readFile "File_Redir_Lint.hs" res <- runD $ do loadMappedFileSource "File.hs" src lint defaultLintOpts "File.hs" - res `shouldBe` "File.hs:6:1: Error: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n" + res `shouldBe` "File.hs:6:1: Warning: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n" describe "literate haskell tests" $ do it "checks redirected file if one is specified and outputs original filename" $ do withDirectory_ "test/data/file-mapping/lhs" $ do diff --git a/test/LintSpec.hs b/test/LintSpec.hs index 00876dd..db668ae 100644 --- a/test/LintSpec.hs +++ b/test/LintSpec.hs @@ -9,7 +9,7 @@ spec = do describe "lint" $ do it "can detect a redundant import" $ do res <- runD $ lint defaultLintOpts "test/data/hlint/hlint.hs" - res `shouldBe` "test/data/hlint/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n" + res `shouldBe` "test/data/hlint/hlint.hs:4:8: Warning: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n" context "when no suggestions are given" $ do it "doesn't output an empty line" $ do From 69727f24faf9a3c487d92e3d1ad0d17d70ce1791 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Tue, 9 Feb 2016 16:25:30 +0300 Subject: [PATCH 06/19] Fix output encoding in loadMappedFileSource --- Language/Haskell/GhcMod/FileMapping.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Language/Haskell/GhcMod/FileMapping.hs b/Language/Haskell/GhcMod/FileMapping.hs index 1806017..a3f2f97 100644 --- a/Language/Haskell/GhcMod/FileMapping.hs +++ b/Language/Haskell/GhcMod/FileMapping.hs @@ -46,8 +46,10 @@ loadMappedFileSource :: IOish m -> GhcModT m () loadMappedFileSource from src = do tmpdir <- cradleTempDir `fmap` cradle + enc <- liftIO . mkTextEncoding . optEncoding =<< options to <- liftIO $ do (fn, h) <- openTempFile tmpdir (takeFileName from) + hSetEncoding h enc hPutStr h src hClose h return fn From 5f070b842862096b6172ae3382a5448e094985ad Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 9 Feb 2016 22:24:46 +0200 Subject: [PATCH 07/19] Rebalance between lib and exe --- Language/Haskell/GhcMod/Options/Options.hs | 45 ----------- ghc-mod.cabal | 7 +- src/GHCMod.hs | 1 + src/GHCMod/Options.hs | 77 +++++++++++++++++++ .../GhcMod => src/GHCMod}/Options/Commands.hs | 2 +- .../GHCMod}/Options/ShellParse.hs | 2 +- .../GhcMod/Options => src/GHCMod}/Version.hs | 2 +- test/ShellParseSpec.hs | 2 +- 8 files changed, 86 insertions(+), 52 deletions(-) create mode 100644 src/GHCMod/Options.hs rename {Language/Haskell/GhcMod => src/GHCMod}/Options/Commands.hs (99%) rename {Language/Haskell/GhcMod => src/GHCMod}/Options/ShellParse.hs (95%) rename {Language/Haskell/GhcMod/Options => src/GHCMod}/Version.hs (95%) diff --git a/Language/Haskell/GhcMod/Options/Options.hs b/Language/Haskell/GhcMod/Options/Options.hs index 72cbe69..b0349f0 100644 --- a/Language/Haskell/GhcMod/Options/Options.hs +++ b/Language/Haskell/GhcMod/Options/Options.hs @@ -17,9 +17,6 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module Language.Haskell.GhcMod.Options.Options ( - parseArgs, - parseArgsInteractive, - GhcModCommands(..), globalArgSpec ) where @@ -30,50 +27,8 @@ import Control.Arrow import Data.Char (toUpper, toLower) import Data.List (intercalate) import Language.Haskell.GhcMod.Read -import Language.Haskell.GhcMod.Options.Commands -import Language.Haskell.GhcMod.Options.Version import Language.Haskell.GhcMod.Options.DocUtils import Language.Haskell.GhcMod.Options.Help -import Language.Haskell.GhcMod.Options.ShellParse - -parseArgs :: IO (Options, GhcModCommands) -parseArgs = - execParser opts - where - opts = info (argAndCmdSpec <**> helpVersion) - $$ fullDesc - <=> header "ghc-mod: Happy Haskell Programming" - -parseArgsInteractive :: String -> Either String GhcModCommands -parseArgsInteractive args = - handle $ execParserPure (prefs idm) opts $ parseCmdLine args - where - opts = info interactiveCommandsSpec $$ fullDesc - handle (Success a) = Right a - handle (Failure failure) = - Left $ fst $ renderFailure failure "" - handle _ = Left "Completion invoked" - -helpVersion :: Parser (a -> a) -helpVersion = - helper - <*> abortOption (InfoMsg ghcModVersion) - $$ long "version" - <=> help "Print the version of the program." - <*> argument r - $$ value id - <=> metavar "" - where - r :: ReadM (a -> a) - r = do - v <- readerAsk - case v of - "help" -> readerAbort ShowHelpText - "version" -> readerAbort $ InfoMsg ghcModVersion - _ -> return id - -argAndCmdSpec :: Parser (Options, GhcModCommands) -argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec splitOn :: Eq a => a -> [a] -> ([a], [a]) splitOn c = second (drop 1) . break (==c) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index def5ce7..1e74c23 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -154,10 +154,7 @@ Library Language.Haskell.GhcMod.World Language.Haskell.GhcMod.Options.Options - Language.Haskell.GhcMod.Options.Commands - Language.Haskell.GhcMod.Options.Version Language.Haskell.GhcMod.Options.DocUtils - Language.Haskell.GhcMod.Options.ShellParse Language.Haskell.GhcMod.Options.Help Other-Modules: Paths_ghc_mod Utils @@ -206,6 +203,9 @@ Executable ghc-mod Default-Language: Haskell2010 Main-Is: GHCMod.hs Other-Modules: Paths_ghc_mod + , GHCMod.Options.Commands + , GHCMod.Options.ShellParse + , GHCMod.Version GHC-Options: -Wall -fno-warn-deprecations -threaded Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src @@ -219,6 +219,7 @@ Executable ghc-mod , ghc < 7.11 , monad-control ==1.0.* , fclabels ==2.0.* + , optparse-applicative >=0.11.0 && <0.13.0 , ghc-mod Executable ghc-modi diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 4a71f61..f67e9b9 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -20,6 +20,7 @@ import System.IO import System.Exit import Text.PrettyPrint hiding ((<>)) import Language.Haskell.GhcMod.Options.Options +import GHCMod.Options import Prelude ghcModStyle :: Style diff --git a/src/GHCMod/Options.hs b/src/GHCMod/Options.hs new file mode 100644 index 0000000..b7b13d0 --- /dev/null +++ b/src/GHCMod/Options.hs @@ -0,0 +1,77 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Nikolay Yakimov +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +module GHCMod.Options ( + parseArgs, + parseArgsInteractive, + GhcModCommands(..), +) where + +import Options.Applicative +import Options.Applicative.Types +import Language.Haskell.GhcMod.Types +-- import Control.Arrow +-- import Data.Char (toUpper, toLower) +-- import Data.List (intercalate) +-- import Language.Haskell.GhcMod.Read +import GHCMod.Options.Commands +import GHCMod.Version +import Language.Haskell.GhcMod.Options.DocUtils +-- import Language.Haskell.GhcMod.Options.Help +import Language.Haskell.GhcMod.Options.Options +import GHCMod.Options.ShellParse + +parseArgs :: IO (Options, GhcModCommands) +parseArgs = + execParser opts + where + opts = info (argAndCmdSpec <**> helpVersion) + $$ fullDesc + <=> header "ghc-mod: Happy Haskell Programming" + +parseArgsInteractive :: String -> Either String GhcModCommands +parseArgsInteractive args = + handle $ execParserPure (prefs idm) opts $ parseCmdLine args + where + opts = info interactiveCommandsSpec $$ fullDesc + handle (Success a) = Right a + handle (Failure failure) = + Left $ fst $ renderFailure failure "" + handle _ = Left "Completion invoked" + +helpVersion :: Parser (a -> a) +helpVersion = + helper + <*> abortOption (InfoMsg ghcModVersion) + $$ long "version" + <=> help "Print the version of the program." + <*> argument r + $$ value id + <=> metavar "" + where + r :: ReadM (a -> a) + r = do + v <- readerAsk + case v of + "help" -> readerAbort ShowHelpText + "version" -> readerAbort $ InfoMsg ghcModVersion + _ -> return id + +argAndCmdSpec :: Parser (Options, GhcModCommands) +argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec + diff --git a/Language/Haskell/GhcMod/Options/Commands.hs b/src/GHCMod/Options/Commands.hs similarity index 99% rename from Language/Haskell/GhcMod/Options/Commands.hs rename to src/GHCMod/Options/Commands.hs index b39663a..a2ab3c0 100644 --- a/Language/Haskell/GhcMod/Options/Commands.hs +++ b/src/GHCMod/Options/Commands.hs @@ -16,7 +16,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -module Language.Haskell.GhcMod.Options.Commands where +module GHCMod.Options.Commands where import Options.Applicative import Options.Applicative.Types diff --git a/Language/Haskell/GhcMod/Options/ShellParse.hs b/src/GHCMod/Options/ShellParse.hs similarity index 95% rename from Language/Haskell/GhcMod/Options/ShellParse.hs rename to src/GHCMod/Options/ShellParse.hs index a807932..acd609b 100644 --- a/Language/Haskell/GhcMod/Options/ShellParse.hs +++ b/src/GHCMod/Options/ShellParse.hs @@ -13,7 +13,7 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -module Language.Haskell.GhcMod.Options.ShellParse (parseCmdLine) where +module GHCMod.Options.ShellParse (parseCmdLine) where import Data.Char import Data.List diff --git a/Language/Haskell/GhcMod/Options/Version.hs b/src/GHCMod/Version.hs similarity index 95% rename from Language/Haskell/GhcMod/Options/Version.hs rename to src/GHCMod/Version.hs index 72d7371..2bf6db2 100644 --- a/Language/Haskell/GhcMod/Options/Version.hs +++ b/src/GHCMod/Version.hs @@ -14,7 +14,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -module Language.Haskell.GhcMod.Options.Version where +module GHCMod.Version where import Paths_ghc_mod import Data.Version (showVersion) diff --git a/test/ShellParseSpec.hs b/test/ShellParseSpec.hs index 5111217..2c5cefe 100644 --- a/test/ShellParseSpec.hs +++ b/test/ShellParseSpec.hs @@ -1,7 +1,7 @@ module ShellParseSpec where -import Language.Haskell.GhcMod.Options.ShellParse +import GHCMod.Options.ShellParse import Test.Hspec From b02dfb9ce3043e216c4ae75e778b8574c11d34d5 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 9 Feb 2016 22:34:25 +0200 Subject: [PATCH 08/19] Cleaning up --- ghc-mod.cabal | 3 ++- src/GHCMod.hs | 1 - src/GHCMod/Options.hs | 7 +------ 3 files changed, 3 insertions(+), 8 deletions(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 1e74c23..deb1a38 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -203,9 +203,10 @@ Executable ghc-mod Default-Language: Haskell2010 Main-Is: GHCMod.hs Other-Modules: Paths_ghc_mod + , GHCMod.Options , GHCMod.Options.Commands - , GHCMod.Options.ShellParse , GHCMod.Version + , GHCMod.Options.ShellParse GHC-Options: -Wall -fno-warn-deprecations -threaded Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src diff --git a/src/GHCMod.hs b/src/GHCMod.hs index f67e9b9..531f7de 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -19,7 +19,6 @@ import System.Directory (setCurrentDirectory, getAppUserDataDirectory, import System.IO import System.Exit import Text.PrettyPrint hiding ((<>)) -import Language.Haskell.GhcMod.Options.Options import GHCMod.Options import Prelude diff --git a/src/GHCMod/Options.hs b/src/GHCMod/Options.hs index b7b13d0..c3cf263 100644 --- a/src/GHCMod/Options.hs +++ b/src/GHCMod/Options.hs @@ -19,20 +19,15 @@ module GHCMod.Options ( parseArgs, parseArgsInteractive, - GhcModCommands(..), + GhcModCommands(..) ) where import Options.Applicative import Options.Applicative.Types import Language.Haskell.GhcMod.Types --- import Control.Arrow --- import Data.Char (toUpper, toLower) --- import Data.List (intercalate) --- import Language.Haskell.GhcMod.Read import GHCMod.Options.Commands import GHCMod.Version import Language.Haskell.GhcMod.Options.DocUtils --- import Language.Haskell.GhcMod.Options.Help import Language.Haskell.GhcMod.Options.Options import GHCMod.Options.ShellParse From 9b2f4dbb8bb4501e18b6f939d2738fb377c5582b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 20 Jan 2016 23:39:17 +0100 Subject: [PATCH 09/19] Fix NotCPP for GHC 8 --- NotCPP/Declarations.hs | 28 ++++++++++++++++++++++++++-- NotCPP/LookupValueName.hs | 11 ++++++++++- NotCPP/Utils.hs | 19 ++++++++++++++++--- 3 files changed, 52 insertions(+), 6 deletions(-) diff --git a/NotCPP/Declarations.hs b/NotCPP/Declarations.hs index 1657a68..b57feae 100644 --- a/NotCPP/Declarations.hs +++ b/NotCPP/Declarations.hs @@ -104,18 +104,33 @@ boundNames decl = TySynD n _ _ -> [(TcClsName, n)] ClassD _ n _ _ _ -> [(TcClsName, n)] - FamilyD _ n _ _ -> [(TcClsName, n)] +#if __GLASGOW_HASKELL__ >= 800 + DataD _ n _ _ ctors _ -> +#else DataD _ n _ ctors _ -> +#endif [(TcClsName, n)] ++ map ((,) TcClsName) (conNames `concatMap` ctors) +#if __GLASGOW_HASKELL__ >= 800 + NewtypeD _ n _ _ ctor _ -> +#else NewtypeD _ n _ ctor _ -> +#endif [(TcClsName, n)] ++ map ((,) TcClsName) (conNames ctor) +#if __GLASGOW_HASKELL__ >= 800 + DataInstD _ _n _ _ ctors _ -> +#else DataInstD _ _n _ ctors _ -> +#endif map ((,) TcClsName) (conNames `concatMap` ctors) +#if __GLASGOW_HASKELL__ >= 800 + NewtypeInstD _ _n _ _ ctor _ -> +#else NewtypeInstD _ _n _ ctor _ -> +#endif map ((,) TcClsName) (conNames ctor) InstanceD _ _ty _ -> @@ -131,10 +146,19 @@ boundNames decl = #endif #if __GLASGOW_HASKELL__ >= 708 - ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)] RoleAnnotD _n _ -> error "notcpp: RoleAnnotD not supported yet" #endif +#if __GLASGOW_HASKELL__ >= 704 && __GLASGOW_HASKELL__ < 800 + FamilyD _ n _ _ -> [(TcClsName, n)] +#elif __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 800 + ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)] +#else + OpenTypeFamilyD (TypeFamilyHead n _ _ _) -> [(TcClsName, n)] + ClosedTypeFamilyD (TypeFamilyHead n _ _ _) _ -> [(TcClsName, n)] + +#endif + conNames :: Con -> [Name] conNames con = case con of diff --git a/NotCPP/LookupValueName.hs b/NotCPP/LookupValueName.hs index 72462c2..9132e99 100644 --- a/NotCPP/LookupValueName.hs +++ b/NotCPP/LookupValueName.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP, TemplateHaskell #-} -- | This module uses scope lookup techniques to either export -- 'lookupValueName' from @Language.Haskell.TH@, or define -- its own 'lookupValueName', which attempts to do the @@ -25,8 +25,13 @@ bestValueGuess s = do case mi of Nothing -> no Just i -> case i of +#if __GLASGOW_HASKELL__ >= 800 + VarI n _ _ -> yes n + DataConI n _ _ -> yes n +#else VarI n _ _ _ -> yes n DataConI n _ _ _ -> yes n +#endif _ -> err ["unexpected info:", show i] where no = return Nothing @@ -34,5 +39,9 @@ bestValueGuess s = do err = fail . showString "NotCPP.bestValueGuess: " . unwords $(recover [d| lookupValueName = bestValueGuess |] $ do +#if __GLASGOW_HASKELL__ >= 800 + VarI _ _ _ <- reify (mkName "lookupValueName") +#else VarI _ _ _ _ <- reify (mkName "lookupValueName") +#endif return []) diff --git a/NotCPP/Utils.hs b/NotCPP/Utils.hs index 9da7958..8557c4a 100644 --- a/NotCPP/Utils.hs +++ b/NotCPP/Utils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP, TemplateHaskell #-} module NotCPP.Utils where import Control.Applicative ((<$>)) @@ -24,6 +24,19 @@ recoverMaybe q = recover (return Nothing) (Just <$> q) -- | Returns @'Just' ('VarE' n)@ if the info relates to a value called -- @n@, or 'Nothing' if it relates to a different sort of thing. infoToExp :: Info -> Maybe Exp -infoToExp (VarI n _ _ _) = Just (VarE n) -infoToExp (DataConI n _ _ _) = Just (ConE n) + +#if __GLASGOW_HASKELL__ >= 800 +infoToExp (VarI n _ _) = +#else +infoToExp (VarI n _ _ _) = +#endif + Just (VarE n) + +#if __GLASGOW_HASKELL__ >= 800 +infoToExp (DataConI n _ _) = +#else +infoToExp (DataConI n _ _ _) = +#endif + Just (ConE n) + infoToExp _ = Nothing From b4de82632e710f3b041d9a4e59a230fa6ddb564c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 20 Jan 2016 23:40:35 +0100 Subject: [PATCH 10/19] Relax some upper bounds for GHC 8 --- ghc-mod.cabal | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 01358b5..afe8a52 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -158,24 +158,24 @@ Library System.Directory.ModTime Build-Depends: base < 5 && >= 4.0 , bytestring < 0.11 - , binary < 0.8 && >= 0.5.1.0 + , binary < 0.9 && >= 0.5.1.0 , containers < 0.6 , cabal-helper < 0.7 && >= 0.6.3.0 , deepseq < 1.5 , directory < 1.3 , filepath < 1.5 - , ghc < 7.11 + , ghc < 8.2 , ghc-paths < 0.2 , ghc-syb-utils < 0.3 , hlint < 1.10 && >= 1.9.26 , monad-journal < 0.8 && >= 0.4 , old-time < 1.2 , pretty < 1.2 - , process < 1.3 + , process < 1.5 , syb < 0.7 , temporary < 1.3 - , time < 1.6 - , transformers < 0.5 + , time < 1.7 + , transformers < 0.6 , transformers-base < 0.5 , mtl < 2.3 && >= 2.0 , monad-control < 1.1 && >= 1 @@ -211,10 +211,10 @@ Executable ghc-mod , directory < 1.3 , filepath < 1.5 , pretty < 1.2 - , process < 1.3 + , process < 1.5 , split < 0.3 , mtl < 2.3 && >= 2.0 - , ghc < 7.11 + , ghc < 8.1 , monad-control ==1.0.* , fclabels ==2.0.* , optparse-applicative >=0.11.0 && <0.13.0 @@ -231,13 +231,13 @@ Executable ghc-modi Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src, . Build-Depends: base < 5 && >= 4.0 - , binary < 0.8 && >= 0.5.1.0 + , binary < 0.9 && >= 0.5.1.0 , deepseq < 1.5 , directory < 1.3 , filepath < 1.5 - , process < 1.3 + , process < 1.5 , old-time < 1.2 - , time < 1.6 + , time < 1.7 , ghc-mod Test-Suite doctest From 2e4c2b52280290cd6af58d96c5368ed1ae0ae15f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 14 Feb 2016 08:41:11 +0100 Subject: [PATCH 11/19] Check session validity via equality on DynFlags --- Language/Haskell/GhcMod/DynFlags.hs | 12 +++- Language/Haskell/GhcMod/DynFlagsTH.hs | 97 +++++++++++++++++++++++++++ Language/Haskell/GhcMod/LightGhc.hs | 4 ++ Language/Haskell/GhcMod/Logger.hs | 2 +- Language/Haskell/GhcMod/Target.hs | 38 +++++++---- ghc-mod.cabal | 2 + 6 files changed, 139 insertions(+), 16 deletions(-) create mode 100644 Language/Haskell/GhcMod/DynFlagsTH.hs diff --git a/Language/Haskell/GhcMod/DynFlags.hs b/Language/Haskell/GhcMod/DynFlags.hs index 4d54ae2..09975db 100644 --- a/Language/Haskell/GhcMod/DynFlags.hs +++ b/Language/Haskell/GhcMod/DynFlags.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, TemplateHaskell #-} module Language.Haskell.GhcMod.DynFlags where @@ -10,6 +10,7 @@ import GHC.Paths (libdir) import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.DebugLogger +import Language.Haskell.GhcMod.DynFlagsTH import System.IO.Unsafe (unsafePerformIO) import Prelude @@ -102,7 +103,14 @@ setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing } setNoMaxRelevantBindings = id #endif -deferErrors :: DynFlags -> Ghc DynFlags +deferErrors :: Monad m => DynFlags -> m DynFlags deferErrors df = return $ Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $ Gap.setDeferTypeErrors $ setNoWarningFlags df + +---------------------------------------------------------------- + +deriveEqDynFlags [d| + eqDynFlags :: DynFlags -> DynFlags -> Bool + eqDynFlags = undefined + |] diff --git a/Language/Haskell/GhcMod/DynFlagsTH.hs b/Language/Haskell/GhcMod/DynFlagsTH.hs new file mode 100644 index 0000000..13ac237 --- /dev/null +++ b/Language/Haskell/GhcMod/DynFlagsTH.hs @@ -0,0 +1,97 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE TemplateHaskell #-} +module Language.Haskell.GhcMod.DynFlagsTH where + +import Language.Haskell.TH.Syntax +import Data.Maybe +import Data.Generics.Aliases +import Data.Generics.Schemes +import Packages +import Hooks +import DynFlags + +deriveEqDynFlags :: Q [Dec] -> Q [Dec] +deriveEqDynFlags qds = do + ~(TyConI (DataD [] _ [] [ctor] _ )) <- reify ''DynFlags + let ~(RecC _ fs) = ctor + + a <- newName "a" + b <- newName "b" + + e <- AppE (VarE 'and) . ListE <$> sequence (catMaybes $ map (eq a b) fs) + + tysig@(SigD n _) :_ <- qds + + return $ [tysig, FunD n [Clause [VarP a, VarP b] (NormalB e) []]] + + where + eq :: Name -> Name -> (Name, Strict, Type) -> Maybe (Q Exp) + eq a b (fn@(Name (OccName fon) _), _, ft) + | not isUneqable = Just expr + | otherwise = Nothing + where + isUneqable = everything (||) (mkQ False hasUnEqable) ft + + hasUnEqable ArrowT = True + hasUnEqable (ConT n@(Name (OccName on) _)) + | n == ''LogAction = True + | any (==n) ignoredTypeNames = True + | any (==on) ignoredTypeOccNames = True + hasUnEqable _ = False + + ignoredTypeNames = + [ ''PackageState + , ''Hooks + , ''FlushOut + , ''FlushErr + , ''Settings -- I think these can't cange at runtime + ] + ignoredTypeOccNames = [ "OnOff" ] + + fa = AppE (VarE fn) (VarE a) + fb = AppE (VarE fn) (VarE b) + expr = + case fon of + "language" -> do + eqfn <- [| let eqfn (Just Haskell98) (Just Haskell98) = True + eqfn (Just Haskell2010) (Just Haskell2010) = True + eqfn _ _ = False + in eqfn + |] + return $ AppE (AppE eqfn fa) fb + "rtsOptsEnabled" -> do + eqfn <- [| let eqfn RtsOptsNone RtsOptsNone = True + eqfn RtsOptsSafeOnly RtsOptsSafeOnly = True + eqfn RtsOptsAll RtsOptsAll = True + eqfn _ _ = False + in eqfn + |] + return $ AppE (AppE eqfn fa) fb + + "sigOf" -> do + eqfn <- [| let eqfn NotSigOf NotSigOf = True + eqfn (SigOf a') (SigOf b') = a' == b' + eqfn (SigOfMap a') (SigOfMap b') = a' == b' + eqfn _ _ = False + in eqfn + |] + return $ AppE (AppE eqfn fa) fb + + + _ -> + return $ InfixE (Just fa) (VarE '(==)) (Just fb) diff --git a/Language/Haskell/GhcMod/LightGhc.hs b/Language/Haskell/GhcMod/LightGhc.hs index 18aac05..6c53716 100644 --- a/Language/Haskell/GhcMod/LightGhc.hs +++ b/Language/Haskell/GhcMod/LightGhc.hs @@ -42,3 +42,7 @@ runLightGhc :: HscEnv -> LightGhc a -> IO a runLightGhc env action = do renv <- newIORef env flip runReaderT renv $ unLightGhc action + +runLightGhc' :: IORef HscEnv -> LightGhc a -> IO a +runLightGhc' renv action = do + flip runReaderT renv $ unLightGhc action diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 10ebd5b..36d1995 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -169,6 +169,6 @@ checkErrorPrefix :: String checkErrorPrefix = "Dummy:0:0:Error:" warningAsErrorPrefixes :: [String] -warningAsErrorPrefixes = ["Couldn't match expected type" +warningAsErrorPrefixes = [ "Couldn't match expected type" , "Couldn't match type" , "No instance for"] diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 7985d1a..2e2d1ae 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -66,29 +66,41 @@ runGmPkgGhc action = do withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action initSession :: IOish m - => [GHCOption] -> (DynFlags -> Ghc DynFlags) -> GhcModT m () + => [GHCOption] -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) -> GhcModT m () initSession opts mdf = do s <- gmsGet case gmGhcSession s of - Just GmGhcSession {..} | gmgsOptions /= opts-> do - gmLog GmDebug "initSession" $ text "Flags changed, creating new session" - putNewSession s - Just _ -> return () Nothing -> do gmLog GmDebug "initSession" $ text "Session not initialized, creating new one" putNewSession s + Just GmGhcSession {..} -> do + gmLog GmDebug "initSession" $ text "Flags changed, creating new session" + crdl <- cradle + changed <- liftIO $ runLightGhc' gmgsSession $ do + df <- getSessionDynFlags + ndf <- initDF crdl + return $ ndf `eqDynFlags` df + if changed + then putNewSession s + else return () where - putNewSession s = do - rghc <- (liftIO . newIORef =<< newSession =<< cradle) - gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc } - - newSession Cradle { cradleTempDir } = liftIO $ do - runGhc (Just libdir) $ do + initDF Cradle { cradleTempDir } = do let setDf df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df) _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags + getSessionDynFlags + + putNewSession s = do + rghc <- (liftIO . newIORef =<< newSession) + gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc } + + newSession = do + crdl <- cradle + liftIO $ runGhc (Just libdir) $ do + _ <- initDF crdl getSession + -- | Drop the currently active GHC session, the next that requires a GHC session -- will initialize a new one. dropSession :: IOish m => GhcModT m () @@ -114,7 +126,7 @@ runGmlT fns action = runGmlT' fns return action -- of certain files or modules, with updated GHC flags runGmlT' :: IOish m => [Either FilePath ModuleName] - -> (DynFlags -> Ghc DynFlags) + -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) -> GmlT m a -> GhcModT m a runGmlT' fns mdf action = runGmlTWith fns mdf id action @@ -124,7 +136,7 @@ runGmlT' fns mdf action = runGmlTWith fns mdf id action -- transformation runGmlTWith :: IOish m => [Either FilePath ModuleName] - -> (DynFlags -> Ghc DynFlags) + -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) -> (GmlT m a -> GmlT m b) -> GmlT m a -> GhcModT m b diff --git a/ghc-mod.cabal b/ghc-mod.cabal index afe8a52..0dc2789 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -187,6 +187,8 @@ Library , extra == 1.4.* , pipes == 4.1.* , safe < 0.4 && >= 0.3.9 + , template-haskell + , syb if impl(ghc < 7.8) Build-Depends: convertible if impl(ghc < 7.5) From daeb5018f3c4e79c1ec2cbcacd7e7257bb12ca64 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 14 Feb 2016 08:50:49 +0100 Subject: [PATCH 12/19] Add DynFlagsTH to exposed-modules --- ghc-mod.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 0dc2789..3f673a9 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -117,6 +117,7 @@ Library Language.Haskell.GhcMod.DebugLogger Language.Haskell.GhcMod.Doc Language.Haskell.GhcMod.DynFlags + Language.Haskell.GhcMod.DynFlagsTH Language.Haskell.GhcMod.Error Language.Haskell.GhcMod.FileMapping Language.Haskell.GhcMod.FillSig From 4f289fc4e4c6ae58bae6082c7014d7dbc8cfc68c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 14 Feb 2016 08:59:59 +0100 Subject: [PATCH 13/19] Fix older GHCs --- Language/Haskell/GhcMod/DynFlagsTH.hs | 62 +++++++++++++++++++-------- 1 file changed, 43 insertions(+), 19 deletions(-) diff --git a/Language/Haskell/GhcMod/DynFlagsTH.hs b/Language/Haskell/GhcMod/DynFlagsTH.hs index 13ac237..084396b 100644 --- a/Language/Haskell/GhcMod/DynFlagsTH.hs +++ b/Language/Haskell/GhcMod/DynFlagsTH.hs @@ -14,16 +14,16 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP, TemplateHaskell #-} module Language.Haskell.GhcMod.DynFlagsTH where import Language.Haskell.TH.Syntax +import Control.Applicative import Data.Maybe import Data.Generics.Aliases import Data.Generics.Schemes -import Packages -import Hooks import DynFlags +import Prelude deriveEqDynFlags :: Q [Dec] -> Q [Dec] deriveEqDynFlags qds = do @@ -42,24 +42,31 @@ deriveEqDynFlags qds = do where eq :: Name -> Name -> (Name, Strict, Type) -> Maybe (Q Exp) eq a b (fn@(Name (OccName fon) _), _, ft) - | not isUneqable = Just expr + | not (isUneqable || isIgnored) = Just expr | otherwise = Nothing where isUneqable = everything (||) (mkQ False hasUnEqable) ft hasUnEqable ArrowT = True - hasUnEqable (ConT n@(Name (OccName on) _)) - | n == ''LogAction = True - | any (==n) ignoredTypeNames = True + hasUnEqable (ConT (Name (OccName on) _)) + | any (==on) ignoredTypeNames = True | any (==on) ignoredTypeOccNames = True hasUnEqable _ = False + isIgnored = fon `elem` ignoredNames + + ignoredNames = [ "pkgDatabase" -- 7.8 +#if __GLASGOW_HASKELL__ <= 706 + , "ways" -- 'Ways' is not exported :/ +#endif + ] ignoredTypeNames = - [ ''PackageState - , ''Hooks - , ''FlushOut - , ''FlushErr - , ''Settings -- I think these can't cange at runtime + [ "LogAction" + , "PackageState" + , "Hooks" + , "FlushOut" + , "FlushErr" + , "Settings" -- I think these can't cange at runtime ] ignoredTypeOccNames = [ "OnOff" ] @@ -67,13 +74,6 @@ deriveEqDynFlags qds = do fb = AppE (VarE fn) (VarE b) expr = case fon of - "language" -> do - eqfn <- [| let eqfn (Just Haskell98) (Just Haskell98) = True - eqfn (Just Haskell2010) (Just Haskell2010) = True - eqfn _ _ = False - in eqfn - |] - return $ AppE (AppE eqfn fa) fb "rtsOptsEnabled" -> do eqfn <- [| let eqfn RtsOptsNone RtsOptsNone = True eqfn RtsOptsSafeOnly RtsOptsSafeOnly = True @@ -83,6 +83,7 @@ deriveEqDynFlags qds = do |] return $ AppE (AppE eqfn fa) fb +#if __GLASGOW_HASKELL__ >= 710 "sigOf" -> do eqfn <- [| let eqfn NotSigOf NotSigOf = True eqfn (SigOf a') (SigOf b') = a' == b' @@ -91,7 +92,30 @@ deriveEqDynFlags qds = do in eqfn |] return $ AppE (AppE eqfn fa) fb +#endif +#if __GLASGOW_HASKELL <= 706 + "profAuto" -> do + eqfn <- [| let eqfn NoProfAuto NoProfAuto = True + eqfn ProfAutoAll ProfAutoAll = True + eqfn ProfAutoTop ProfAutoTop = True + eqfn ProfAutoExports ProfAutoExports = True + eqfn ProfAutoCalls ProfAutoCalls = True + eqfn _ _ = False + in eqfn + |] + return $ AppE (AppE eqfn fa) fb +#endif + +#if __GLASGOW_HASKELL__ >= 706 + "language" -> do + eqfn <- [| let eqfn (Just Haskell98) (Just Haskell98) = True + eqfn (Just Haskell2010) (Just Haskell2010) = True + eqfn _ _ = False + in eqfn + |] + return $ AppE (AppE eqfn fa) fb +#endif _ -> return $ InfixE (Just fa) (VarE '(==)) (Just fb) From 20c999e0980de4aabe7643df0f16f9c5758e2fef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 14 Feb 2016 09:57:42 +0100 Subject: [PATCH 14/19] Time to kill GHC 7.4 support --- .travis.yml | 1 - ghc-mod.cabal | 12 +----------- 2 files changed, 1 insertion(+), 12 deletions(-) diff --git a/.travis.yml b/.travis.yml index c110a3c..9d870b0 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,5 @@ language: haskell ghc: - - 7.4 - 7.6 - 7.8 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 3f673a9..85f0738 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -165,7 +165,7 @@ Library , deepseq < 1.5 , directory < 1.3 , filepath < 1.5 - , ghc < 8.2 + , ghc < 8.2 && >= 7.6 , ghc-paths < 0.2 , ghc-syb-utils < 0.3 , hlint < 1.10 && >= 1.9.26 @@ -192,10 +192,6 @@ Library , syb if impl(ghc < 7.8) Build-Depends: convertible - if impl(ghc < 7.5) - -- Only used to constrain random to a version that still works with GHC 7.4 - Build-Depends: random <= 1.0.1.1, - ghc-prim Executable ghc-mod Default-Language: Haskell2010 @@ -250,8 +246,6 @@ Test-Suite doctest Ghc-Options: -Wall Default-Extensions: ConstraintKinds, FlexibleContexts Main-Is: doctests.hs - if impl(ghc == 7.4.*) - Buildable: False Build-Depends: base , doctest >= 0.9.3 @@ -284,12 +278,8 @@ Test-Suite spec ShellParseSpec Build-Depends: hspec >= 2.0.0 - if impl(ghc == 7.4.*) - Build-Depends: executable-path X-Build-Depends-Like: CLibName - - Source-Repository head Type: git Location: https://github.com/kazu-yamamoto/ghc-mod.git From 85df08a91312098173c3450ee0250ab88beb39d3 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 15 Feb 2016 22:04:47 +0200 Subject: [PATCH 15/19] Add a argument parser and some haddocks I am not sure if I have set the ParserInfo up correctly, I have never used it before. --- Language/Haskell/GhcMod/Options/Options.hs | 23 +++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Options/Options.hs b/Language/Haskell/GhcMod/Options/Options.hs index b0349f0..8d10d9d 100644 --- a/Language/Haskell/GhcMod/Options/Options.hs +++ b/Language/Haskell/GhcMod/Options/Options.hs @@ -17,10 +17,12 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module Language.Haskell.GhcMod.Options.Options ( - globalArgSpec + globalArgSpec + , parseCmdLineOptions ) where import Options.Applicative +import Options.Applicative.Help.Chunk import Options.Applicative.Types import Language.Haskell.GhcMod.Types import Control.Arrow @@ -30,6 +32,22 @@ import Language.Haskell.GhcMod.Read import Language.Haskell.GhcMod.Options.DocUtils import Language.Haskell.GhcMod.Options.Help +-- | Parse a set of arguments according to the ghc-mod CLI flag spec, producing +-- @Options@ set accordingly. +parseCmdLineOptions :: [String] -> Maybe Options +parseCmdLineOptions args = execParserMaybe parserInfo args + where + parserInfo + = ParserInfo + { infoParser = globalArgSpec + , infoFullDesc = True + , infoProgDesc = Chunk Nothing + , infoHeader = Chunk Nothing + , infoFooter = Chunk Nothing + , infoFailureCode = -1 + , infoIntersperse = True + } + splitOn :: Eq a => a -> [a] -> ([a], [a]) splitOn c = second (drop 1) . break (==c) @@ -119,6 +137,9 @@ programsArgSpec = Programs <=> showDefault <=> help "stack executable to use" +-- | An optparse-applicative @Parser@ sepcification for @Options@ so that +-- applications making use of the ghc-mod API can have a consistent way of +-- parsing global options. globalArgSpec :: Parser Options globalArgSpec = Options <$> outputOptsSpec From 4874bc914b53c8ce9d18ae62797cd9c2a59210aa Mon Sep 17 00:00:00 2001 From: Moritz Kiefer Date: Tue, 16 Feb 2016 21:44:10 +0100 Subject: [PATCH 16/19] Add Ord instances for Cradle --- Language/Haskell/GhcMod/Types.hs | 6 +++--- stack.yaml | 5 ++--- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 42dac13..2281ba9 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -134,7 +134,7 @@ data Project = CabalProject | SandboxProject | PlainProject | StackProject StackEnv - deriving (Eq, Show) + deriving (Eq, Show, Ord) isCabalHelperProject :: Project -> Bool isCabalHelperProject StackProject {} = True @@ -146,7 +146,7 @@ data StackEnv = StackEnv { , seBinPath :: [FilePath] , seSnapshotPkgDb :: FilePath , seLocalPkgDb :: FilePath - } deriving (Eq, Show) + } deriving (Eq, Show, Ord) -- | The environment where this library is used. data Cradle = Cradle { @@ -161,7 +161,7 @@ data Cradle = Cradle { , cradleCabalFile :: Maybe FilePath -- | The build info directory. , cradleDistDir :: FilePath - } deriving (Eq, Show) + } deriving (Eq, Show, Ord) data GmStream = GmOutStream | GmErrStream deriving (Show) diff --git a/stack.yaml b/stack.yaml index fdcb756..1e26270 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,5 @@ flags: {} packages: - '.' -extra-deps: -- cabal-helper-0.6.2.0 -resolver: lts-3.20 +extra-deps: [] +resolver: lts-5.3 From 45eb3b8d4c0dd4857e9b7c6c9044a4d2c95db586 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 29 Feb 2016 20:45:32 +0200 Subject: [PATCH 17/19] Do not use deprecated API for parseCmdLineOptions Thanks to @lierdakil --- Language/Haskell/GhcMod/Options/Options.hs | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) diff --git a/Language/Haskell/GhcMod/Options/Options.hs b/Language/Haskell/GhcMod/Options/Options.hs index 8d10d9d..c49d6f7 100644 --- a/Language/Haskell/GhcMod/Options/Options.hs +++ b/Language/Haskell/GhcMod/Options/Options.hs @@ -35,18 +35,7 @@ import Language.Haskell.GhcMod.Options.Help -- | Parse a set of arguments according to the ghc-mod CLI flag spec, producing -- @Options@ set accordingly. parseCmdLineOptions :: [String] -> Maybe Options -parseCmdLineOptions args = execParserMaybe parserInfo args - where - parserInfo - = ParserInfo - { infoParser = globalArgSpec - , infoFullDesc = True - , infoProgDesc = Chunk Nothing - , infoHeader = Chunk Nothing - , infoFooter = Chunk Nothing - , infoFailureCode = -1 - , infoIntersperse = True - } +parseCmdLineOptions = getParseResult . execParserPure (prefs mempty) (info globalArgSpec mempty) splitOn :: Eq a => a -> [a] -> ([a], [a]) splitOn c = second (drop 1) . break (==c) From 04b75e2bdef561ab53b1068673ff66f8c2fb6084 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 29 Feb 2016 21:24:30 +0200 Subject: [PATCH 18/19] Sort out imports for earlier GHC versions --- Language/Haskell/GhcMod/Options/Options.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Options/Options.hs b/Language/Haskell/GhcMod/Options/Options.hs index c49d6f7..8b13091 100644 --- a/Language/Haskell/GhcMod/Options/Options.hs +++ b/Language/Haskell/GhcMod/Options/Options.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Nikolay Yakimov -- @@ -22,12 +23,14 @@ module Language.Haskell.GhcMod.Options.Options ( ) where import Options.Applicative -import Options.Applicative.Help.Chunk import Options.Applicative.Types import Language.Haskell.GhcMod.Types import Control.Arrow import Data.Char (toUpper, toLower) import Data.List (intercalate) +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid (mempty) +#endif import Language.Haskell.GhcMod.Read import Language.Haskell.GhcMod.Options.DocUtils import Language.Haskell.GhcMod.Options.Help From f992200d57fc93355d5e5c754ce7b65ee701cfc3 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 1 Mar 2016 22:58:10 +0200 Subject: [PATCH 19/19] Remove CPP from Options As per @lierdakil suggestion --- Language/Haskell/GhcMod/Options/Options.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/Language/Haskell/GhcMod/Options/Options.hs b/Language/Haskell/GhcMod/Options/Options.hs index 8b13091..7d4aa3a 100644 --- a/Language/Haskell/GhcMod/Options/Options.hs +++ b/Language/Haskell/GhcMod/Options/Options.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} -- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Nikolay Yakimov -- @@ -28,12 +27,11 @@ import Language.Haskell.GhcMod.Types import Control.Arrow import Data.Char (toUpper, toLower) import Data.List (intercalate) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (mempty) -#endif import Language.Haskell.GhcMod.Read import Language.Haskell.GhcMod.Options.DocUtils import Language.Haskell.GhcMod.Options.Help +import Data.Monoid +import Prelude -- | Parse a set of arguments according to the ghc-mod CLI flag spec, producing -- @Options@ set accordingly.