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/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..084396b --- /dev/null +++ b/Language/Haskell/GhcMod/DynFlagsTH.hs @@ -0,0 +1,121 @@ +-- 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 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) 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 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/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/Language/Haskell/GhcMod/Options/Options.hs b/Language/Haskell/GhcMod/Options/Options.hs new file mode 100644 index 0000000..7d4aa3a --- /dev/null +++ b/Language/Haskell/GhcMod/Options/Options.hs @@ -0,0 +1,173 @@ +-- 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 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) 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/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 779c5c9..2281ba9 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" } ---------------------------------------------------------------- @@ -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) 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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 01358b5..c7b1f9f 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 @@ -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 - , transformers < 0.5 + , time < 1.7 + , 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 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..c3cf263 100644 --- a/src/GHCMod/Options.hs +++ b/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 GHCMod.Options.Help +import Language.Haskell.GhcMod.Options.DocUtils +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) diff --git a/src/GHCMod/Options/Commands.hs b/src/GHCMod/Options/Commands.hs index 2e1f60a..a2ab3c0 100644 --- a/src/GHCMod/Options/Commands.hs +++ b/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 GHCMod.Options.Help +import Language.Haskell.GhcMod.Options.DocUtils +import Language.Haskell.GhcMod.Options.Help type Symbol = String type Expr = String 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 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