Merge branch 'master' into find-cache-master
This commit is contained in:
commit
2feaf14325
@ -1,6 +1,5 @@
|
||||
language: haskell
|
||||
ghc:
|
||||
- 7.4
|
||||
- 7.6
|
||||
- 7.8
|
||||
|
||||
|
@ -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
|
||||
|]
|
||||
|
121
Language/Haskell/GhcMod/DynFlagsTH.hs
Normal file
121
Language/Haskell/GhcMod/DynFlagsTH.hs
Normal file
@ -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)
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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"]
|
||||
|
@ -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 (
|
||||
($$),
|
||||
($$$),
|
||||
(<=>),
|
@ -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)
|
173
Language/Haskell/GhcMod/Options/Options.hs
Normal file
173
Language/Haskell/GhcMod/Options/Options.hs
Normal file
@ -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)
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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 [])
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 =
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -1,6 +1,5 @@
|
||||
flags: {}
|
||||
packages:
|
||||
- '.'
|
||||
extra-deps:
|
||||
- cabal-helper-0.6.2.0
|
||||
resolver: lts-3.20
|
||||
extra-deps: []
|
||||
resolver: lts-5.3
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user