Merge branch 'master' into find-cache-master

This commit is contained in:
Nikolay Yakimov 2016-03-02 00:25:30 +03:00
commit 2feaf14325
21 changed files with 430 additions and 195 deletions

View File

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

View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP, TemplateHaskell #-}
module Language.Haskell.GhcMod.DynFlags where module Language.Haskell.GhcMod.DynFlags where
@ -10,6 +10,7 @@ import GHC.Paths (libdir)
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.DebugLogger import Language.Haskell.GhcMod.DebugLogger
import Language.Haskell.GhcMod.DynFlagsTH
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import Prelude import Prelude
@ -102,7 +103,14 @@ setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
setNoMaxRelevantBindings = id setNoMaxRelevantBindings = id
#endif #endif
deferErrors :: DynFlags -> Ghc DynFlags deferErrors :: Monad m => DynFlags -> m DynFlags
deferErrors df = return $ deferErrors df = return $
Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $ Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $
Gap.setDeferTypeErrors $ setNoWarningFlags df Gap.setDeferTypeErrors $ setNoWarningFlags df
----------------------------------------------------------------
deriveEqDynFlags [d|
eqDynFlags :: DynFlags -> DynFlags -> Bool
eqDynFlags = undefined
|]

View 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)

View File

@ -46,8 +46,10 @@ loadMappedFileSource :: IOish m
-> GhcModT m () -> GhcModT m ()
loadMappedFileSource from src = do loadMappedFileSource from src = do
tmpdir <- cradleTempDir `fmap` cradle tmpdir <- cradleTempDir `fmap` cradle
enc <- liftIO . mkTextEncoding . optEncoding =<< options
to <- liftIO $ do to <- liftIO $ do
(fn, h) <- openTempFile tmpdir (takeFileName from) (fn, h) <- openTempFile tmpdir (takeFileName from)
hSetEncoding h enc
hPutStr h src hPutStr h src
hClose h hClose h
return fn return fn

View File

@ -42,3 +42,7 @@ runLightGhc :: HscEnv -> LightGhc a -> IO a
runLightGhc env action = do runLightGhc env action = do
renv <- newIORef env renv <- newIORef env
flip runReaderT renv $ unLightGhc action flip runReaderT renv $ unLightGhc action
runLightGhc' :: IORef HscEnv -> LightGhc a -> IO a
runLightGhc' renv action = do
flip runReaderT renv $ unLightGhc action

View File

@ -14,7 +14,7 @@
-- You should have received a copy of the GNU Affero General Public License -- 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/>. -- along with this program. If not, see <http://www.gnu.org/licenses/>.
module GHCMod.Options.DocUtils ( module Language.Haskell.GhcMod.Options.DocUtils (
($$), ($$),
($$$), ($$$),
(<=>), (<=>),

View File

@ -15,7 +15,7 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>. -- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-}
module GHCMod.Options.Help where module Language.Haskell.GhcMod.Options.Help where
import Options.Applicative import Options.Applicative
import Options.Applicative.Help.Pretty (Doc) import Options.Applicative.Help.Pretty (Doc)

View 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)

View File

@ -66,29 +66,41 @@ runGmPkgGhc action = do
withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action
initSession :: IOish m initSession :: IOish m
=> [GHCOption] -> (DynFlags -> Ghc DynFlags) -> GhcModT m () => [GHCOption] -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) -> GhcModT m ()
initSession opts mdf = do initSession opts mdf = do
s <- gmsGet s <- gmsGet
case gmGhcSession s of case gmGhcSession s of
Just GmGhcSession {..} | gmgsOptions /= opts-> do
gmLog GmDebug "initSession" $ text "Flags changed, creating new session"
putNewSession s
Just _ -> return ()
Nothing -> do Nothing -> do
gmLog GmDebug "initSession" $ text "Session not initialized, creating new one" gmLog GmDebug "initSession" $ text "Session not initialized, creating new one"
putNewSession s 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 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) let setDf df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)
_ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags _ <- 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 getSession
-- | Drop the currently active GHC session, the next that requires a GHC session -- | Drop the currently active GHC session, the next that requires a GHC session
-- will initialize a new one. -- will initialize a new one.
dropSession :: IOish m => GhcModT m () 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 -- of certain files or modules, with updated GHC flags
runGmlT' :: IOish m runGmlT' :: IOish m
=> [Either FilePath ModuleName] => [Either FilePath ModuleName]
-> (DynFlags -> Ghc DynFlags) -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)
-> GmlT m a -> GmlT m a
-> GhcModT m a -> GhcModT m a
runGmlT' fns mdf action = runGmlTWith fns mdf id action runGmlT' fns mdf action = runGmlTWith fns mdf id action
@ -124,7 +136,7 @@ runGmlT' fns mdf action = runGmlTWith fns mdf id action
-- transformation -- transformation
runGmlTWith :: IOish m runGmlTWith :: IOish m
=> [Either FilePath ModuleName] => [Either FilePath ModuleName]
-> (DynFlags -> Ghc DynFlags) -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)
-> (GmlT m a -> GmlT m b) -> (GmlT m a -> GmlT m b)
-> GmlT m a -> GmlT m a
-> GhcModT m b -> GhcModT m b

View File

@ -105,6 +105,7 @@ data Options = Options {
-- | GHC command line options set on the @ghc-mod@ command line -- | GHC command line options set on the @ghc-mod@ command line
, optGhcUserOptions :: [GHCOption] , optGhcUserOptions :: [GHCOption]
, optFileMappings :: [(FilePath, Maybe FilePath)] , optFileMappings :: [(FilePath, Maybe FilePath)]
, optEncoding :: String
} deriving (Show) } deriving (Show)
-- | A default 'Options'. -- | A default 'Options'.
@ -124,6 +125,7 @@ defaultOptions = Options {
} }
, optGhcUserOptions = [] , optGhcUserOptions = []
, optFileMappings = [] , optFileMappings = []
, optEncoding = "UTF-8"
} }
---------------------------------------------------------------- ----------------------------------------------------------------
@ -132,7 +134,7 @@ data Project = CabalProject
| SandboxProject | SandboxProject
| PlainProject | PlainProject
| StackProject StackEnv | StackProject StackEnv
deriving (Eq, Show) deriving (Eq, Show, Ord)
isCabalHelperProject :: Project -> Bool isCabalHelperProject :: Project -> Bool
isCabalHelperProject StackProject {} = True isCabalHelperProject StackProject {} = True
@ -144,7 +146,7 @@ data StackEnv = StackEnv {
, seBinPath :: [FilePath] , seBinPath :: [FilePath]
, seSnapshotPkgDb :: FilePath , seSnapshotPkgDb :: FilePath
, seLocalPkgDb :: FilePath , seLocalPkgDb :: FilePath
} deriving (Eq, Show) } deriving (Eq, Show, Ord)
-- | The environment where this library is used. -- | The environment where this library is used.
data Cradle = Cradle { data Cradle = Cradle {
@ -159,7 +161,7 @@ data Cradle = Cradle {
, cradleCabalFile :: Maybe FilePath , cradleCabalFile :: Maybe FilePath
-- | The build info directory. -- | The build info directory.
, cradleDistDir :: FilePath , cradleDistDir :: FilePath
} deriving (Eq, Show) } deriving (Eq, Show, Ord)
data GmStream = GmOutStream | GmErrStream data GmStream = GmOutStream | GmErrStream
deriving (Show) deriving (Show)

View File

@ -104,18 +104,33 @@ boundNames decl =
TySynD n _ _ -> [(TcClsName, n)] TySynD n _ _ -> [(TcClsName, n)]
ClassD _ n _ _ _ -> [(TcClsName, n)] ClassD _ n _ _ _ -> [(TcClsName, n)]
FamilyD _ n _ _ -> [(TcClsName, n)]
#if __GLASGOW_HASKELL__ >= 800
DataD _ n _ _ ctors _ ->
#else
DataD _ n _ ctors _ -> DataD _ n _ ctors _ ->
#endif
[(TcClsName, n)] ++ map ((,) TcClsName) (conNames `concatMap` ctors) [(TcClsName, n)] ++ map ((,) TcClsName) (conNames `concatMap` ctors)
#if __GLASGOW_HASKELL__ >= 800
NewtypeD _ n _ _ ctor _ ->
#else
NewtypeD _ n _ ctor _ -> NewtypeD _ n _ ctor _ ->
#endif
[(TcClsName, n)] ++ map ((,) TcClsName) (conNames ctor) [(TcClsName, n)] ++ map ((,) TcClsName) (conNames ctor)
#if __GLASGOW_HASKELL__ >= 800
DataInstD _ _n _ _ ctors _ ->
#else
DataInstD _ _n _ ctors _ -> DataInstD _ _n _ ctors _ ->
#endif
map ((,) TcClsName) (conNames `concatMap` ctors) map ((,) TcClsName) (conNames `concatMap` ctors)
#if __GLASGOW_HASKELL__ >= 800
NewtypeInstD _ _n _ _ ctor _ ->
#else
NewtypeInstD _ _n _ ctor _ -> NewtypeInstD _ _n _ ctor _ ->
#endif
map ((,) TcClsName) (conNames ctor) map ((,) TcClsName) (conNames ctor)
InstanceD _ _ty _ -> InstanceD _ _ty _ ->
@ -131,10 +146,19 @@ boundNames decl =
#endif #endif
#if __GLASGOW_HASKELL__ >= 708 #if __GLASGOW_HASKELL__ >= 708
ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)]
RoleAnnotD _n _ -> error "notcpp: RoleAnnotD not supported yet" RoleAnnotD _n _ -> error "notcpp: RoleAnnotD not supported yet"
#endif #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 -> [Name]
conNames con = conNames con =
case con of case con of

View File

@ -1,4 +1,4 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP, TemplateHaskell #-}
-- | This module uses scope lookup techniques to either export -- | This module uses scope lookup techniques to either export
-- 'lookupValueName' from @Language.Haskell.TH@, or define -- 'lookupValueName' from @Language.Haskell.TH@, or define
-- its own 'lookupValueName', which attempts to do the -- its own 'lookupValueName', which attempts to do the
@ -25,8 +25,13 @@ bestValueGuess s = do
case mi of case mi of
Nothing -> no Nothing -> no
Just i -> case i of Just i -> case i of
#if __GLASGOW_HASKELL__ >= 800
VarI n _ _ -> yes n
DataConI n _ _ -> yes n
#else
VarI n _ _ _ -> yes n VarI n _ _ _ -> yes n
DataConI n _ _ _ -> yes n DataConI n _ _ _ -> yes n
#endif
_ -> err ["unexpected info:", show i] _ -> err ["unexpected info:", show i]
where where
no = return Nothing no = return Nothing
@ -34,5 +39,9 @@ bestValueGuess s = do
err = fail . showString "NotCPP.bestValueGuess: " . unwords err = fail . showString "NotCPP.bestValueGuess: " . unwords
$(recover [d| lookupValueName = bestValueGuess |] $ do $(recover [d| lookupValueName = bestValueGuess |] $ do
#if __GLASGOW_HASKELL__ >= 800
VarI _ _ _ <- reify (mkName "lookupValueName")
#else
VarI _ _ _ _ <- reify (mkName "lookupValueName") VarI _ _ _ _ <- reify (mkName "lookupValueName")
#endif
return []) return [])

View File

@ -1,4 +1,4 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP, TemplateHaskell #-}
module NotCPP.Utils where module NotCPP.Utils where
import Control.Applicative ((<$>)) 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 -- | Returns @'Just' ('VarE' n)@ if the info relates to a value called
-- @n@, or 'Nothing' if it relates to a different sort of thing. -- @n@, or 'Nothing' if it relates to a different sort of thing.
infoToExp :: Info -> Maybe Exp 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 infoToExp _ = Nothing

View File

@ -117,6 +117,7 @@ Library
Language.Haskell.GhcMod.DebugLogger Language.Haskell.GhcMod.DebugLogger
Language.Haskell.GhcMod.Doc Language.Haskell.GhcMod.Doc
Language.Haskell.GhcMod.DynFlags Language.Haskell.GhcMod.DynFlags
Language.Haskell.GhcMod.DynFlagsTH
Language.Haskell.GhcMod.Error Language.Haskell.GhcMod.Error
Language.Haskell.GhcMod.FileMapping Language.Haskell.GhcMod.FileMapping
Language.Haskell.GhcMod.FillSig Language.Haskell.GhcMod.FillSig
@ -152,30 +153,34 @@ Library
Language.Haskell.GhcMod.Types Language.Haskell.GhcMod.Types
Language.Haskell.GhcMod.Utils Language.Haskell.GhcMod.Utils
Language.Haskell.GhcMod.World Language.Haskell.GhcMod.World
Language.Haskell.GhcMod.Options.Options
Language.Haskell.GhcMod.Options.DocUtils
Language.Haskell.GhcMod.Options.Help
Other-Modules: Paths_ghc_mod Other-Modules: Paths_ghc_mod
Utils Utils
Data.Binary.Generic Data.Binary.Generic
System.Directory.ModTime System.Directory.ModTime
Build-Depends: base < 5 && >= 4.0 Build-Depends: base < 5 && >= 4.0
, bytestring < 0.11 , bytestring < 0.11
, binary < 0.8 && >= 0.5.1.0 , binary < 0.9 && >= 0.5.1.0
, containers < 0.6 , containers < 0.6
, cabal-helper < 0.7 && >= 0.6.3.0 , cabal-helper < 0.7 && >= 0.6.3.0
, deepseq < 1.5 , deepseq < 1.5
, directory < 1.3 , directory < 1.3
, filepath < 1.5 , filepath < 1.5
, ghc < 7.11 , ghc < 8.2 && >= 7.6
, ghc-paths < 0.2 , ghc-paths < 0.2
, ghc-syb-utils < 0.3 , ghc-syb-utils < 0.3
, hlint < 1.10 && >= 1.9.26 , hlint < 1.10 && >= 1.9.26
, monad-journal < 0.8 && >= 0.4 , monad-journal < 0.8 && >= 0.4
, old-time < 1.2 , old-time < 1.2
, pretty < 1.2 , pretty < 1.2
, process < 1.3 , process < 1.5
, syb < 0.7 , syb < 0.7
, temporary < 1.3 , temporary < 1.3
, time < 1.6 , time < 1.7
, transformers < 0.5 , transformers < 0.6
, transformers-base < 0.5 , transformers-base < 0.5
, mtl < 2.3 && >= 2.0 , mtl < 2.3 && >= 2.0
, monad-control < 1.1 && >= 1 , monad-control < 1.1 && >= 1
@ -187,12 +192,11 @@ Library
, extra == 1.4.* , extra == 1.4.*
, pipes == 4.1.* , pipes == 4.1.*
, safe < 0.4 && >= 0.3.9 , safe < 0.4 && >= 0.3.9
, optparse-applicative >=0.11.0 && <0.13.0
, template-haskell
, syb
if impl(ghc < 7.8) if impl(ghc < 7.8)
Build-Depends: convertible 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 Executable ghc-mod
Default-Language: Haskell2010 Default-Language: Haskell2010
@ -201,9 +205,7 @@ Executable ghc-mod
, GHCMod.Options , GHCMod.Options
, GHCMod.Options.Commands , GHCMod.Options.Commands
, GHCMod.Version , GHCMod.Version
, GHCMod.Options.DocUtils
, GHCMod.Options.ShellParse , GHCMod.Options.ShellParse
, GHCMod.Options.Help
GHC-Options: -Wall -fno-warn-deprecations -threaded GHC-Options: -Wall -fno-warn-deprecations -threaded
Default-Extensions: ConstraintKinds, FlexibleContexts Default-Extensions: ConstraintKinds, FlexibleContexts
HS-Source-Dirs: src HS-Source-Dirs: src
@ -211,10 +213,10 @@ Executable ghc-mod
, directory < 1.3 , directory < 1.3
, filepath < 1.5 , filepath < 1.5
, pretty < 1.2 , pretty < 1.2
, process < 1.3 , process < 1.5
, split < 0.3 , split < 0.3
, mtl < 2.3 && >= 2.0 , mtl < 2.3 && >= 2.0
, ghc < 7.11 , ghc < 8.1
, monad-control ==1.0.* , monad-control ==1.0.*
, fclabels ==2.0.* , fclabels ==2.0.*
, optparse-applicative >=0.11.0 && <0.13.0 , optparse-applicative >=0.11.0 && <0.13.0
@ -231,13 +233,13 @@ Executable ghc-modi
Default-Extensions: ConstraintKinds, FlexibleContexts Default-Extensions: ConstraintKinds, FlexibleContexts
HS-Source-Dirs: src, . HS-Source-Dirs: src, .
Build-Depends: base < 5 && >= 4.0 Build-Depends: base < 5 && >= 4.0
, binary < 0.8 && >= 0.5.1.0 , binary < 0.9 && >= 0.5.1.0
, deepseq < 1.5 , deepseq < 1.5
, directory < 1.3 , directory < 1.3
, filepath < 1.5 , filepath < 1.5
, process < 1.3 , process < 1.5
, old-time < 1.2 , old-time < 1.2
, time < 1.6 , time < 1.7
, ghc-mod , ghc-mod
Test-Suite doctest Test-Suite doctest
@ -247,8 +249,6 @@ Test-Suite doctest
Ghc-Options: -Wall Ghc-Options: -Wall
Default-Extensions: ConstraintKinds, FlexibleContexts Default-Extensions: ConstraintKinds, FlexibleContexts
Main-Is: doctests.hs Main-Is: doctests.hs
if impl(ghc == 7.4.*)
Buildable: False
Build-Depends: base Build-Depends: base
, doctest >= 0.9.3 , doctest >= 0.9.3
@ -281,12 +281,8 @@ Test-Suite spec
ShellParseSpec ShellParseSpec
Build-Depends: hspec >= 2.0.0 Build-Depends: hspec >= 2.0.0
if impl(ghc == 7.4.*)
Build-Depends: executable-path
X-Build-Depends-Like: CLibName X-Build-Depends-Like: CLibName
Source-Repository head Source-Repository head
Type: git Type: git
Location: https://github.com/kazu-yamamoto/ghc-mod.git Location: https://github.com/kazu-yamamoto/ghc-mod.git

View File

@ -34,9 +34,12 @@ handler = flip gcatches
] ]
main :: IO () 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) [ catches (progMain res) [
Handler $ \(e :: GhcModError) -> Handler $ \(e :: GhcModError) ->
runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e) runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e)
@ -107,7 +110,6 @@ getFileSourceFromStdin = do
then fmap (x:) readStdin' then fmap (x:) readStdin'
else return [] else return []
-- Someone please already rewrite the cmdline parsing code *weep* :'(
wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m () wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m ()
wrapGhcCommands _opts CmdRoot = gmPutStr =<< rootInfo wrapGhcCommands _opts CmdRoot = gmPutStr =<< rootInfo
wrapGhcCommands opts cmd = wrapGhcCommands opts cmd =

View File

@ -25,14 +25,10 @@ module GHCMod.Options (
import Options.Applicative import Options.Applicative
import Options.Applicative.Types import Options.Applicative.Types
import Language.Haskell.GhcMod.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.Options.Commands
import GHCMod.Version 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 import GHCMod.Options.ShellParse
parseArgs :: IO (Options, GhcModCommands) parseArgs :: IO (Options, GhcModCommands)
@ -74,128 +70,3 @@ helpVersion =
argAndCmdSpec :: Parser (Options, GhcModCommands) argAndCmdSpec :: Parser (Options, GhcModCommands)
argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec 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)

View File

@ -23,8 +23,8 @@ import Options.Applicative.Types
import Options.Applicative.Builder.Internal import Options.Applicative.Builder.Internal
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Read 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 Symbol = String
type Expr = String type Expr = String

View File

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

View File

@ -123,13 +123,13 @@ spec = do
res <- runD $ do res <- runD $ do
loadMappedFile "File.hs" "File_Redir_Lint.hs" loadMappedFile "File.hs" "File_Redir_Lint.hs"
lint defaultLintOpts "File.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 it "lints in-memory file if one is specified and outputs original filename" $ do
withDirectory_ "test/data/file-mapping" $ do withDirectory_ "test/data/file-mapping" $ do
res <- runD $ do res <- runD $ do
loadMappedFileSource "File.hs" "func a b = (++) a b\n" loadMappedFileSource "File.hs" "func a b = (++) a b\n"
lint defaultLintOpts "File.hs" 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 it "shows types of the expression for redirected files" $ do
let tdir = "test/data/file-mapping" let tdir = "test/data/file-mapping"
res <- runD' tdir $ do res <- runD' tdir $ do
@ -184,14 +184,14 @@ spec = do
res <- runD $ do res <- runD $ do
loadMappedFile "File.hs" "File_Redir_Lint.hs" loadMappedFile "File.hs" "File_Redir_Lint.hs"
lint defaultLintOpts "File.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 it "lints in-memory file if one is specified and outputs original filename" $ do
withDirectory_ "test/data/file-mapping/preprocessor" $ do withDirectory_ "test/data/file-mapping/preprocessor" $ do
src <- readFile "File_Redir_Lint.hs" src <- readFile "File_Redir_Lint.hs"
res <- runD $ do res <- runD $ do
loadMappedFileSource "File.hs" src loadMappedFileSource "File.hs" src
lint defaultLintOpts "File.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"
describe "literate haskell tests" $ do describe "literate haskell tests" $ do
it "checks redirected file if one is specified and outputs original filename" $ do it "checks redirected file if one is specified and outputs original filename" $ do
withDirectory_ "test/data/file-mapping/lhs" $ do withDirectory_ "test/data/file-mapping/lhs" $ do

View File

@ -9,7 +9,7 @@ spec = do
describe "lint" $ do describe "lint" $ do
it "can detect a redundant import" $ do it "can detect a redundant import" $ do
res <- runD $ lint defaultLintOpts "test/data/hlint/hlint.hs" 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 context "when no suggestions are given" $ do
it "doesn't output an empty line" $ do it "doesn't output an empty line" $ do