Merge branch 'master' into find-cache-master

.travis.yml

@@ -1,6 +1,5 @@
 language: haskell
 ghc:
-  - 7.4
   - 7.6
   - 7.8
 

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
+ |]

Language/Haskell/GhcMod/DynFlagsTH.hs

@@ -0,0 +1,121 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
+--
+-- 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 <http://www.gnu.org/licenses/>.
+
+{-# 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 DynFlags
+import Prelude
+
+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 || isIgnored) = Just expr
+       | otherwise = Nothing
+    where
+       isUneqable = everything (||) (mkQ False hasUnEqable) ft
+
+       hasUnEqable ArrowT = 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 =
+           [ "LogAction"
+           , "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
+           "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
+
+#if __GLASGOW_HASKELL__ >= 710
+           "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
+#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)

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

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

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"]

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 <http://www.gnu.org/licenses/>.
 
-module GHCMod.Options.DocUtils (
+module Language.Haskell.GhcMod.Options.DocUtils (
   ($$),
   ($$$),
   (<=>),

Language/Haskell/GhcMod/Options/Help.hs

@@ -15,7 +15,7 @@
 -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
 {-# 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)

Language/Haskell/GhcMod/Options/Options.hs

@@ -0,0 +1,173 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>
+--
+-- 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 <http://www.gnu.org/licenses/>.
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
+
+module Language.Haskell.GhcMod.Options.Options (
+    globalArgSpec
+  , parseCmdLineOptions
+) 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 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.
+parseCmdLineOptions :: [String] -> Maybe Options
+parseCmdLineOptions = getParseResult . execParserPure (prefs mempty) (info globalArgSpec mempty)
+
+splitOn :: Eq a => a -> [a] -> ([a], [a])
+splitOn c = second (drop 1) . break (==c)
+
+logLevelParser :: Parser GmLogLevel
+logLevelParser =
+    logLevelSwitch <*>
+           logLevelOption
+      <||> silentSwitch
+  where
+    logLevelOption =
+      option parseLL
+        $$  long "verbose"
+        <=> metavar "LEVEL"
+        <=> value GmWarning
+        <=> showDefaultWith showLL
+        <=> help' $$$ do
+          "Set log level ("
+            <> int' (fromEnum (minBound :: GmLogLevel))
+            <> "-"
+            <> int' (fromEnum (maxBound :: GmLogLevel))
+            <> ")"
+          "You can also use strings (case-insensitive):"
+          para'
+            $ intercalate ", "
+            $ map showLL ([minBound..maxBound] :: [GmLogLevel])
+    logLevelSwitch =
+      repeatAp succ' . length <$> many $$ flag' ()
+        $$  short 'v'
+        <=> help "Increase log level"
+    silentSwitch = flag' GmSilent
+        $$  long "silent"
+        <=> short 's'
+        <=> help "Be silent, set log level to 'silent'"
+    showLL = drop 2 . map toLower . show
+    repeatAp f n = foldr (.) id (replicate n f)
+    succ' x | x == maxBound = x
+            | otherwise     = succ x
+    parseLL = do
+      v <- readerAsk
+      let
+        il'= toEnum . min maxBound <$> readMaybe v
+        ll' = readMaybe ("Gm" ++ capFirst v)
+      maybe (readerError $ "Not a log level \"" ++ v ++ "\"") return $ ll' <|> il'
+    capFirst (h:t) = toUpper h : map toLower t
+    capFirst [] = []
+
+outputOptsSpec :: Parser OutputOpts
+outputOptsSpec = OutputOpts
+      <$> logLevelParser
+      <*> flag PlainStyle LispStyle
+          $$  long "tolisp"
+          <=> short 'l'
+          <=> help "Format output as an S-Expression"
+      <*> LineSeparator <$$> strOption
+          $$  long "boundary"
+          <=> long "line-separator"
+          <=> short 'b'
+          <=> metavar "SEP"
+          <=> value "\0"
+          <=> showDefault
+          <=> help "Output line separator"
+      <*> optional $$ splitOn ',' <$$> strOption
+          $$  long "line-prefix"
+          <=> metavar "OUT,ERR"
+          <=> help "Output prefixes"
+
+programsArgSpec :: Parser Programs
+programsArgSpec = Programs
+      <$> strOption
+          $$  long "with-ghc"
+          <=> value "ghc"
+          <=> showDefault
+          <=> help "GHC executable to use"
+      <*> strOption
+          $$  long "with-ghc-pkg"
+          <=> value "ghc-pkg"
+          <=> showDefault
+          <=> help "ghc-pkg executable to use (only needed when guessing from GHC path fails)"
+      <*> strOption
+          $$  long "with-cabal"
+          <=> value "cabal"
+          <=> showDefault
+          <=> help "cabal-install executable to use"
+      <*> strOption
+          $$  long "with-stack"
+          <=> value "stack"
+          <=> 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
+      <*> programsArgSpec
+      <*> many $$ strOption
+          $$  long "ghcOpt"
+          <=> long "ghc-option"
+          <=> short 'g'
+          <=> metavar "OPT"
+          <=> help "Option to be passed to GHC"
+      <*> many fileMappingSpec
+      <*> strOption
+          $$  long "encoding"
+          <=> value "UTF-8"
+          <=> showDefault
+          <=> help "I/O encoding"
+  where
+    fileMappingSpec =
+      getFileMapping . splitOn '=' <$> strOption
+        $$  long "map-file"
+        <=> metavar "MAPPING"
+        <=> fileMappingHelp
+    fileMappingHelp = help' $ do
+        "Redirect one file to another"
+        "--map-file \"file1.hs=file2.hs\""
+        indent 4 $ do
+          "can be used to tell ghc-mod"
+            \\ "that it should take source code"
+            \\ "for `file1.hs` from `file2.hs`."
+          "`file1.hs` can be either full path,"
+            \\ "or path relative to project root."
+          "`file2.hs` has to be either relative to project root,"
+            \\  "or full path (preferred)"
+        "--map-file \"file.hs\""
+        indent 4 $ do
+          "can be used to tell ghc-mod that it should take"
+            \\ "source code for `file.hs` from stdin. File end"
+            \\ "marker is `\\n\\EOT\\n`, i.e. `\\x0A\\x04\\x0A`."
+            \\ "`file.hs` may or may not exist, and should be"
+            \\ "either full path, or relative to project root."
+    getFileMapping = second (\i -> if null i then Nothing else Just i)

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
+   initDF Cradle { cradleTempDir } = do
-     rghc <- (liftIO . newIORef =<< newSession =<< cradle)
-     gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc }
-
-   newSession Cradle { cradleTempDir } = liftIO $ do
-     runGhc (Just libdir) $ 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

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"
   }
 
 ----------------------------------------------------------------
@@ -132,7 +134,7 @@ data Project = CabalProject
              | SandboxProject
              | PlainProject
              | StackProject StackEnv
-               deriving (Eq, Show)
+               deriving (Eq, Show, Ord)
 
 isCabalHelperProject :: Project -> Bool
 isCabalHelperProject StackProject {} = True
@@ -144,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 {
@@ -159,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)

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

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 [])

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

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
@@ -152,30 +153,34 @@ Library
                         Language.Haskell.GhcMod.Types
                         Language.Haskell.GhcMod.Utils
                         Language.Haskell.GhcMod.World
+
+                        Language.Haskell.GhcMod.Options.Options
+                        Language.Haskell.GhcMod.Options.DocUtils
+                        Language.Haskell.GhcMod.Options.Help
   Other-Modules:        Paths_ghc_mod
                         Utils
                         Data.Binary.Generic
                         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 && >= 7.6
                       , 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
+                      , time              < 1.7
-                      , transformers      < 0.5
+                      , transformers      < 0.6
                       , transformers-base < 0.5
                       , mtl               < 2.3 && >= 2.0
                       , monad-control     < 1.1 && >= 1
@@ -187,12 +192,11 @@ Library
                       , extra             == 1.4.*
                       , pipes             == 4.1.*
                       , safe              < 0.4 && >= 0.3.9
+                      , optparse-applicative >=0.11.0 && <0.13.0
+                      , template-haskell
+                      , 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
@@ -201,9 +205,7 @@ Executable 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
@@ -211,10 +213,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 +233,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
@@ -247,8 +249,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
 
@@ -281,12 +281,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

src/GHCMod.hs

@@ -34,9 +34,12 @@ handler = flip gcatches
           ]
 
 main :: IO ()
-main = do
+main =
-    hSetEncoding stdout utf8
+    parseArgs >>= \res@(globalOptions, _) -> do
-    parseArgs >>= \res@(globalOptions, _) ->
+      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 =

src/GHCMod/Options.hs

@@ -25,14 +25,10 @@ module GHCMod.Options (
 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 GHCMod.Options.DocUtils
+import Language.Haskell.GhcMod.Options.DocUtils
-import GHCMod.Options.Help
+import Language.Haskell.GhcMod.Options.Options
 import GHCMod.Options.ShellParse
 
 parseArgs :: IO (Options, GhcModCommands)
@@ -74,128 +70,3 @@ helpVersion =
 argAndCmdSpec :: Parser (Options, GhcModCommands)
 argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec
 
-splitOn :: Eq a => a -> [a] -> ([a], [a])
-splitOn c = second (drop 1) . break (==c)
-
-logLevelParser :: Parser GmLogLevel
-logLevelParser =
-    logLevelSwitch <*>
-           logLevelOption
-      <||> silentSwitch
-  where
-    logLevelOption =
-      option parseLL
-        $$  long "verbose"
-        <=> metavar "LEVEL"
-        <=> value GmWarning
-        <=> showDefaultWith showLL
-        <=> help' $$$ do
-          "Set log level ("
-            <> int' (fromEnum (minBound :: GmLogLevel))
-            <> "-"
-            <> int' (fromEnum (maxBound :: GmLogLevel))
-            <> ")"
-          "You can also use strings (case-insensitive):"
-          para'
-            $ intercalate ", "
-            $ map showLL ([minBound..maxBound] :: [GmLogLevel])
-    logLevelSwitch =
-      repeatAp succ' . length <$> many $$ flag' ()
-        $$  short 'v'
-        <=> help "Increase log level"
-    silentSwitch = flag' GmSilent
-        $$  long "silent"
-        <=> short 's'
-        <=> help "Be silent, set log level to 'silent'"
-    showLL = drop 2 . map toLower . show
-    repeatAp f n = foldr (.) id (replicate n f)
-    succ' x | x == maxBound = x
-            | otherwise     = succ x
-    parseLL = do
-      v <- readerAsk
-      let
-        il'= toEnum . min maxBound <$> readMaybe v
-        ll' = readMaybe ("Gm" ++ capFirst v)
-      maybe (readerError $ "Not a log level \"" ++ v ++ "\"") return $ ll' <|> il'
-    capFirst (h:t) = toUpper h : map toLower t
-    capFirst [] = []
-
-outputOptsSpec :: Parser OutputOpts
-outputOptsSpec = OutputOpts
-      <$> logLevelParser
-      <*> flag PlainStyle LispStyle
-          $$  long "tolisp"
-          <=> short 'l'
-          <=> help "Format output as an S-Expression"
-      <*> LineSeparator <$$> strOption
-          $$  long "boundary"
-          <=> long "line-separator"
-          <=> short 'b'
-          <=> metavar "SEP"
-          <=> value "\0"
-          <=> showDefault
-          <=> help "Output line separator"
-      <*> optional $$ splitOn ',' <$$> strOption
-          $$  long "line-prefix"
-          <=> metavar "OUT,ERR"
-          <=> help "Output prefixes"
-
-programsArgSpec :: Parser Programs
-programsArgSpec = Programs
-      <$> strOption
-          $$  long "with-ghc"
-          <=> value "ghc"
-          <=> showDefault
-          <=> help "GHC executable to use"
-      <*> strOption
-          $$  long "with-ghc-pkg"
-          <=> value "ghc-pkg"
-          <=> showDefault
-          <=> help "ghc-pkg executable to use (only needed when guessing from GHC path fails)"
-      <*> strOption
-          $$  long "with-cabal"
-          <=> value "cabal"
-          <=> showDefault
-          <=> help "cabal-install executable to use"
-      <*> strOption
-          $$  long "with-stack"
-          <=> value "stack"
-          <=> showDefault
-          <=> help "stack executable to use"
-
-globalArgSpec :: Parser Options
-globalArgSpec = Options
-      <$> outputOptsSpec
-      <*> programsArgSpec
-      <*> many $$ strOption
-          $$  long "ghcOpt"
-          <=> long "ghc-option"
-          <=> short 'g'
-          <=> metavar "OPT"
-          <=> help "Option to be passed to GHC"
-      <*> many fileMappingSpec
-  where
-    fileMappingSpec =
-      getFileMapping . splitOn '=' <$> strOption
-        $$  long "map-file"
-        <=> metavar "MAPPING"
-        <=> fileMappingHelp
-    fileMappingHelp = help' $ do
-        "Redirect one file to another"
-        "--map-file \"file1.hs=file2.hs\""
-        indent 4 $ do
-          "can be used to tell ghc-mod"
-            \\ "that it should take source code"
-            \\ "for `file1.hs` from `file2.hs`."
-          "`file1.hs` can be either full path,"
-            \\ "or path relative to project root."
-          "`file2.hs` has to be either relative to project root,"
-            \\  "or full path (preferred)"
-        "--map-file \"file.hs\""
-        indent 4 $ do
-          "can be used to tell ghc-mod that it should take"
-            \\ "source code for `file.hs` from stdin. File end"
-            \\ "marker is `\\n\\EOT\\n`, i.e. `\\x0A\\x04\\x0A`."
-            \\ "`file.hs` may or may not exist, and should be"
-            \\ "either full path, or relative to project root."
-    getFileMapping = second (\i -> if null i then Nothing else Just i)

src/GHCMod/Options/Commands.hs

@@ -23,8 +23,8 @@ import Options.Applicative.Types
 import Options.Applicative.Builder.Internal
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Read
-import GHCMod.Options.DocUtils
+import Language.Haskell.GhcMod.Options.DocUtils
-import GHCMod.Options.Help
+import Language.Haskell.GhcMod.Options.Help
 
 type Symbol = String
 type Expr = String

stack.yaml

@@ -1,6 +1,5 @@
 flags: {}
 packages:
 - '.'
-extra-deps:
+extra-deps: []
-- cabal-helper-0.6.2.0
+resolver: lts-5.3
-resolver: lts-3.20

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

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