hasufell
/
ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into find-cache-master

This commit is contained in:
Nikolay Yakimov 2016-03-02 00:25:30 +03:00
parent 2f1e586fea af6c18c162
commit 2feaf14325
21 changed files with 430 additions and 195 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.travis.yml
View File

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

12
Language/Haskell/GhcMod/DynFlags.hs
View File

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

2
Language/Haskell/GhcMod/FileMapping.hs
View File

@ -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

4
Language/Haskell/GhcMod/LightGhc.hs
View File

@ -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

2
Language/Haskell/GhcMod/Logger.hs
View File

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

2
src/GHCMod/Options/DocUtils.hs → Language/Haskell/GhcMod/Options/DocUtils.hs
View File

@ -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 (
($$),
($$$),
(<=>),

2
src/GHCMod/Options/Help.hs → Language/Haskell/GhcMod/Options/Help.hs
View File

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

38
Language/Haskell/GhcMod/Target.hs
View File

@ -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

8
Language/Haskell/GhcMod/Types.hs
View File

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

28
NotCPP/Declarations.hs
View File

@ -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

11
NotCPP/LookupValueName.hs
View File

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

19
NotCPP/Utils.hs
View File

@ -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

40
ghc-mod.cabal
View File

@ -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

10
src/GHCMod.hs
View File

@ -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 =

133
src/GHCMod/Options.hs
View File

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

4
src/GHCMod/Options/Commands.hs
View File

@ -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

5
stack.yaml
View File

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

8
test/FileMappingSpec.hs
View File

@ -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

2
test/LintSpec.hs
View File

@ -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