hhp 1.0.2 → 1.0.3
raw patch · 42 files changed
+1219/−856 lines, 42 filesdep ~hlintsetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: hlint
API changes (from Hackage documentation)
- Hhp.Ghc: data Ghc a
+ Hhp.Ghc: data () => Ghc a
Files
- ChangeLog.md +5/−1
- Setup.hs +1/−0
- elisp/hhp-check.el +1/−1
- elisp/hhp-func.el +8/−8
- hhp.cabal +12/−3
- lib/Hhp.hs +34/−31
- lib/Hhp/Boot.hs +12/−12
- lib/Hhp/Browse.hs +70/−47
- lib/Hhp/CabalApi.hs +119/−71
- lib/Hhp/Check.hs +41/−31
- lib/Hhp/Cradle.hs +48/−38
- lib/Hhp/Debug.hs +26/−24
- lib/Hhp/Doc.hs +17/−8
- lib/Hhp/Find.hs +19/−18
- lib/Hhp/Flag.hs +6/−6
- lib/Hhp/GHCApi.hs +73/−54
- lib/Hhp/Ghc.hs +40/−28
- lib/Hhp/GhcPkg.hs +94/−67
- lib/Hhp/Info.hs +81/−52
- lib/Hhp/Internal.hs +28/−25
- lib/Hhp/Lint.hs +11/−0
- lib/Hhp/List.hs +4/−4
- lib/Hhp/PkgDoc.hs +18/−15
- lib/Hhp/Syb.hs +4/−4
- lib/Hhp/Things.hs +26/−25
- lib/Hhp/Types.hs +94/−76
- src/hhpc.hs +105/−68
- src/hhpi.hs +116/−87
- test/BrowseSpec.hs +4/−2
- test/CabalApiSpec.hs +43/−26
- test/CheckSpec.hs +12/−5
- test/Dir.hs +12/−8
- test/GhcPkgSpec.hs +3/−2
- test/InfoSpec.hs +10/−5
- test/LintSpec.hs +11/−0
- test/data/Bar.hs +2/−0
- test/data/Baz.hs +2/−0
- test/data/Foo.hs +2/−1
- test/data/check-test-subdir/test/Bar/Baz.hs +1/−0
- test/data/check-test-subdir/test/Main.hs +1/−0
- test/data/hhp-check/Data/Foo.hs +2/−2
- test/data/hlint.hs +1/−1
ChangeLog.md view
@@ -1,12 +1,16 @@ # ChangeLog for HHP(Happy Haskell Programming) +## 2024-03-31 v1.0.3++- Supporting GHC 9.12+ ## 2023-03-17 v1.0.2 - Supporting GHC 9.6. ## 2022-09-15 v1.0.1 -- Supporting GHC 9.6.+- Supporting GHC 9.4. ## 2022-05-30 v1.0.0
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
elisp/hhp-check.el view
@@ -321,7 +321,7 @@ (let ((arity (or ar 1))) (save-excursion (goto-char (point-max))- (re-search-backward (format "^%s *::" (regexp-quote fn)))+ (re-search-backward (format "^%s +" (regexp-quote fn))) (forward-line) (re-search-forward "^$" nil t) (insert fn)
elisp/hhp-func.el view
@@ -160,6 +160,14 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro hhp-executable-find (cmd &rest body)+ ;; (declare (indent 1))+ `(if (not (executable-find ,cmd))+ (message "\"%s\" not found" ,cmd)+ ,@body))++(put 'hhp-executable-find 'lisp-indent-function 1)+ (defun hhp-run-hhp (cmds &optional prog) (let ((target (or prog hhpc-command))) (hhp-executable-find target@@ -169,14 +177,6 @@ (apply 'hhp-call-process target nil t nil (append (hhp-make-ghc-options) cmds)) (buffer-substring (point-min) (1- (point-max))))))))--(defmacro hhp-executable-find (cmd &rest body)- ;; (declare (indent 1))- `(if (not (executable-find ,cmd))- (message "\"%s\" not found" ,cmd)- ,@body))--(put 'hhp-executable-find 'lisp-indent-function 1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
hhp.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: hhp-version: 1.0.2+version: 1.0.3 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto <kazu@iij.ad.jp>@@ -60,6 +60,9 @@ type: git location: git://github.com/kazu-yamamoto/hhp.git +flag hlint+ description: Require hlint+ library exposed-modules: Hhp@@ -101,11 +104,14 @@ exceptions, filepath, ghc,- hlint >=1.8.61, process, syb, ghc-boot + if flag(hlint)+ cpp-options: -DHLINT+ build-depends: hlint >=1.8.61+ executable hhpc main-is: hhpc.hs hs-source-dirs: src@@ -185,5 +191,8 @@ hspec >=1.7.1, process, syb,- hlint >=1.7.1, ghc-boot++ if flag(hlint)+ cpp-options: -DHLINT+ build-depends: hlint >=1.8.61
lib/Hhp.hs view
@@ -1,37 +1,40 @@ -- | The Happy Haskell Programming library. -- API for commands.- module Hhp (- -- * Cradle- Cradle(..)- , findCradle- -- * Options- , Options(..)- , LineSeparator(..)- , OutputStyle(..)- , defaultOptions- -- * Types- , ModuleString- , Expression- -- * 'IO' utilities- , bootInfo- , browseModule- , checkSyntax- , lintSyntax- , expandTemplate- , infoExpr- , typeExpr- , listModules- , listLanguages- , listFlags- , debugInfo- , rootInfo- , packageDoc- , findSymbol- -- * Misc- , cProjectVersion- , cProjectVersionInt- ) where+ -- * Cradle+ Cradle (..),+ findCradle,++ -- * Options+ Options (..),+ LineSeparator (..),+ OutputStyle (..),+ defaultOptions,++ -- * Types+ ModuleString,+ Expression,++ -- * 'IO' utilities+ bootInfo,+ browseModule,+ checkSyntax,+ lintSyntax,+ expandTemplate,+ infoExpr,+ typeExpr,+ listModules,+ listLanguages,+ listFlags,+ debugInfo,+ rootInfo,+ packageDoc,+ findSymbol,++ -- * Misc+ cProjectVersion,+ cProjectVersionInt,+) where import Hhp.Boot import Hhp.Browse
lib/Hhp/Boot.hs view
@@ -19,20 +19,20 @@ -- | Printing necessary information for front-end booting. boot :: Options -> Ghc String boot opt = do- mods <- modules opt+ mods <- modules opt langs <- liftIO $ listLanguages opt flags <- liftIO $ listFlags opt- pre <- concat <$> mapM (browse opt) preBrowsedModules+ pre <- concat <$> mapM (browse opt) preBrowsedModules return $ mods ++ langs ++ flags ++ pre preBrowsedModules :: [String]-preBrowsedModules = [- "Prelude"- , "Control.Applicative"- , "Control.Exception"- , "Control.Monad"- , "Data.Char"- , "Data.List"- , "Data.Maybe"- , "System.IO"- ]+preBrowsedModules =+ [ "Prelude"+ , "Control.Applicative"+ , "Control.Exception"+ , "Control.Monad"+ , "Data.Char"+ , "Data.List"+ , "Data.Maybe"+ , "System.IO"+ ]
lib/Hhp/Browse.hs view
@@ -1,9 +1,18 @@ module Hhp.Browse (- browseModule- , browse- ) where+ browseModule,+ browse,+) where -import GHC (Ghc, GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon)+import GHC (+ DynFlags,+ Ghc,+ GhcException (CmdLineError),+ ModuleInfo,+ Name,+ TyCon,+ TyThing,+ Type,+ ) import qualified GHC as G import GHC.Core.TyCon (isAlgTyCon) import GHC.Core.Type (dropForAlls)@@ -13,7 +22,7 @@ import GHC.Utils.Monad (liftIO) import qualified Control.Exception as E-import Control.Monad.Catch (SomeException(..), handle, catch)+import Control.Monad.Catch (SomeException (..), catch, handle) import Data.Char (isAlpha) import Data.List (sort) import Data.Maybe (catMaybes)@@ -29,10 +38,12 @@ -- | Getting functions, classes, etc from a module. -- If 'detailed' is 'True', their types are also obtained. -- If 'operators' is 'True', operators are also returned.-browseModule :: Options- -> Cradle- -> ModuleString -- ^ A module name. (e.g. \"Data.List\")- -> IO String+browseModule+ :: Options+ -> Cradle+ -> ModuleString+ -- ^ A module name. (e.g. \"Data.List\")+ -> IO String browseModule opt cradle pkgmdl = withGHC' $ do initializeFlagsWithCradle opt cradle browse opt pkgmdl@@ -40,16 +51,18 @@ -- | Getting functions, classes, etc from a module. -- If 'detailed' is 'True', their types are also obtained. -- If 'operators' is 'True', operators are also returned.-browse :: Options- -> ModuleString -- ^ A module name. (e.g. \"Data.List\")- -> Ghc String+browse+ :: Options+ -> ModuleString+ -- ^ A module name. (e.g. \"Data.List\")+ -> Ghc String browse opt pkgmdl = do convert opt . sort <$> (getModule >>= listExports) where- (mpkg,mdl) = splitPkgMdl pkgmdl+ (mpkg, mdl) = splitPkgMdl pkgmdl mdlname = G.mkModuleName mdl mpkgid = mkFastString <$> mpkg- listExports Nothing = return []+ listExports Nothing = return [] listExports (Just mdinfo) = processExports opt mdinfo -- findModule works only for package modules, moreover, -- you cannot load a package module. On the other hand,@@ -62,51 +75,56 @@ -- But that of GHC 9.4 does not, sigh. mx <- G.findModule mdlname mpkgid >>= G.getModuleInfo case mx of- Just _ -> return mx- _ -> liftIO $ E.throwIO $ CmdLineError "for GHC 9.4"+ Just _ -> return mx+ _ -> liftIO $ E.throwIO $ CmdLineError "for GHC 9.4" browseLocalModule = handle handler $ do setTargetFiles [mdl] G.findModule mdlname Nothing >>= G.getModuleInfo fallback (CmdLineError _) = browseLocalModule- fallback _ = return Nothing+ fallback _ = return Nothing handler (SomeException _) = return Nothing+ -- | -- -- >>> splitPkgMdl "base:Prelude" -- (Just "base","Prelude") -- >>> splitPkgMdl "Prelude" -- (Nothing,"Prelude")-splitPkgMdl :: String -> (Maybe String,String)-splitPkgMdl pkgmdl = case break (==':') pkgmdl of- (mdl,"") -> (Nothing,mdl)- (pkg,_:mdl) -> (Just pkg,mdl)+splitPkgMdl :: String -> (Maybe String, String)+splitPkgMdl pkgmdl = case break (== ':') pkgmdl of+ (mdl, "") -> (Nothing, mdl)+ (pkg, _ : mdl) -> (Just pkg, mdl) processExports :: Options -> ModuleInfo -> Ghc [String] processExports opt minfo = mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo where removeOps- | operators opt = id- | otherwise = filter (isAlpha . head . getOccString)+ | operators opt = id+ | otherwise = filter (isAlpha . unsafeHead . getOccString) showExport :: Options -> ModuleInfo -> Name -> Ghc String showExport opt minfo e = do- mtype' <- mtype- return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']+ mtype' <- mtype+ return $+ concat $+ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype'] where- mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt+ mqualified =+ (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".")+ `justIf` qualified opt mtype- | detailed opt = do- tyInfo <- G.modInfoLookupName minfo e- -- If nothing found, load dependent module and lookup global- tyResult <- maybe (inOtherModule e) (return . Just) tyInfo- dflag <- G.getSessionDynFlags- return $ do- typeName <- tyResult >>= showThing dflag- (" :: " ++ typeName) `justIf` detailed opt- | otherwise = return Nothing- formatOp nm@(n:_)- | isAlpha n = nm- | otherwise = "(" ++ nm ++ ")"+ | detailed opt = do+ tyInfo <- G.modInfoLookupName minfo e+ -- If nothing found, load dependent module and lookup global+ tyResult <- maybe (inOtherModule e) (return . Just) tyInfo+ dflag <- G.getSessionDynFlags+ return $ do+ typeName <- tyResult >>= showThing dflag+ (" :: " ++ typeName) `justIf` detailed opt+ | otherwise = return Nothing+ formatOp nm@(n : _)+ | isAlpha n = nm+ | otherwise = "(" ++ nm ++ ")" formatOp "" = error "formatOp" inOtherModule :: Name -> Ghc (Maybe TyThing) inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm@@ -119,26 +137,31 @@ showThing' :: DynFlags -> GapThing -> Maybe String showThing' dflag (GtA a) = Just $ formatType dflag a-showThing' _ (GtT t) = unwords . toList <$> tyType t+showThing' _ (GtT t) = unwords . toList <$> tyType t where toList t' = t' : getOccString t : map getOccString (G.tyConTyVars t)-showThing' _ _ = Nothing+showThing' _ _ = Nothing formatType :: DynFlags -> Type -> String formatType dflag a = showOutputable dflag $ removeForAlls a showOutputable :: DynFlags -> Type -> String-showOutputable dflag = unwords . lines . showPage (initSDocContext dflag styleUnqualified) . pprSigmaType+showOutputable dflag =+ unwords+ . lines+ . showPage (initSDocContext dflag styleUnqualified)+ . pprSigmaType tyType :: TyCon -> Maybe String tyType typ | isAlgTyCon typ- && not (G.isNewTyCon typ)- && not (G.isClassTyCon typ) = Just "data"- | G.isNewTyCon typ = Just "newtype"- | G.isClassTyCon typ = Just "class"- | G.isTypeSynonymTyCon typ = Just "type"- | otherwise = Nothing+ && not (G.isNewTyCon typ)+ && not (G.isClassTyCon typ) =+ Just "data"+ | G.isNewTyCon typ = Just "newtype"+ | G.isClassTyCon typ = Just "class"+ | G.isTypeSynonymTyCon typ = Just "type"+ | otherwise = Nothing removeForAlls :: Type -> Type removeForAlls = dropForAlls
lib/Hhp/CabalApi.hs view
@@ -1,29 +1,36 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} module Hhp.CabalApi (- getCompilerOptions- , parseCabalFile- , cabalAllBuildInfo- , cabalDependPackages- , cabalSourceDirs- , cabalAllTargets- ) where+ getCompilerOptions,+ parseCabalFile,+ cabalAllBuildInfo,+ cabalDependPackages,+ cabalSourceDirs,+ cabalAllTargets,+) where -import Distribution.Compiler (unknownCompilerInfo, AbiTag(NoAbiTag))-import Distribution.ModuleName (ModuleName,toFilePath)-import Distribution.Package (Dependency(Dependency))+import Distribution.Compiler (AbiTag (NoAbiTag), unknownCompilerInfo)+import Distribution.ModuleName (ModuleName, toFilePath)+import Distribution.Package (Dependency (Dependency)) import qualified Distribution.Package as C-import Distribution.PackageDescription (PackageDescription, BuildInfo, TestSuite, TestSuiteInterface(..), Executable)+import Distribution.PackageDescription (+ BuildInfo,+ Executable,+ PackageDescription,+ TestSuite,+ TestSuiteInterface (..),+ ) import qualified Distribution.PackageDescription as P-import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..))+import Distribution.PackageDescription.Configuration (finalizePD)+import Distribution.Simple.Compiler (CompilerFlavor (..), CompilerId (..)) import Distribution.Simple.Program (ghcProgram)-import Distribution.Simple.Program.Types (programName, programFindVersion)+import Distribution.Simple.Program.Types (programFindVersion, programName) import Distribution.System (buildPlatform) import Distribution.Text (display) import Distribution.Verbosity (silent) import Distribution.Version (Version)-import Distribution.PackageDescription.Configuration (finalizePD) #if MIN_VERSION_Cabal(3,8,0) import Distribution.Simple.PackageDescription (readGenericPackageDescription) #else@@ -35,41 +42,46 @@ #if MIN_VERSION_Cabal(3,6,0) import Distribution.Utils.Path (getSymbolicPath, SymbolicPath) #endif+#if MIN_VERSION_Cabal(3,14,0)+import qualified Distribution.Utils.Path as Path+#endif import GHC.Utils.Monad (liftIO) import Control.Exception (throwIO) import Control.Monad (filterM)-import Data.Maybe (maybeToList, mapMaybe, fromMaybe)+import Data.Maybe (fromMaybe, mapMaybe, maybeToList) import Data.Set (fromList, toList) import System.Directory (doesFileExist) import System.Environment (lookupEnv) import System.FilePath (dropExtension, takeFileName, (</>)) -import Hhp.Types import Hhp.GhcPkg+import Hhp.Types ---------------------------------------------------------------- -- | Getting necessary 'CompilerOptions' from three information sources.-getCompilerOptions :: [GHCOption]- -> Cradle- -> PackageDescription- -> IO CompilerOptions+getCompilerOptions+ :: [GHCOption]+ -> Cradle+ -> PackageDescription+ -> IO CompilerOptions getCompilerOptions ghcopts cradle pkgDesc = do- gopts <- getGHCOptions ghcopts cradle rdir $ head buildInfos+ gopts <- getGHCOptions ghcopts cradle rdir $ unsafeHead buildInfos dbPkgs <- ghcPkgListEx (cradlePkgDbStack cradle) return $ CompilerOptions gopts idirs (depPkgs dbPkgs) where- wdir = cradleCurrentDir cradle- rdir = cradleRootDir cradle- cfile = fromMaybe "error getCompilerOptions" $ cradleCabalFile cradle- thisPkg = dropExtension $ takeFileName cfile+ wdir = cradleCurrentDir cradle+ rdir = cradleRootDir cradle+ cfile = fromMaybe "error getCompilerOptions" $ cradleCabalFile cradle+ thisPkg = dropExtension $ takeFileName cfile buildInfos = cabalAllBuildInfo pkgDesc- idirs = includeDirectories rdir wdir $ cabalSourceDirs buildInfos- depPkgs ps = attachPackageIds ps- $ removeThem (problematicPackages ++ [thisPkg])- $ cabalDependPackages buildInfos+ idirs = includeDirectories rdir wdir $ cabalSourceDirs buildInfos+ depPkgs ps =+ attachPackageIds ps $+ removeThem (problematicPackages ++ [thisPkg]) $+ cabalDependPackages buildInfos ---------------------------------------------------------------- -- Dependent packages@@ -78,16 +90,16 @@ removeThem badpkgs = filter (`notElem` badpkgs) problematicPackages :: [PackageBaseName]-problematicPackages = [- "base-compat" -- providing "Prelude"- ]+problematicPackages =+ [ "base-compat" -- providing "Prelude"+ ] attachPackageIds :: [Package] -> [PackageBaseName] -> [Package] attachPackageIds pkgs = mapMaybe (`lookup3` pkgs) -lookup3 :: Eq a => a -> [(a,b,c)] -> Maybe (a,b,c)+lookup3 :: Eq a => a -> [(a, b, c)] -> Maybe (a, b, c) lookup3 _ [] = Nothing-lookup3 k (t@(a,_,_):ls)+lookup3 k (t@(a, _, _) : ls) | k == a = Just t | otherwise = lookup3 k ls @@ -98,10 +110,10 @@ cabalBuildDirs = ["dist/build", "dist/build/autogen"] includeDirectories :: FilePath -> FilePath -> [FilePath] -> [FilePath]-includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir])+includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir, wdir]) where extdirs = map expand $ dirs ++ cabalBuildDirs- expand "." = cdir+ expand "." = cdir expand subdir = cdir </> subdir ----------------------------------------------------------------@@ -112,27 +124,30 @@ parseCabalFile file = do cid <- getGHCId let cid' = unknownCompilerInfo cid NoAbiTag- epgd <- readGenericPackageDescription silent file+ epgd <- readPackageDescription file flags <- getFlags case toPkgDesc cid' flags epgd of- Left deps -> throwIO $ userError $ show deps ++ " are not installed"- Right (pd,_) -> if nullPkg pd- then throwIO $ userError $ file ++ " is broken"- else return pd+ Left deps -> throwIO $ userError $ show deps ++ " are not installed"+ Right (pd, _) ->+ if nullPkg pd+ then throwIO $ userError $ file ++ " is broken"+ else return pd where envFlags = do- let parseF [] = []- parseF ccs@(c:cs)- | c == '-' = [(mkFlagName cs, False)]- | otherwise = [(mkFlagName ccs, True)]- maybe [] (concatMap parseF . words) `fmap` lookupEnv "HHP_CABAL_FLAGS"+ let parseF [] = []+ parseF ccs@(c : cs)+ | c == '-' = [(mkFlagName cs, False)]+ | otherwise = [(mkFlagName ccs, True)]+ maybe [] (concatMap parseF . words) `fmap` lookupEnv "HHP_CABAL_FLAGS" getFlags = mkFlagAssignment <$> envFlags nullPkg pd = unPackageName (C.pkgName (P.package pd)) == ""- toPkgDesc cid flags = finalizePD flags defaultComponentRequestedSpec (const True) buildPlatform cid []+ toPkgDesc cid flags =+ finalizePD flags defaultComponentRequestedSpec (const True) buildPlatform cid [] ---------------------------------------------------------------- -getGHCOptions :: [GHCOption] -> Cradle -> FilePath -> BuildInfo -> IO [GHCOption]+getGHCOptions+ :: [GHCOption] -> Cradle -> FilePath -> BuildInfo -> IO [GHCOption] getGHCOptions ghcopts cradle rdir binfo = do cabalCpp <- cabalCppOptions rdir let cpps = map ("-optP" ++) $ P.cppOptions binfo ++ cabalCpp@@ -140,17 +155,17 @@ where pkgDb = ghcDbStackOpts $ cradlePkgDbStack cradle lang = maybe "-XHaskell98" (("-X" ++) . display) $ P.defaultLanguage binfo- libDirs = map ("-L" ++) $ P.extraLibDirs binfo+ libDirs = map ("-L" ++) $ extLibDirs binfo exts = map (("-X" ++) . display) $ P.usedExtensions binfo libs = map ("-l" ++) $ P.extraLibs binfo cabalCppOptions :: FilePath -> IO [String] cabalCppOptions dir = do exist <- doesFileExist cabalMacro- return $ if exist then- ["-include", cabalMacro]- else- []+ return $+ if exist+ then ["-include", cabalMacro]+ else [] where cabalMacro = dir </> "dist/build/autogen/cabal_macros.h" @@ -160,10 +175,10 @@ cabalAllBuildInfo :: PackageDescription -> [BuildInfo] cabalAllBuildInfo pd = libBI ++ subBI ++ execBI ++ testBI ++ benchBI where- libBI = map P.libBuildInfo $ maybeToList $ P.library pd- subBI = map P.libBuildInfo $ P.subLibraries pd- execBI = map P.buildInfo $ P.executables pd- testBI = map P.testBuildInfo $ P.testSuites pd+ libBI = map P.libBuildInfo $ maybeToList $ P.library pd+ subBI = map P.libBuildInfo $ P.subLibraries pd+ execBI = map P.buildInfo $ P.executables pd+ testBI = map P.testBuildInfo $ P.testSuites pd benchBI = map P.benchmarkBuildInfo $ P.benchmarks pd ----------------------------------------------------------------@@ -196,46 +211,79 @@ mv <- programFindVersion ghcProgram silent (programName ghcProgram) case mv of Nothing -> throwIO $ userError "ghc not found"- Just v -> return v+ Just v -> return v ---------------------------------------------------------------- -- | Extracting all 'Module' 'FilePath's for libraries, executables, -- tests and benchmarks.-cabalAllTargets :: PackageDescription -> IO ([String],[String],[String],[String])+cabalAllTargets+ :: PackageDescription -> IO ([String], [String], [String], [String]) cabalAllTargets pd = do- exeTargets <- mapM getExecutableTarget $ P.executables pd+ exeTargets <- mapM getExecutableTarget $ P.executables pd testTargets <- mapM getTestTarget $ P.testSuites pd- return (libTargets,concat exeTargets,concat testTargets,benchTargets)+ return (libTargets, concat exeTargets, concat testTargets, benchTargets) where lib = maybe [] P.explicitLibModules $ P.library pd libTargets = map toModuleString lib- benchTargets = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks pd+ benchTargets = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks pd toModuleString :: ModuleName -> String toModuleString mn = fromFilePath $ toFilePath mn fromFilePath :: FilePath -> String- fromFilePath fp = map (\c -> if c=='/' then '.' else c) fp+ fromFilePath fp = map (\c -> if c == '/' then '.' else c) fp getTestTarget :: TestSuite -> IO [String] getTestTarget ts =- case P.testInterface ts of- (TestSuiteExeV10 _ filePath) -> do- let maybeTests = [toPath p </> e | p <- P.hsSourceDirs $ P.testBuildInfo ts, e <- [filePath]]- liftIO $ filterM doesFileExist maybeTests- (TestSuiteLibV09 _ moduleName) -> return [toModuleString moduleName]- (TestSuiteUnsupported _) -> return []+ case P.testInterface ts of+ (TestSuiteExeV10 _ filePath) -> do+ let maybeTests =+ [ p <//> e+ | p <- P.hsSourceDirs $ P.testBuildInfo ts+ , e <- [filePath]+ ]+ liftIO $ filterM doesFileExist maybeTests+ (TestSuiteLibV09 _ moduleName) -> return [toModuleString moduleName]+ (TestSuiteUnsupported _) -> return [] getExecutableTarget :: Executable -> IO [String] getExecutableTarget exe = do- let maybeExes = [toPath p </> e | p <- P.hsSourceDirs $ P.buildInfo exe, e <- [P.modulePath exe]]- liftIO $ filterM doesFileExist maybeExes+ let maybeExes =+ [ p <//> e+ | p <- P.hsSourceDirs $ P.buildInfo exe+ , e <- [P.modulePath exe]+ ]+ liftIO $ filterM doesFileExist maybeExes +#if MIN_VERSION_Cabal(3,14,0)+(<//>) :: SymbolicPath Path.Pkg (Path.Dir Path.Source)+ -> Path.RelativePath Path.Source Path.File+ -> FilePath+dir <//> file = toPath (dir Path.</> file)+#else+(<//>) :: SymbolicPath from to -> FilePath -> FilePath+dir <//> file = toPath dir </> file+#endif++extLibDirs :: BuildInfo -> [FilePath]+#if MIN_VERSION_Cabal(3,14,0)+extLibDirs = map getSymbolicPath . P.extraLibDirs+#else+extLibDirs = P.extraLibDirs+#endif+ #if MIN_VERSION_Cabal(3,6,0) toPath :: SymbolicPath from to -> FilePath toPath = getSymbolicPath #else toPath :: String -> String toPath = id+#endif++readPackageDescription :: FilePath -> IO P.GenericPackageDescription+#if MIN_VERSION_Cabal(3,14,0)+readPackageDescription = readGenericPackageDescription silent Nothing . Path.makeSymbolicPath+#else+readPackageDescription = readGenericPackageDescription silent #endif
lib/Hhp/Check.hs view
@@ -1,12 +1,12 @@ module Hhp.Check (- checkSyntax- , check- , expandTemplate- , expand- ) where+ checkSyntax,+ check,+ expandTemplate,+ expand,+) where -import GHC (Ghc, DynFlags(..))-import GHC.Driver.Session (dopt_set, DumpFlag(Opt_D_dump_splices))+import GHC (DynFlags (..), Ghc)+import GHC.Driver.Session (DumpFlag (Opt_D_dump_splices), dopt_set) import Hhp.GHCApi import Hhp.Logger@@ -16,53 +16,63 @@ -- | Checking syntax of a target file using GHC. -- Warnings and errors are returned.-checkSyntax :: Options- -> Cradle- -> [FilePath] -- ^ The target files.- -> IO String-checkSyntax _ _ [] = return ""+checkSyntax+ :: Options+ -> Cradle+ -> [FilePath]+ -- ^ The target files.+ -> IO String+checkSyntax _ _ [] = return "" checkSyntax opt cradle files = withGHC sessionName $ do initializeFlagsWithCradle opt cradle either id id <$> check opt files where sessionName = case files of- [file] -> file- _ -> "MultipleFiles"+ [file] -> file+ _ -> "MultipleFiles" ---------------------------------------------------------------- -- | Checking syntax of a target file using GHC. -- Warnings and errors are returned.-check :: Options- -> [FilePath] -- ^ The target files.- -> Ghc (Either String String)-check opt fileNames = withLogger opt (setAllWarningFlags . setPartialSignatures . setDeferTypedHoles) $- setTargetFiles fileNames+check+ :: Options+ -> [FilePath]+ -- ^ The target files.+ -> Ghc (Either String String)+check opt fileNames =+ withLogger opt (setAllWarningFlags . setPartialSignatures . setDeferTypedHoles) $+ setTargetFiles fileNames ---------------------------------------------------------------- -- | Expanding Haskell Template.-expandTemplate :: Options- -> Cradle- -> [FilePath] -- ^ The target files.- -> IO String-expandTemplate _ _ [] = return ""+expandTemplate+ :: Options+ -> Cradle+ -> [FilePath]+ -- ^ The target files.+ -> IO String+expandTemplate _ _ [] = return "" expandTemplate opt cradle files = withGHC sessionName $ do initializeFlagsWithCradle opt cradle either id id <$> expand opt files where sessionName = case files of- [file] -> file- _ -> "MultipleFiles"+ [file] -> file+ _ -> "MultipleFiles" ---------------------------------------------------------------- -- | Expanding Haskell Template.-expand :: Options- -> [FilePath] -- ^ The target files.- -> Ghc (Either String String)-expand opt fileNames = withLogger opt (setDumpSplices . setNoWarningFlags) $- setTargetFiles fileNames+expand+ :: Options+ -> [FilePath]+ -- ^ The target files.+ -> Ghc (Either String String)+expand opt fileNames =+ withLogger opt (setDumpSplices . setNoWarningFlags) $+ setTargetFiles fileNames setDumpSplices :: DynFlags -> DynFlags setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices
lib/Hhp/Cradle.hs view
@@ -1,17 +1,21 @@ module Hhp.Cradle (- findCradle- , findCradleWithoutSandbox- ) where+ findCradle,+ findCradleWithoutSandbox,+) where import Control.Applicative ((<|>)) import qualified Control.Exception as E import Control.Monad (filterM) import Data.List (isSuffixOf)-import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist)-import System.FilePath ((</>), takeDirectory)+import System.Directory (+ doesFileExist,+ getCurrentDirectory,+ getDirectoryContents,+ )+import System.FilePath (takeDirectory, (</>)) -import Hhp.Types import Hhp.GhcPkg+import Hhp.Types ---------------------------------------------------------------- @@ -26,39 +30,43 @@ cabalCradle :: FilePath -> IO Cradle cabalCradle wdir = do- (rdir,cfile) <- cabalDir wdir+ (rdir, cfile) <- cabalDir wdir pkgDbStack <- getPackageDbStack rdir- return Cradle {- cradleCurrentDir = wdir- , cradleRootDir = rdir- , cradleCabalFile = Just cfile- , cradlePkgDbStack = pkgDbStack- }+ return+ Cradle+ { cradleCurrentDir = wdir+ , cradleRootDir = rdir+ , cradleCabalFile = Just cfile+ , cradlePkgDbStack = pkgDbStack+ } sandboxCradle :: FilePath -> IO Cradle sandboxCradle wdir = do rdir <- getSandboxDir wdir pkgDbStack <- getPackageDbStack rdir- return Cradle {- cradleCurrentDir = wdir- , cradleRootDir = rdir- , cradleCabalFile = Nothing- , cradlePkgDbStack = pkgDbStack- }+ return+ Cradle+ { cradleCurrentDir = wdir+ , cradleRootDir = rdir+ , cradleCabalFile = Nothing+ , cradlePkgDbStack = pkgDbStack+ } plainCradle :: FilePath -> IO Cradle-plainCradle wdir = return Cradle {- cradleCurrentDir = wdir- , cradleRootDir = wdir- , cradleCabalFile = Nothing- , cradlePkgDbStack = [GlobalDb]- }+plainCradle wdir =+ return+ Cradle+ { cradleCurrentDir = wdir+ , cradleRootDir = wdir+ , cradleCabalFile = Nothing+ , cradlePkgDbStack = [GlobalDb]+ } -- Just for testing findCradleWithoutSandbox :: IO Cradle findCradleWithoutSandbox = do cradle <- findCradle- return cradle { cradlePkgDbStack = [GlobalDb]}+ return cradle{cradlePkgDbStack = [GlobalDb]} ---------------------------------------------------------------- @@ -72,21 +80,23 @@ -- Input: a directly to investigate -- Output: (the path to the directory containing a Cabal file -- ,the path to the Cabal file)-cabalDir :: FilePath -> IO (FilePath,FilePath)+cabalDir :: FilePath -> IO (FilePath, FilePath) cabalDir dir = do cnts <- getCabalFiles dir case cnts of- [] | dir' == dir -> E.throwIO $ userError "cabal files not found"- | otherwise -> cabalDir dir'- cfile:_ -> return (dir,dir </> cfile)+ []+ | dir' == dir -> E.throwIO $ userError "cabal files not found"+ | otherwise -> cabalDir dir'+ cfile : _ -> return (dir, dir </> cfile) where dir' = takeDirectory dir getCabalFiles :: FilePath -> IO [FilePath] getCabalFiles dir = getFiles >>= filterM doesCabalFileExist where- isCabal name = cabalSuffix `isSuffixOf` name- && length name > cabalSuffixLength+ isCabal name =+ cabalSuffix `isSuffixOf` name+ && length name > cabalSuffixLength getFiles = filter isCabal <$> getDirectoryContents dir doesCabalFileExist file = doesFileExist $ dir </> file @@ -95,12 +105,12 @@ getSandboxDir :: FilePath -> IO FilePath getSandboxDir dir = do exist <- doesFileExist sfile- if exist then- return dir- else if dir == dir' then- E.throwIO $ userError "sandbox not found"- else- getSandboxDir dir'+ if exist+ then return dir+ else+ if dir == dir'+ then E.throwIO $ userError "sandbox not found"+ else getSandboxDir dir' where sfile = dir </> "cabal.sandbox.config" dir' = takeDirectory dir
lib/Hhp/Debug.hs view
@@ -4,7 +4,7 @@ import Control.Applicative ((<|>)) import Data.List (intercalate)-import Data.Maybe (fromMaybe, isJust, fromJust)+import Data.Maybe (fromJust, fromMaybe, isJust) import Hhp.CabalApi import Hhp.GHCApi@@ -13,29 +13,30 @@ ---------------------------------------------------------------- -- | Obtaining debug information.-debugInfo :: Options- -> Cradle- -> IO String-debugInfo opt cradle = convert opt <$> do- CompilerOptions gopts incDir pkgs <-- if cabal then- liftIO (fromCabalFile <|> return simpleCompilerOption)- else- return simpleCompilerOption- mglibdir <- liftIO getSystemLibDir- return [- "Root directory: " ++ rootDir- , "Current directory: " ++ currentDir- , "Cabal file: " ++ cabalFile- , "GHC options: " ++ unwords gopts- , "Include directories: " ++ unwords incDir- , "Dependent packages: " ++ intercalate ", " (map showPkg pkgs)- , "System libraries: " ++ fromMaybe "" mglibdir- ]+debugInfo+ :: Options+ -> Cradle+ -> IO String+debugInfo opt cradle =+ convert opt <$> do+ CompilerOptions gopts incDir pkgs <-+ if cabal+ then liftIO (fromCabalFile <|> return simpleCompilerOption)+ else return simpleCompilerOption+ mglibdir <- liftIO getSystemLibDir+ return+ [ "Root directory: " ++ rootDir+ , "Current directory: " ++ currentDir+ , "Cabal file: " ++ cabalFile+ , "GHC options: " ++ unwords gopts+ , "Include directories: " ++ unwords incDir+ , "Dependent packages: " ++ intercalate ", " (map showPkg pkgs)+ , "System libraries: " ++ fromMaybe "" mglibdir+ ] where currentDir = cradleCurrentDir cradle mCabalFile = cradleCabalFile cradle- rootDir = cradleRootDir cradle+ rootDir = cradleRootDir cradle cabal = isJust mCabalFile cabalFile = fromMaybe "" mCabalFile origGopts = ghcOpts opt@@ -49,7 +50,8 @@ ---------------------------------------------------------------- -- | Obtaining root information.-rootInfo :: Options- -> Cradle- -> IO String+rootInfo+ :: Options+ -> Cradle+ -> IO String rootInfo opt cradle = return $ convert opt $ cradleRootDir cradle
lib/Hhp/Doc.hs view
@@ -1,13 +1,22 @@ module Hhp.Doc (- showPage- , showOneLine- , getStyle- , styleUnqualified- ) where+ showPage,+ showOneLine,+ getStyle,+ styleUnqualified,+) where import GHC (Ghc)-import GHC.Utils.Outputable (PprStyle, SDoc, neverQualify, runSDoc, PprStyle, Depth(..), mkUserStyle, sdocLineLength, SDocContext)-import GHC.Utils.Ppr (Mode(..), Style(..), renderStyle, style)+import GHC.Utils.Outputable (+ Depth (..),+ PprStyle,+ SDoc,+ SDocContext,+ mkUserStyle,+ neverQualify,+ runSDoc,+ sdocLineLength,+ )+import GHC.Utils.Ppr (Mode (..), Style (..), renderStyle, style) import Hhp.Gap @@ -23,7 +32,7 @@ showSDocWithMode md ctx sdoc = renderStyle style' doc where doc = runSDoc sdoc ctx- style' = style { mode = md, lineLength = sdocLineLength ctx }+ style' = style{mode = md, lineLength = sdocLineLength ctx} ----------------------------------------------------------------
lib/Hhp/Find.hs view
@@ -1,35 +1,36 @@ {-# LANGUAGE BangPatterns #-} module Hhp.Find (- Symbol- , SymMdlDb- , findSymbol- , getSymMdlDb- , lookupSym- ) where+ Symbol,+ SymMdlDb,+ findSymbol,+ getSymMdlDb,+ lookupSym,+) where -import GHC (Ghc, DynFlags, Module, ModuleInfo)+import GHC (DynFlags, Ghc, Module, ModuleInfo) import qualified GHC as G-import GHC.Unit.Info (UnitInfo, unitExposedModules, mkUnit)-import GHC.Unit.State (listUnitInfo, UnitState)-import GHC.Utils.Outputable (ppr) import GHC.Driver.Session (initSDocContext)+import GHC.Unit.Info (UnitInfo, mkUnit, unitExposedModules)+import GHC.Unit.State (UnitState, listUnitInfo)+import GHC.Utils.Outputable (ppr) import Control.DeepSeq (force)-import Control.Monad.Catch (SomeException(..), catch)+import Control.Monad.Catch (SomeException (..), catch) import Data.Function (on) import Data.List (groupBy, sort) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M-import Data.Maybe (fromMaybe, catMaybes)+import Data.Maybe (catMaybes, fromMaybe) import Hhp.Doc (showOneLine, styleUnqualified)-import Hhp.Gap import Hhp.GHCApi+import Hhp.Gap import Hhp.Types -- | Type of key for `SymMdlDb`. type Symbol = String+ -- | Database from 'Symbol' to modules. newtype SymMdlDb = SymMdlDb (Map Symbol [ModuleString]) @@ -47,7 +48,7 @@ !m = force $ M.fromList sms return (SymMdlDb m) where- tieup x = (head (map fst x), map snd x)+ tieup x = (unsafeHead (map fst x), map snd x) -- | Looking up 'SymMdlDb' with 'Symbol' to find modules. lookupSym :: Options -> Symbol -> SymMdlDb -> String@@ -56,7 +57,7 @@ ---------------------------------------------------------------- -- | Browsing all functions in all system/user modules.-browseAll :: DynFlags -> Ghc [(String,String)]+browseAll :: DynFlags -> Ghc [(String, String)] browseAll dflag = do ms <- packageModules <$> getUnitState is <- catMaybes <$> mapM getMaybeModuleInfo ms@@ -66,9 +67,9 @@ getMaybeModuleInfo :: Module -> Ghc (Maybe (Maybe ModuleInfo)) getMaybeModuleInfo x = Just <$> G.getModuleInfo x `catch` (\(SomeException _) -> return Nothing) -toNameModule :: DynFlags -> (Module, Maybe ModuleInfo) -> [(String,String)]-toNameModule _ (_,Nothing) = []-toNameModule dflag (m,Just inf) = map (\name -> (toStr name, mdl)) names+toNameModule :: DynFlags -> (Module, Maybe ModuleInfo) -> [(String, String)]+toNameModule _ (_, Nothing) = []+toNameModule dflag (m, Just inf) = map (\name -> (toStr name, mdl)) names where mdl = G.moduleNameString (G.moduleName m) names = G.modInfoExports inf
lib/Hhp/Flag.hs view
@@ -1,18 +1,18 @@ module Hhp.Flag where -import GHC.Driver.Session (flagSpecName, fFlags, wWarningFlags, fLangFlags)+import GHC.Driver.Session (fFlags, fLangFlags, flagSpecName, wWarningFlags) import Hhp.Types -- | Listing GHC flags. (e.g -Wno-orphans)- listFlags :: Options -> IO String listFlags opt = return $ convert opt options where options = expand "-f" fOptions ++ expand "-W" wOptions fOptions = map flagSpecName fFlags ++ map flagSpecName fLangFlags wOptions = map flagSpecName wWarningFlags- expand prefix lst = [ prefix ++ no ++ option- | option <- lst- , no <- ["","no-"]- ]+ expand prefix lst =+ [ prefix ++ no ++ option+ | option <- lst+ , no <- ["", "no-"]+ ]
lib/Hhp/GHCApi.hs view
@@ -1,35 +1,46 @@-{-# LANGUAGE ScopedTypeVariables, RecordWildCards #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} module Hhp.GHCApi (- withGHC- , withGHC'- , initializeFlagsWithCradle- , setTargetFiles- , getDynamicFlags- , getSystemLibDir- , withDynFlags- , withCmdFlags- , setNoWarningFlags- , setAllWarningFlags- , setDeferTypedHoles- , setDeferTypeErrors- , setPartialSignatures- , setWarnTypedHoles- ) where+ withGHC,+ withGHC',+ initializeFlagsWithCradle,+ setTargetFiles,+ getDynamicFlags,+ getSystemLibDir,+ withDynFlags,+ withCmdFlags,+ setNoWarningFlags,+ setAllWarningFlags,+ setDeferTypedHoles,+ setDeferTypeErrors,+ setPartialSignatures,+ setWarnTypedHoles,+) where -import GHC (Ghc, DynFlags(..), LoadHowMuch(..))+import GHC (DynFlags (..), Ghc, LoadHowMuch (..)) import qualified GHC as G import qualified GHC.Data.EnumSet as E (EnumSet, empty)-import GHC.Driver.Session (GeneralFlag(Opt_BuildingCabalPackage, Opt_HideAllPackages),WarningFlag(Opt_WarnTypedHoles),gopt_set, xopt_set, wopt_set,ModRenaming(..), PackageFlag(ExposePackage), PackageArg(..), WarningFlag, parseDynamicFlagsCmdLine)-import GHC.LanguageExtensions (Extension(..))+import GHC.Driver.Session (+ GeneralFlag (Opt_BuildingCabalPackage, Opt_HideAllPackages),+ ModRenaming (..),+ PackageArg (..),+ PackageFlag (ExposePackage),+ WarningFlag (Opt_WarnTypedHoles),+ gopt_set,+ parseDynamicFlagsCmdLine,+ wopt_set,+ xopt_set,+ )+import GHC.LanguageExtensions (Extension (..)) import GHC.Utils.Monad (liftIO) import Control.Applicative ((<|>)) import Control.Monad (forM, void)-import Control.Monad.Catch (SomeException, handle, bracket)-import Data.Maybe (isJust, fromJust)+import Control.Monad.Catch (SomeException, bracket, handle)+import Data.Maybe (fromJust, isJust) import System.Exit (exitSuccess)-import System.IO (hPutStr, hPrint, stderr)+import System.IO (hPrint, hPutStr, stderr) import System.IO.Unsafe (unsafePerformIO) import System.Process (readProcess) @@ -45,15 +56,18 @@ getSystemLibDir = do res <- readProcess "ghc" ["--print-libdir"] [] return $ case res of- "" -> Nothing+ "" -> Nothing dirn -> Just (init dirn) ---------------------------------------------------------------- -- | Converting the 'Ghc' monad to the 'IO' monad.-withGHC :: FilePath -- ^ A target file displayed in an error message.- -> Ghc a -- ^ 'Ghc' actions created by the Ghc utilities.- -> IO a+withGHC+ :: FilePath+ -- ^ A target file displayed in an error message.+ -> Ghc a+ -- ^ 'Ghc' actions created by the Ghc utilities.+ -> IO a withGHC file body = handle ignore $ withGHC' body where ignore :: SomeException -> IO a@@ -70,20 +84,20 @@ ---------------------------------------------------------------- importDirs :: [IncludeDir]-importDirs = [".","..","../..","../../..","../../../..","../../../../.."]+importDirs = [".", "..", "../..", "../../..", "../../../..", "../../../../.."] -data Build = CabalPkg | SingleFile deriving Eq+data Build = CabalPkg | SingleFile deriving (Eq) -- | Initialize the 'DynFlags' relating to the compilation of a single -- file or GHC session according to the 'Cradle' and 'Options' -- provided.-initializeFlagsWithCradle ::- Options- -> Cradle- -> Ghc ()+initializeFlagsWithCradle+ :: Options+ -> Cradle+ -> Ghc () initializeFlagsWithCradle opt cradle- | cabal = withCabal <|> withSandbox- | otherwise = withSandbox+ | cabal = withCabal <|> withSandbox+ | otherwise = withSandbox where mCradleFile = cradleCabalFile cradle cabal = isJust mCradleFile@@ -96,30 +110,35 @@ where pkgOpts = ghcDbStackOpts $ cradlePkgDbStack cradle compOpts- | null pkgOpts = CompilerOptions ghcopts importDirs []- | otherwise = CompilerOptions (ghcopts ++ pkgOpts) [wdir,rdir] []+ | null pkgOpts = CompilerOptions ghcopts importDirs []+ | otherwise = CompilerOptions (ghcopts ++ pkgOpts) [wdir, rdir] [] wdir = cradleCurrentDir cradle- rdir = cradleRootDir cradle+ rdir = cradleRootDir cradle ---------------------------------------------------------------- -initSession :: Build- -> Options- -> CompilerOptions- -> Ghc ()+initSession+ :: Build+ -> Options+ -> CompilerOptions+ -> Ghc () initSession build Options{} CompilerOptions{..} = do df <- G.getSessionDynFlags- void $ G.setSessionDynFlags =<< addCmdOpts ghcOptions- ( setLinkerOptions- $ setIncludeDirs includeDirs- $ setBuildEnv build- $ setEmptyLogger- $ addPackageFlags depPackages df)+ void $+ G.setSessionDynFlags+ =<< addCmdOpts+ ghcOptions+ ( setLinkerOptions $+ setIncludeDirs includeDirs $+ setBuildEnv build $+ setEmptyLogger $+ addPackageFlags depPackages df+ ) ---------------------------------------------------------------- setIncludeDirs :: [IncludeDir] -> DynFlags -> DynFlags-setIncludeDirs idirs df = df { importPaths = idirs }+setIncludeDirs idirs df = df{importPaths = idirs} setBuildEnv :: Build -> DynFlags -> DynFlags setBuildEnv build = setHideAllPackages build . setCabalPackage build@@ -134,14 +153,14 @@ -- | Enable hiding of all package not explicitly exposed (like Cabal does) setHideAllPackages :: Build -> DynFlags -> DynFlags setHideAllPackages CabalPkg df = gopt_set df Opt_HideAllPackages-setHideAllPackages _ df = df+setHideAllPackages _ df = df -- | Parse command line ghc options and add them to the 'DynFlags' passed addCmdOpts :: [GHCOption] -> DynFlags -> Ghc DynFlags addCmdOpts cmdOpts df = tfst <$> parseDynamicFlagsCmdLine df (map G.noLoc cmdOpts) where- tfst (a,_,_) = a+ tfst (a, _, _) = a ---------------------------------------------------------------- @@ -198,11 +217,11 @@ -- | Set 'DynFlags' equivalent to "-w:". setNoWarningFlags :: DynFlags -> DynFlags-setNoWarningFlags df = df { warningFlags = E.empty}+setNoWarningFlags df = df{warningFlags = E.empty} -- | Set 'DynFlags' equivalent to "-Wall". setAllWarningFlags :: DynFlags -> DynFlags-setAllWarningFlags df = df { warningFlags = allWarningFlags }+setAllWarningFlags df = df{warningFlags = allWarningFlags} {-# NOINLINE allWarningFlags #-} allWarningFlags :: E.EnumSet WarningFlag@@ -218,9 +237,9 @@ addPackageFlags :: [Package] -> DynFlags -> DynFlags addPackageFlags pkgs df =- df { packageFlags = packageFlags df ++ expose `map` pkgs }+ df{packageFlags = packageFlags df ++ expose `map` pkgs} where expose pkg = ExposePackage pkgid (PackageArg name) (ModRenaming True []) where- (name,_,_) = pkg+ (name, _, _) = pkg pkgid = showPkgId pkg
lib/Hhp/Ghc.hs view
@@ -1,33 +1,45 @@ -- | The Happy Haskell Programming library. -- API for interactive processes- module Hhp.Ghc (- -- * Converting the Ghc monad to the IO monad- withGHC- , withGHC'- -- * Initializing DynFlags- , initializeFlagsWithCradle- -- * Ghc utilities- , boot- , browse- , check- , info- , types- , modules- -- * SymMdlDb- , Symbol- , SymMdlDb- , getSymMdlDb- , lookupSym- -- * Misc- , getSystemLibDir- , liftIO- , runGhc- , getMainFileToBeDeleted- , Ghc- ) where+ -- * Converting the Ghc monad to the IO monad+ withGHC,+ withGHC', -import GHC (Ghc, runGhc, ModSummary, mgModSummaries, getModuleGraph,moduleNameString, moduleName, ms_mod)+ -- * Initializing DynFlags+ initializeFlagsWithCradle,++ -- * Ghc utilities+ boot,+ browse,+ check,+ info,+ types,+ modules,++ -- * SymMdlDb+ Symbol,+ SymMdlDb,+ getSymMdlDb,+ lookupSym,++ -- * Misc+ getSystemLibDir,+ liftIO,+ runGhc,+ getMainFileToBeDeleted,+ Ghc,+) where++import GHC (+ Ghc,+ ModSummary,+ getModuleGraph,+ mgModSummaries,+ moduleName,+ moduleNameString,+ ms_mod,+ runGhc,+ ) import qualified GHC as G import GHC.Utils.Monad (liftIO) @@ -46,10 +58,10 @@ getMainFileToBeDeleted file = isSameMainFile file <$> getModSummaryForMain isSameMainFile :: FilePath -> Maybe G.ModSummary -> Maybe FilePath-isSameMainFile _ Nothing = Nothing+isSameMainFile _ Nothing = Nothing isSameMainFile file (Just x) | mainfile == file = Nothing- | otherwise = Just mainfile+ | otherwise = Just mainfile where mmainfile = G.ml_hs_file (G.ms_location x) -- G.ms_hspp_file x is a temporary file with CPP.
lib/Hhp/GhcPkg.hs view
@@ -1,28 +1,39 @@-{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} module Hhp.GhcPkg (- ghcPkgList- , ghcPkgListEx- , ghcPkgDbOpt- , ghcPkgDbStackOpts- , ghcDbStackOpts- , ghcDbOpt- , getSandboxDb- , getPackageDbStack- ) where+ ghcPkgList,+ ghcPkgListEx,+ ghcPkgDbOpt,+ ghcPkgDbStackOpts,+ ghcDbStackOpts,+ ghcDbOpt,+ getSandboxDb,+ getPackageDbStack,+) where import GHC.Settings.Config (cProjectVersionInt) -- ghc version -import Control.Exception (SomeException(..))+import Control.Exception (SomeException (..)) import qualified Control.Exception as E-import Data.Char (isSpace,isAlphaNum)-import Data.List (isPrefixOf, intercalate, dropWhileEnd)+import Data.Char (isAlphaNum, isSpace)+import Data.List (dropWhileEnd, intercalate, isPrefixOf) import Data.Maybe (listToMaybe, maybeToList)-import System.Exit (ExitCode(..))+import System.Exit (ExitCode (..)) import System.FilePath ((</>))-import System.IO (hPutStrLn,stderr)+import System.IO (hPutStrLn, stderr) import System.Process (readProcessWithExitCode)-import Text.ParserCombinators.ReadP (ReadP, char, between, sepBy1, many1, string, choice, eof)+import Text.ParserCombinators.ReadP (+ ReadP,+ between,+ char,+ choice,+ eof,+ many1,+ sepBy1,+ string,+ ) import qualified Text.ParserCombinators.ReadP as P import Hhp.Types@@ -31,15 +42,19 @@ ghcVersion = read cProjectVersionInt -- | Get path to sandbox package db-getSandboxDb :: FilePath -- ^ Path to the cabal package root directory- -- (containing the @cabal.sandbox.config@ file)- -> IO FilePath+getSandboxDb+ :: FilePath+ -- ^ Path to the cabal package root directory+ -- (containing the @cabal.sandbox.config@ file)+ -> IO FilePath getSandboxDb cdir = getSandboxDbDir (cdir </> "cabal.sandbox.config") -- | Extract the sandbox package db directory from the cabal.sandbox.config file. -- Exception is thrown if the sandbox config file is broken.-getSandboxDbDir :: FilePath -- ^ Path to the @cabal.sandbox.config@ file- -> IO FilePath+getSandboxDbDir+ :: FilePath+ -- ^ Path to the @cabal.sandbox.config@ file+ -> IO FilePath getSandboxDbDir sconf = do -- Be strict to ensure that an error can be caught. !path <- extractValue . parse <$> readFile sconf@@ -48,31 +63,33 @@ key = "package-db:" keyLen = length key - parse = head . filter (key `isPrefixOf`) . lines+ parse = unsafeHead . filter (key `isPrefixOf`) . lines extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen -getPackageDbStack :: FilePath -- ^ Project Directory (where the- -- cabal.sandbox.config file would be if it- -- exists)- -> IO [GhcPkgDb]+getPackageDbStack+ :: FilePath+ -- ^ Project Directory (where the+ -- cabal.sandbox.config file would be if it+ -- exists)+ -> IO [GhcPkgDb] getPackageDbStack cdir = (getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db])- `E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb]-+ `E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb] -- | List packages in one or more ghc package store ghcPkgList :: [GhcPkgDb] -> IO [PackageBaseName] ghcPkgList dbs = map fst3 <$> ghcPkgListEx dbs- where fst3 (x,_,_) = x+ where+ fst3 (x, _, _) = x ghcPkgListEx :: [GhcPkgDb] -> IO [Package] ghcPkgListEx dbs = do- (rv,output,err) <- readProcessWithExitCode "ghc-pkg" opts ""+ (rv, output, err) <- readProcessWithExitCode "ghc-pkg" opts "" case rv of- ExitFailure val -> do- hPutStrLn stderr err- fail $ "ghc-pkg " ++ unwords opts ++ " (exit " ++ show val ++ ")"- ExitSuccess -> return ()+ ExitFailure val -> do+ hPutStrLn stderr err+ fail $ "ghc-pkg " ++ unwords opts ++ " (exit " ++ show val ++ ")"+ ExitSuccess -> return () return $ parseGhcPkgOutput $ lines output where@@ -80,76 +97,86 @@ parseGhcPkgOutput :: [String] -> [Package] parseGhcPkgOutput [] = []-parseGhcPkgOutput (l:ls) =+parseGhcPkgOutput (l : ls) = parseGhcPkgOutput ls ++ case l of- [] -> []- h:_ | isSpace h -> maybeToList $ packageLine l- | otherwise -> []+ [] -> []+ h : _+ | isSpace h -> maybeToList $ packageLine l+ | otherwise -> [] packageLine :: String -> Maybe Package packageLine l = case listToMaybe $ P.readP_to_S packageLineP l of- Just ((Normal,p),_) -> Just p- Just ((Hidden,p),_) -> Just p- _ -> Nothing+ Just ((Normal, p), _) -> Just p+ Just ((Hidden, p), _) -> Just p+ _ -> Nothing -data PackageState = Normal | Hidden | Broken deriving (Eq,Show)+data PackageState = Normal | Hidden | Broken deriving (Eq, Show) packageLineP :: ReadP (PackageState, Package) packageLineP = do P.skipSpaces- p <- choice [ (Hidden,) <$> between (char '(') (char ')') packageP- , (Broken,) <$> between (char '{') (char '}') packageP- , (Normal,) <$> packageP ]+ p <-+ choice+ [ (Hidden,) <$> between (char '(') (char ')') packageP+ , (Broken,) <$> between (char '{') (char '}') packageP+ , (Normal,) <$> packageP+ ] eof return p packageP :: ReadP (PackageBaseName, PackageVersion, PackageId) packageP = do- pkgSpec@(name,ver) <- packageSpecP+ pkgSpec@(name, ver) <- packageSpecP P.skipSpaces i <- between (char '(') (char ')') $ packageIdSpecP pkgSpec- return (name,ver,i)+ return (name, ver, i) -packageSpecP :: ReadP (PackageBaseName,PackageVersion)+packageSpecP :: ReadP (PackageBaseName, PackageVersion) packageSpecP = do- fs <- many1 packageCompCharP `sepBy1` char '-'- return (intercalate "-" (init fs), last fs)+ fs <- many1 packageCompCharP `sepBy1` char '-'+ return (intercalate "-" (init fs), last fs) -packageIdSpecP :: (PackageBaseName,PackageVersion) -> ReadP PackageId-packageIdSpecP (name,ver) = do+packageIdSpecP :: (PackageBaseName, PackageVersion) -> ReadP PackageId+packageIdSpecP (name, ver) = do _ <- string name >> char '-' >> string ver- choice [ char '-' >> many1 (P.satisfy isAlphaNum)- , return ""]+ choice+ [ char '-' >> many1 (P.satisfy isAlphaNum)+ , return ""+ ] packageCompCharP :: ReadP Char packageCompCharP = P.satisfy $ \c -> isAlphaNum c || c `elem` "_-." -- | Get options needed to add a list of package dbs to ghc-pkg's db stack-ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack- -> [String]+ghcPkgDbStackOpts+ :: [GhcPkgDb]+ -- ^ Package db stack+ -> [String] ghcPkgDbStackOpts dbs = ghcPkgDbOpt `concatMap` dbs -- | Get options needed to add a list of package dbs to ghc's db stack-ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack- -> [String]+ghcDbStackOpts+ :: [GhcPkgDb]+ -- ^ Package db stack+ -> [String] ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs ghcPkgDbOpt :: GhcPkgDb -> [String] ghcPkgDbOpt GlobalDb = ["--global"]-ghcPkgDbOpt UserDb = ["--user"]+ghcPkgDbOpt UserDb = ["--user"] ghcPkgDbOpt (PackageDb pkgDb)- | ghcVersion < 706 = ["--no-user-package-conf", "--package-conf=" ++ pkgDb]- | otherwise = ["--no-user-package-db", "--package-db=" ++ pkgDb]+ | ghcVersion < 706 = ["--no-user-package-conf", "--package-conf=" ++ pkgDb]+ | otherwise = ["--no-user-package-db", "--package-db=" ++ pkgDb] ghcDbOpt :: GhcPkgDb -> [String] ghcDbOpt GlobalDb- | ghcVersion < 706 = ["-global-package-conf"]- | otherwise = ["-global-package-db"]+ | ghcVersion < 706 = ["-global-package-conf"]+ | otherwise = ["-global-package-db"] ghcDbOpt UserDb- | ghcVersion < 706 = ["-user-package-conf"]- | otherwise = ["-user-package-db"]+ | ghcVersion < 706 = ["-user-package-conf"]+ | otherwise = ["-user-package-db"] ghcDbOpt (PackageDb pkgDb)- | ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb]- | otherwise = ["-no-user-package-db", "-package-db", pkgDb]+ | ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb]+ | otherwise = ["-no-user-package-db", "-package-db", pkgDb]
lib/Hhp/Info.hs view
@@ -1,34 +1,48 @@-{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TupleSections #-} module Hhp.Info (- infoExpr- , info- , typeExpr- , types- ) where+ infoExpr,+ info,+ typeExpr,+ types,+) where -import GHC (Ghc, TypecheckedModule(..), SrcSpan, Type, GenLocated(L), ModSummary, mgModSummaries, mg_ext, LHsBind, Type, LPat, LHsExpr)+import GHC (+ GenLocated (L),+ Ghc,+ LHsBind,+ LHsExpr,+ LPat,+ ModSummary,+ SrcSpan,+ Type,+ TypecheckedModule (..),+ mgModSummaries,+ mg_ext,+ ) import qualified GHC as G import GHC.Core.Utils (exprType)-import GHC.Hs.Binds (HsBindLR(..))-import GHC.Hs.Expr (MatchGroupTc(..))+import GHC.Driver.Session (initSDocContext)+import GHC.Hs.Binds (HsBindLR (..))+import GHC.Hs.Expr (MatchGroupTc (..)) import GHC.Hs.Extension (GhcTc) import GHC.HsToCore (deSugarExpr) import GHC.Utils.Monad (liftIO) import GHC.Utils.Outputable (SDocContext)-import GHC.Driver.Session (initSDocContext) import Control.Applicative ((<|>)) import Control.Monad (filterM)-import Control.Monad.Catch (SomeException(..), handle, bracket)+import Control.Monad.Catch (SomeException (..), bracket, handle) import Data.Function (on) import Data.List (sortBy) import Data.Maybe (catMaybes, fromMaybe) import Data.Ord as O -import Hhp.Doc (showPage, showOneLine, getStyle)-import Hhp.Gap+import Hhp.Doc (getStyle, showOneLine, showPage) import Hhp.GHCApi+import Hhp.Gap import Hhp.Logger (getSrcSpan) import Hhp.Syb import Hhp.Things@@ -37,20 +51,26 @@ ---------------------------------------------------------------- -- | Obtaining information of a target expression. (GHCi's info:)-infoExpr :: Options- -> Cradle- -> FilePath -- ^ A target file.- -> Expression -- ^ A Haskell expression.- -> IO String+infoExpr+ :: Options+ -> Cradle+ -> FilePath+ -- ^ A target file.+ -> Expression+ -- ^ A Haskell expression.+ -> IO String infoExpr opt cradle file expr = withGHC' $ do initializeFlagsWithCradle opt cradle info opt file expr -- | Obtaining information of a target expression. (GHCi's info:)-info :: Options- -> FilePath -- ^ A target file.- -> Expression -- ^ A Haskell expression.- -> Ghc String+info+ :: Options+ -> FilePath+ -- ^ A target file.+ -> Expression+ -- ^ A Haskell expression.+ -> Ghc String info opt file expr = convert opt <$> handle handler body where body = inModuleContext file $ \ctx -> do@@ -61,22 +81,30 @@ ---------------------------------------------------------------- -- | Obtaining type of a target expression. (GHCi's type:)-typeExpr :: Options- -> Cradle- -> FilePath -- ^ A target file.- -> Int -- ^ Line number.- -> Int -- ^ Column number.- -> IO String+typeExpr+ :: Options+ -> Cradle+ -> FilePath+ -- ^ A target file.+ -> Int+ -- ^ Line number.+ -> Int+ -- ^ Column number.+ -> IO String typeExpr opt cradle file lineNo colNo = withGHC' $ do initializeFlagsWithCradle opt cradle types opt file lineNo colNo -- | Obtaining type of a target expression. (GHCi's type:)-types :: Options- -> FilePath -- ^ A target file.- -> Int -- ^ Line number.- -> Int -- ^ Column number.- -> Ghc String+types+ :: Options+ -> FilePath+ -- ^ A target file.+ -> Int+ -- ^ Line number.+ -> Int+ -- ^ Column number.+ -> Ghc String types opt file lineNo colNo = convert opt <$> handle handler body where body = inModuleContext file $ \ctx -> do@@ -86,8 +114,8 @@ handler (SomeException _) = return [] type LExpression = LHsExpr GhcTc-type LBinding = LHsBind GhcTc-type LPattern = LPat GhcTc+type LBinding = LHsBind GhcTc+type LPattern = LPat GhcTc getSrcSpanType :: ModSummary -> Int -> Int -> Ghc [(SrcSpan, Type)] getSrcSpanType modSum lineNo colNo = do@@ -103,15 +131,15 @@ cmp :: SrcSpan -> SrcSpan -> Ordering cmp a b- | a `G.isSubspanOf` b = O.LT- | b `G.isSubspanOf` a = O.GT- | otherwise = O.EQ+ | a `G.isSubspanOf` b = O.LT+ | b `G.isSubspanOf` a = O.GT+ | otherwise = O.EQ -toTup :: SDocContext -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)+toTup :: SDocContext -> (SrcSpan, Type) -> ((Int, Int, Int, Int), String) toTup ctx (spn, typ) = (fourInts spn, pretty ctx typ) -fourInts :: SrcSpan -> (Int,Int,Int,Int)-fourInts = fromMaybe (0,0,0,0) . getSrcSpan+fourInts :: SrcSpan -> (Int, Int, Int, Int)+fourInts = fromMaybe (0, 0, 0, 0) . getSrcSpan pretty :: SDocContext -> Type -> String pretty ctx = showOneLine ctx . pprSigmaType@@ -121,11 +149,11 @@ inModuleContext :: FilePath -> (SDocContext -> Ghc a) -> Ghc a inModuleContext file action = withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWarningFlags) $ do- setTargetFiles [file]- withContext $ do- dflag <- G.getSessionDynFlags- style <- getStyle- action $ initSDocContext dflag style+ setTargetFiles [file]+ withContext $ do+ dflag <- G.getSessionDynFlags+ style <- getStyle+ action $ initSDocContext dflag style ---------------------------------------------------------------- @@ -134,8 +162,8 @@ mss <- mgModSummaries <$> G.getModuleGraph let xs = filter (\m -> G.ml_hs_file (G.ms_location m) == Just file) mss case xs of- [ms] -> return ms- _ -> error "fileModSummary"+ [ms] -> return ms+ _ -> error "fileModSummary" withContext :: Ghc a -> Ghc a withContext action = bracket setup teardown body@@ -156,18 +184,19 @@ ---------------------------------------------------------------- -getTypeLExpression :: TypecheckedModule -> LExpression -> Ghc (Maybe (SrcSpan, Type))+getTypeLExpression+ :: TypecheckedModule -> LExpression -> Ghc (Maybe (SrcSpan, Type)) getTypeLExpression _ e@(L spnA _) = do hs_env <- G.getSession (_, mbc) <- liftIO $ deSugarExpr hs_env e let spn = locA spnA- return $ (spn, ) . exprType <$> mbc+ return $ (spn,) . exprType <$> mbc getTypeLBinding :: TypecheckedModule -> LBinding -> Ghc (Maybe (SrcSpan, Type)) getTypeLBinding _ (L spnA FunBind{fun_matches = m}) = return $ Just (spn, typ) where- in_tys = mg_arg_tys $ mg_ext m- out_typ = mg_res_ty $ mg_ext m+ in_tys = mg_arg_tys $ mg_ext m+ out_typ = mg_res_ty $ mg_ext m typ = mkScaledFunctionTys in_tys out_typ spn = locA spnA getTypeLBinding _ _ = return Nothing
lib/Hhp/Internal.hs view
@@ -1,30 +1,33 @@ -- | The Happy Haskell Programming library in low level.- module Hhp.Internal (- -- * Types- GHCOption- , Package- , PackageBaseName- , PackageVersion- , PackageId- , IncludeDir- , CompilerOptions(..)- -- * Cabal API- , parseCabalFile- , getCompilerOptions- , cabalAllBuildInfo- , cabalDependPackages- , cabalSourceDirs- , cabalAllTargets- -- * IO- , getDynamicFlags- -- * Targets- , setTargetFiles- -- * Logging- , withLogger- , setNoWarningFlags- , setAllWarningFlags- ) where+ -- * Types+ GHCOption,+ Package,+ PackageBaseName,+ PackageVersion,+ PackageId,+ IncludeDir,+ CompilerOptions (..),++ -- * Cabal API+ parseCabalFile,+ getCompilerOptions,+ cabalAllBuildInfo,+ cabalDependPackages,+ cabalSourceDirs,+ cabalAllTargets,++ -- * IO+ getDynamicFlags,++ -- * Targets+ setTargetFiles,++ -- * Logging+ withLogger,+ setNoWarningFlags,+ setAllWarningFlags,+) where import Hhp.CabalApi import Hhp.GHCApi
lib/Hhp/Lint.hs view
@@ -1,5 +1,8 @@+{-# LANGUAGE CPP #-}+ module Hhp.Lint where +#ifdef HLINT import Control.Exception (handle, SomeException(..)) import Language.Haskell.HLint (hlint) @@ -16,3 +19,11 @@ pack = convert opt . map (init . show) -- init drops the last \n. hopts = hlintOpts opt handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"+#else+import Hhp.Types++lintSyntax :: Options+ -> FilePath -- ^ A target file.+ -> IO String+lintSyntax _ _ = return ""+#endif
lib/Hhp/List.hs view
@@ -3,14 +3,14 @@ import GHC (Ghc) import qualified GHC as G -import GHC.Unit.State (lookupModuleInAllUnits, listVisibleModuleNames)+import GHC.Unit.State (listVisibleModuleNames, lookupModuleInAllUnits) import GHC.Unit.Types (moduleName) -import Control.Monad.Catch (SomeException(..), catch)+import Control.Monad.Catch (SomeException (..), catch) import Data.List (nub, sort) -import Hhp.Gap import Hhp.GHCApi+import Hhp.Gap import Hhp.Types ----------------------------------------------------------------@@ -34,4 +34,4 @@ getModules = do us <- getUnitState let modNames = listVisibleModuleNames us- return [ m | mn <- modNames, (m, _) <- lookupModuleInAllUnits us mn ]+ return [m | mn <- modNames, (m, _) <- lookupModuleInAllUnits us mn]
lib/Hhp/PkgDoc.hs view
@@ -2,28 +2,31 @@ import System.Process (readProcess) -import Hhp.Types import Hhp.GhcPkg+import Hhp.Types -- | Obtaining the package name and the doc path of a module.-packageDoc :: Options- -> Cradle- -> ModuleString- -> IO String+packageDoc+ :: Options+ -> Cradle+ -> ModuleString+ -> IO String packageDoc _ cradle mdl = pkgDoc cradle mdl pkgDoc :: Cradle -> String -> IO String pkgDoc cradle mdl = do pkg <- trim <$> readProcess "ghc-pkg" toModuleOpts []- if pkg == "" then- return "\n"- else do- htmlpath <- readProcess "ghc-pkg" (toDocDirOpts pkg) []- let ret = pkg ++ " " ++ drop 14 htmlpath- return ret+ if pkg == ""+ then return "\n"+ else do+ htmlpath <- readProcess "ghc-pkg" (toDocDirOpts pkg) []+ let ret = pkg ++ " " ++ drop 14 htmlpath+ return ret where- toModuleOpts = ["find-module", mdl, "--simple-output"]- ++ ghcPkgDbStackOpts (cradlePkgDbStack cradle)- toDocDirOpts pkg = ["field", pkg, "haddock-html"]- ++ ghcPkgDbStackOpts (cradlePkgDbStack cradle)+ toModuleOpts =+ ["find-module", mdl, "--simple-output"]+ ++ ghcPkgDbStackOpts (cradlePkgDbStack cradle)+ toDocDirOpts pkg =+ ["field", pkg, "haddock-html"]+ ++ ghcPkgDbStackOpts (cradlePkgDbStack cradle) trim = takeWhile (`notElem` " \n")
lib/Hhp/Syb.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE RankNTypes #-} module Hhp.Syb (- listifySpans- ) where+ listifySpans,+) where -import GHC (TypecheckedSource, GenLocated(L), isGoodSrcSpan, spans)+import GHC (GenLocated (L), TypecheckedSource, isGoodSrcSpan, spans) -import Data.Generics (Typeable, GenericQ, mkQ, gmapQ)+import Data.Generics (GenericQ, Typeable, gmapQ, mkQ) import Hhp.Gap
lib/Hhp/Things.hs view
@@ -1,12 +1,12 @@ module Hhp.Things (- GapThing(..)- , fromTyThing- , infoThing- ) where+ GapThing (..),+ fromTyThing,+ infoThing,+) where -import GHC (Type, TyCon, Ghc, Fixity, TyThing)+import GHC (Fixity, Ghc, TyCon, TyThing, Type) import qualified GHC as G-import GHC.Core.ConLike (ConLike(..))+import GHC.Core.ConLike (ConLike (..)) import GHC.Core.DataCon (dataConNonlinearType) import GHC.Core.FamInstEnv (pprFamInsts) import qualified GHC.Core.InstEnv as InstEnv@@ -22,17 +22,18 @@ ---------------------------------------------------------------- -data GapThing = GtA Type- | GtT TyCon- | GtN- | GtPatSyn PatSyn+data GapThing+ = GtA Type+ | GtT TyCon+ | GtN+ | GtPatSyn PatSyn fromTyThing :: TyThing -> GapThing-fromTyThing (G.AnId i) = GtA $ varType i+fromTyThing (G.AnId i) = GtA $ varType i fromTyThing (G.AConLike (RealDataCon d)) = GtA $ dataConNonlinearType d-fromTyThing (G.AConLike (PatSynCon p)) = GtPatSyn p-fromTyThing (G.ATyCon t) = GtT t-fromTyThing _ = GtN+fromTyThing (G.AConLike (PatSynCon p)) = GtPatSyn p+fromTyThing (G.ATyCon t) = GtT t+fromTyThing _ = GtN ---------------------------------------------------------------- @@ -43,22 +44,22 @@ let filtered = filterOutChildren getTyThing $ catMaybes $ fromNE mb_stuffs return $ vcat (intersperse (text "") $ map (pprInfo . fixInfo) filtered) where- getTyThing (t,_,_,_,_) = t- fixInfo (t,f,cs,fs,_) = (t,f,cs,fs)+ getTyThing (t, _, _, _, _) = t+ fixInfo (t, f, cs, fs, _) = (t, f, cs, fs) filterOutChildren :: (a -> TyThing) -> [a] -> [a]-filterOutChildren get_thing xs- = [x | x <- xs, not (G.getName (get_thing x) `elemNameSet` implicits)]+filterOutChildren get_thing xs =+ [x | x <- xs, not (G.getName (get_thing x) `elemNameSet` implicits)] where implicits = mkNameSet [G.getName t | x <- xs, t <- implicitTyThings (get_thing x)] pprInfo :: (TyThing, GHC.Fixity, [InstEnv.ClsInst], [G.FamInst]) -> SDoc-pprInfo (thing, fixity, insts, famInsts)- = pprTyThingInContextLoc thing- $$ show_fixity fixity- $$ InstEnv.pprInstances insts- $$ pprFamInsts famInsts+pprInfo (thing, fixity, insts, famInsts) =+ pprTyThingInContextLoc thing+ $$ show_fixity fixity+ $$ InstEnv.pprInstances insts+ $$ pprFamInsts famInsts where show_fixity fx- | fx == G.defaultFixity = Outputable.empty- | otherwise = ppr fx <+> ppr (G.getName thing)+ | fx == G.defaultFixity = Outputable.empty+ | otherwise = ppr fx <+> ppr (G.getName thing)
lib/Hhp/Types.hs view
@@ -7,42 +7,46 @@ import Control.Monad.Catch (catch) import GHC (Ghc) +import Control.Applicative (Alternative (..)) import Control.Exception (IOException)-import Control.Applicative (Alternative(..)) import Data.List (intercalate) -- | Output style.-data OutputStyle = LispStyle -- ^ S expression style.- | PlainStyle -- ^ Plain textstyle.+data OutputStyle+ = -- | S expression style.+ LispStyle+ | -- | Plain textstyle.+ PlainStyle -- | The type for line separator. Historically, a Null string is used. newtype LineSeparator = LineSeparator String -data Options = Options {- outputStyle :: OutputStyle- , hlintOpts :: [String]- , ghcOpts :: [GHCOption]- -- | If 'True', 'browse' also returns operators.- , operators :: Bool- -- | If 'True', 'browse' also returns types.- , detailed :: Bool- -- | If 'True', 'browse' will return fully qualified name- , qualified :: Bool- -- | Line separator string.- , lineSeparator :: LineSeparator- }+data Options = Options+ { outputStyle :: OutputStyle+ , hlintOpts :: [String]+ , ghcOpts :: [GHCOption]+ , operators :: Bool+ -- ^ If 'True', 'browse' also returns operators.+ , detailed :: Bool+ -- ^ If 'True', 'browse' also returns types.+ , qualified :: Bool+ -- ^ If 'True', 'browse' will return fully qualified name+ , lineSeparator :: LineSeparator+ -- ^ Line separator string.+ } -- | A default 'Options'. defaultOptions :: Options-defaultOptions = Options {- outputStyle = PlainStyle- , hlintOpts = []- , ghcOpts = []- , operators = False- , detailed = False- , qualified = False- , lineSeparator = LineSeparator "\0"- }+defaultOptions =+ Options+ { outputStyle = PlainStyle+ , hlintOpts = []+ , ghcOpts = []+ , operators = False+ , detailed = False+ , qualified = False+ , lineSeparator = LineSeparator "\0"+ } ---------------------------------------------------------------- @@ -53,25 +57,25 @@ -- >>> replace '"' "\\\"" "foo\"bar" "" -- "foo\\\"bar" replace :: Char -> String -> String -> Builder-replace _ _ [] = id-replace c cs (x:xs)- | x == c = (cs ++) . replace c cs xs- | otherwise = (x :) . replace c cs xs+replace _ _ [] = id+replace c cs (x : xs)+ | x == c = (cs ++) . replace c cs xs+ | otherwise = (x :) . replace c cs xs inter :: Char -> [Builder] -> Builder inter _ [] = id-inter c bs = foldr1 (\x y -> x . (c:) . y) bs+inter c bs = foldr1 (\x y -> x . (c :) . y) bs convert :: ToString a => Options -> a -> String-convert opt@Options { outputStyle = LispStyle } x = toLisp opt x "\n"-convert opt@Options { outputStyle = PlainStyle } x- | str == "\n" = ""- | otherwise = str+convert opt@Options{outputStyle = LispStyle} x = toLisp opt x "\n"+convert opt@Options{outputStyle = PlainStyle} x+ | str == "\n" = ""+ | otherwise = str where str = toPlain opt x "\n" class ToString a where- toLisp :: Options -> a -> Builder+ toLisp :: Options -> a -> Builder toPlain :: Options -> a -> Builder lineSep :: Options -> String@@ -86,7 +90,7 @@ -- >>> toPlain defaultOptions "foo" "" -- "foo" instance ToString String where- toLisp opt = quote opt+ toLisp opt = quote opt toPlain opt = replace '\n' (lineSep opt) -- |@@ -96,7 +100,7 @@ -- >>> toPlain defaultOptions ["foo", "bar", "baz"] "" -- "foo\nbar\nbaz" instance ToString [String] where- toLisp opt = toSexp1 opt+ toLisp opt = toSexp1 opt toPlain opt = inter '\n' . map (toPlain opt) -- |@@ -106,8 +110,8 @@ -- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))" -- >>> toPlain defaultOptions inp "" -- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""-instance ToString [((Int,Int,Int,Int),String)] where- toLisp opt = toSexp2 . map toS+instance ToString [((Int, Int, Int, Int), String)] where+ toLisp opt = toSexp2 . map toS where toS x = ('(' :) . tupToString opt x . (')' :) toPlain opt = inter '\n' . map (tupToString opt)@@ -118,37 +122,43 @@ toSexp2 :: [Builder] -> Builder toSexp2 ss = ('(' :) . inter ' ' ss . (')' :) -tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder-tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :)- . (show b ++) . (' ' :)- . (show c ++) . (' ' :)- . (show d ++) . (' ' :)- . quote opt s -- fixme: quote is not necessary+tupToString :: Options -> ((Int, Int, Int, Int), String) -> Builder+tupToString opt ((a, b, c, d), s) =+ (show a ++)+ . (' ' :)+ . (show b ++)+ . (' ' :)+ . (show c ++)+ . (' ' :)+ . (show d ++)+ . (' ' :)+ . quote opt s -- fixme: quote is not necessary quote :: Options -> String -> Builder-quote opt str = ("\"" ++) . (quote' str ++) . ("\"" ++)+quote opt str = ("\"" ++) . (quote' str ++) . ("\"" ++) where lsep = lineSep opt quote' [] = []- quote' (x:xs)- | x == '\n' = lsep ++ quote' xs- | x == '\\' = "\\\\" ++ quote' xs- | x == '"' = "\\\"" ++ quote' xs- | otherwise = x : quote' xs+ quote' (x : xs)+ | x == '\n' = lsep ++ quote' xs+ | x == '\\' = "\\\\" ++ quote' xs+ | x == '"' = "\\\"" ++ quote' xs+ | otherwise = x : quote' xs ---------------------------------------------------------------- -- | The environment where this library is used.-data Cradle = Cradle {- -- | The directory where this library is executed.- cradleCurrentDir :: FilePath- -- | The project root directory.- , cradleRootDir :: FilePath- -- | The file name of the found cabal file.- , cradleCabalFile :: Maybe FilePath- -- | Package database stack- , cradlePkgDbStack :: [GhcPkgDb]- } deriving (Eq, Show)+data Cradle = Cradle+ { cradleCurrentDir :: FilePath+ -- ^ The directory where this library is executed.+ , cradleRootDir :: FilePath+ -- ^ The project root directory.+ , cradleCabalFile :: Maybe FilePath+ -- ^ The file name of the found cabal file.+ , cradlePkgDbStack :: [GhcPkgDb]+ -- ^ Package database stack+ }+ deriving (Eq, Show) ---------------------------------------------------------------- @@ -156,7 +166,7 @@ data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show) -- | A single GHC command line option.-type GHCOption = String+type GHCOption = String -- | An include directory for modules. type IncludeDir = FilePath@@ -165,29 +175,29 @@ type PackageBaseName = String -- | A package version.-type PackageVersion = String+type PackageVersion = String -- | A package id.-type PackageId = String+type PackageId = String -- | A package's name, verson and id.-type Package = (PackageBaseName, PackageVersion, PackageId)+type Package = (PackageBaseName, PackageVersion, PackageId) pkgName :: Package -> PackageBaseName-pkgName (n,_,_) = n+pkgName (n, _, _) = n pkgVer :: Package -> PackageVersion-pkgVer (_,v,_) = v+pkgVer (_, v, _) = v pkgId :: Package -> PackageId-pkgId (_,_,i) = i+pkgId (_, _, i) = i showPkg :: Package -> String-showPkg (n,v,_) = intercalate "-" [n,v]+showPkg (n, v, _) = intercalate "-" [n, v] showPkgId :: Package -> String-showPkgId (n,v,"") = intercalate "-" [n,v]-showPkgId (n,v,i) = intercalate "-" [n,v,i]+showPkgId (n, v, "") = intercalate "-" [n, v]+showPkgId (n, v, i) = intercalate "-" [n, v, i] -- | Haskell expression. type Expression = String@@ -196,12 +206,20 @@ type ModuleString = String -- | Option information for GHC-data CompilerOptions = CompilerOptions {- ghcOptions :: [GHCOption] -- ^ Command line options- , includeDirs :: [IncludeDir] -- ^ Include directories for modules- , depPackages :: [Package] -- ^ Dependent package names- } deriving (Eq, Show)+data CompilerOptions = CompilerOptions+ { ghcOptions :: [GHCOption]+ -- ^ Command line options+ , includeDirs :: [IncludeDir]+ -- ^ Include directories for modules+ , depPackages :: [Package]+ -- ^ Dependent package names+ }+ deriving (Eq, Show) instance Alternative Ghc where x <|> y = x `catch` (\(_ :: IOException) -> y) empty = undefined++unsafeHead :: [a] -> a+unsafeHead [] = error "unsafeHead"+unsafeHead (x : _) = x
src/hhpc.hs view
@@ -2,16 +2,15 @@ module Main where -import Control.Exception (Exception, Handler(..), ErrorCall(..))+import Control.Exception (ErrorCall (..), Exception, Handler (..)) import qualified Control.Exception as E-import Data.Typeable (Typeable) import Data.Version (showVersion)-import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))+import System.Console.GetOpt (ArgDescr (..), ArgOrder (..), OptDescr (..)) import qualified System.Console.GetOpt as O import System.Directory (doesFileExist) import System.Environment (getArgs) import System.Exit (exitFailure)-import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8)+import System.IO (hPutStr, hPutStrLn, hSetEncoding, stderr, stdout, utf8) import Hhp import Paths_hhp@@ -19,23 +18,43 @@ ---------------------------------------------------------------- progVersion :: String-progVersion = "hhpc version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"+progVersion =+ "hhpc version "+ ++ showVersion version+ ++ " compiled by GHC "+ ++ cProjectVersion+ ++ "\n" ghcOptHelp :: String ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] " usage :: String-usage = progVersion+usage =+ progVersion ++ "Usage:\n"- ++ "\t hhpc list" ++ ghcOptHelp ++ "[-l] [-d]\n"+ ++ "\t hhpc list"+ ++ ghcOptHelp+ ++ "[-l] [-d]\n" ++ "\t hhpc lang [-l]\n" ++ "\t hhpc flag [-l]\n"- ++ "\t hhpc browse" ++ ghcOptHelp ++ "[-l] [-o] [-d] [-q] [<package>:]<module> [[<package>:]<module> ...]\n"- ++ "\t hhpc check" ++ ghcOptHelp ++ "<HaskellFiles...>\n"- ++ "\t hhpc expand" ++ ghcOptHelp ++ "<HaskellFiles...>\n"- ++ "\t hhpc debug" ++ ghcOptHelp ++ "\n"- ++ "\t hhpc info" ++ ghcOptHelp ++ "<HaskellFile> <expression>\n"- ++ "\t hhpc type" ++ ghcOptHelp ++ "<HaskellFile> <line-no> <column-no>\n"+ ++ "\t hhpc browse"+ ++ ghcOptHelp+ ++ "[-l] [-o] [-d] [-q] [<package>:]<module> [[<package>:]<module> ...]\n"+ ++ "\t hhpc check"+ ++ ghcOptHelp+ ++ "<HaskellFiles...>\n"+ ++ "\t hhpc expand"+ ++ ghcOptHelp+ ++ "<HaskellFiles...>\n"+ ++ "\t hhpc debug"+ ++ ghcOptHelp+ ++ "\n"+ ++ "\t hhpc info"+ ++ ghcOptHelp+ ++ "<HaskellFile> <expression>\n"+ ++ "\t hhpc type"+ ++ ghcOptHelp+ ++ "<HaskellFile> <line-no> <column-no>\n" ++ "\t hhpc find <symbol>\n" ++ "\t hhpc lint [-h opt] <HaskellFile>\n" ++ "\t hhpc root\n"@@ -47,42 +66,59 @@ ---------------------------------------------------------------- argspec :: [OptDescr (Options -> Options)]-argspec = [ Option "l" ["tolisp"]- (NoArg (\opts -> opts { outputStyle = LispStyle }))- "print as a list of Lisp"- , Option "h" ["hlintOpt"]- (ReqArg (\h opts -> opts { hlintOpts = h : hlintOpts opts }) "hlintOpt")- "hlint options"- , Option "g" ["ghcOpt"]- (ReqArg (\g opts -> opts { ghcOpts = g : ghcOpts opts }) "ghcOpt")- "GHC options"- , Option "o" ["operators"]- (NoArg (\opts -> opts { operators = True }))- "print operators, too"- , Option "d" ["detailed"]- (NoArg (\opts -> opts { detailed = True }))- "print detailed info"- , Option "q" ["qualified"]- (NoArg (\opts -> opts { qualified = True }))- "show qualified names"- , Option "b" ["boundary"]- (ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep")- "specify line separator (default is Nul string)"- ]+argspec =+ [ Option+ "l"+ ["tolisp"]+ (NoArg (\opts -> opts{outputStyle = LispStyle}))+ "print as a list of Lisp"+ , Option+ "h"+ ["hlintOpt"]+ (ReqArg (\h opts -> opts{hlintOpts = h : hlintOpts opts}) "hlintOpt")+ "hlint options"+ , Option+ "g"+ ["ghcOpt"]+ (ReqArg (\g opts -> opts{ghcOpts = g : ghcOpts opts}) "ghcOpt")+ "GHC options"+ , Option+ "o"+ ["operators"]+ (NoArg (\opts -> opts{operators = True}))+ "print operators, too"+ , Option+ "d"+ ["detailed"]+ (NoArg (\opts -> opts{detailed = True}))+ "print detailed info"+ , Option+ "q"+ ["qualified"]+ (NoArg (\opts -> opts{qualified = True}))+ "show qualified names"+ , Option+ "b"+ ["boundary"]+ (ReqArg (\s opts -> opts{lineSeparator = LineSeparator s}) "sep")+ "specify line separator (default is Nul string)"+ ] parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])-parseArgs spec argv- = case O.getOpt Permute spec argv of- (o,n,[] ) -> (foldr id defaultOptions o, n)- (_,_,errs) -> E.throw (CmdArg errs)+parseArgs spec argv =+ case O.getOpt Permute spec argv of+ (o, n, []) -> (foldr id defaultOptions o, n)+ (_, _, errs) -> E.throw (CmdArg errs) ---------------------------------------------------------------- -data HhpcError = SafeList- | TooManyArguments String- | NoSuchCommand String- | CmdArg [String]- | FileNotExist String deriving (Show, Typeable)+data HhpcError+ = SafeList+ | TooManyArguments String+ | NoSuchCommand String+ | CmdArg [String]+ | FileNotExist String+ deriving (Show) instance Exception HhpcError @@ -92,34 +128,35 @@ main = flip E.catches handlers $ do hSetEncoding stdout utf8 args <- getArgs- let (opt,cmdArg) = parseArgs argspec args+ let (opt, cmdArg) = parseArgs argspec args cradle <- findCradle let cmdArg0 = cmdArg !. 0 cmdArg1 = cmdArg !. 1 cmdArg2 = cmdArg !. 2 cmdArg3 = cmdArg !. 3- remainingArgs = tail cmdArg- nArgs n f = if length remainingArgs == n- then f- else E.throw (TooManyArguments cmdArg0)+ remainingArgs = drop 1 cmdArg+ nArgs n f =+ if length remainingArgs == n+ then f+ else E.throw (TooManyArguments cmdArg0) res <- case cmdArg0 of- "list" -> listModules opt cradle- "lang" -> listLanguages opt- "flag" -> listFlags opt- "browse" -> concat <$> mapM (browseModule opt cradle) remainingArgs- "check" -> checkSyntax opt cradle remainingArgs- "expand" -> expandTemplate opt cradle remainingArgs- "debug" -> debugInfo opt cradle- "info" -> nArgs 2 infoExpr opt cradle cmdArg1 cmdArg2- "type" -> nArgs 3 $ typeExpr opt cradle cmdArg1 (read cmdArg2) (read cmdArg3)- "find" -> nArgs 1 $ findSymbol opt cradle cmdArg1- "lint" -> nArgs 1 withFile (lintSyntax opt) cmdArg1- "root" -> rootInfo opt cradle- "doc" -> nArgs 1 $ packageDoc opt cradle cmdArg1- "boot" -> bootInfo opt cradle- "version" -> return progVersion- "help" -> return $ O.usageInfo usage argspec- cmd -> E.throw (NoSuchCommand cmd)+ "list" -> listModules opt cradle+ "lang" -> listLanguages opt+ "flag" -> listFlags opt+ "browse" -> concat <$> mapM (browseModule opt cradle) remainingArgs+ "check" -> checkSyntax opt cradle remainingArgs+ "expand" -> expandTemplate opt cradle remainingArgs+ "debug" -> debugInfo opt cradle+ "info" -> nArgs 2 infoExpr opt cradle cmdArg1 cmdArg2+ "type" -> nArgs 3 $ typeExpr opt cradle cmdArg1 (read cmdArg2) (read cmdArg3)+ "find" -> nArgs 1 $ findSymbol opt cradle cmdArg1+ "lint" -> nArgs 1 withFile (lintSyntax opt) cmdArg1+ "root" -> rootInfo opt cradle+ "doc" -> nArgs 1 $ packageDoc opt cradle cmdArg1+ "boot" -> bootInfo opt cradle+ "version" -> return progVersion+ "help" -> return $ O.usageInfo usage argspec+ cmd -> E.throw (NoSuchCommand cmd) putStr res where handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]@@ -147,5 +184,5 @@ then cmd file else E.throw (FileNotExist file) xs !. idx- | length xs <= idx = E.throw SafeList- | otherwise = xs !! idx+ | length xs <= idx = E.throw SafeList+ | otherwise = xs !! idx
src/hhpi.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE DeriveDataTypeable, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} -- Commands: -- check <file>@@ -18,21 +19,21 @@ module Main where -import Control.Concurrent (forkIO, MVar, newEmptyMVar, putMVar, readMVar)-import Control.Exception (SomeException(..), Exception)+import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, readMVar)+import Control.Exception (Exception, SomeException (..)) import qualified Control.Exception as E-import Control.Monad (when, void)+import Control.Monad (void, when) import Data.Set (Set) import qualified Data.Set as S-import Data.Typeable (Typeable) import Data.Version (showVersion) import System.Console.GetOpt import System.Directory (setCurrentDirectory) import System.Environment (getArgs)-import System.IO (hFlush,stdout)+import System.IO (hFlush, stdout) import Hhp import Hhp.Ghc+ -- import Hhp.Internal import Paths_hhp @@ -43,35 +44,49 @@ ---------------------------------------------------------------- progVersion :: String-progVersion = "hhpi version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"+progVersion =+ "hhpi version "+ ++ showVersion version+ ++ " compiled by GHC "+ ++ cProjectVersion+ ++ "\n" argspec :: [OptDescr (Options -> Options)]-argspec = [ Option "b" ["boundary"]- (ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep")- "specify line separator (default is Nul string)"- , Option "l" ["tolisp"]- (NoArg (\opts -> opts { outputStyle = LispStyle }))- "print as a list of Lisp"- , Option "g" []- (ReqArg (\s opts -> opts { ghcOpts = s : ghcOpts opts }) "flag") "specify a ghc flag"- ]+argspec =+ [ Option+ "b"+ ["boundary"]+ (ReqArg (\s opts -> opts{lineSeparator = LineSeparator s}) "sep")+ "specify line separator (default is Nul string)"+ , Option+ "l"+ ["tolisp"]+ (NoArg (\opts -> opts{outputStyle = LispStyle}))+ "print as a list of Lisp"+ , Option+ "g"+ []+ (ReqArg (\s opts -> opts{ghcOpts = s : ghcOpts opts}) "flag")+ "specify a ghc flag"+ ] usage :: String-usage = progVersion+usage =+ progVersion ++ "Usage:\n" ++ "\t hhpi [-l] [-b sep] [-g flag]\n" ++ "\t hhpi version\n" ++ "\t hhpi help\n" parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])-parseArgs spec argv- = case getOpt Permute spec argv of- (o,n,[] ) -> (foldr id defaultOptions o, n)- (_,_,errs) -> E.throw (CmdArg errs)+parseArgs spec argv =+ case getOpt Permute spec argv of+ (o, n, []) -> (foldr id defaultOptions o, n)+ (_, _, errs) -> E.throw (CmdArg errs) ---------------------------------------------------------------- -newtype HhpiError = CmdArg [String] deriving (Show, Typeable)+newtype HhpiError = CmdArg [String] deriving (Show) instance Exception HhpiError @@ -81,16 +96,17 @@ -- C-c since installSignalHandlers is called twice, sigh. main :: IO ()-main = E.handle cmdHandler $- go =<< parseArgs argspec <$> getArgs+main =+ E.handle cmdHandler $+ go =<< parseArgs argspec <$> getArgs where cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec- go (_,"help":_) = putStr $ usageInfo usage argspec- go (_,"version":_) = putStr progVersion- go (opt,_) = E.handle someHandler $ do+ go (_, "help" : _) = putStr $ usageInfo usage argspec+ go (_, "version" : _) = putStr progVersion+ go (opt, _) = E.handle someHandler $ do cradle0 <- findCradle let rootdir = cradleRootDir cradle0- cradle = cradle0 { cradleCurrentDir = rootdir }+ cradle = cradle0{cradleCurrentDir = rootdir} setCurrentDirectory rootdir mvar <- liftIO newEmptyMVar mlibdir <- getSystemLibDir@@ -104,8 +120,8 @@ replace :: String -> String replace [] = []-replace ('\n':xs) = ';' : replace xs-replace (x:xs) = x : replace xs+replace ('\n' : xs) = ';' : replace xs+replace (x : xs) = x : replace xs ---------------------------------------------------------------- @@ -128,69 +144,78 @@ loop :: Options -> Set FilePath -> MVar SymMdlDb -> Ghc () loop opt set mvar = do cmdArg <- liftIO getLine- let (cmd,arg') = break (== ' ') cmdArg+ let (cmd, arg') = break (== ' ') cmdArg arg = dropWhile (== ' ') arg'- (ret,ok,set') <- case cmd of- "check" -> checkStx opt set arg- "find" -> findSym opt set arg mvar- "lint" -> lintStx opt set arg- "info" -> showInfo opt set arg- "type" -> showType opt set arg- "boot" -> bootIt opt set+ (ret, ok, set') <- case cmd of+ "check" -> checkStx opt set arg+ "find" -> findSym opt set arg mvar+ "lint" -> lintStx opt set arg+ "info" -> showInfo opt set arg+ "type" -> showType opt set arg+ "boot" -> bootIt opt set "browse" -> browseIt opt set arg- "quit" -> return ("quit", False, set)- "" -> return ("quit", False, set)- _ -> return ([], True, set)- if ok then do- liftIO $ putStr ret- liftIO $ putStrLn "OK"- else do- liftIO $ putStrLn $ "NG " ++ replace ret+ "quit" -> return ("quit", False, set)+ "" -> return ("quit", False, set)+ _ -> return ([], True, set)+ if ok+ then do+ liftIO $ putStr ret+ liftIO $ putStrLn "OK"+ else do+ liftIO $ putStrLn $ "NG " ++ replace ret liftIO $ hFlush stdout when ok $ loop opt set' mvar ---------------------------------------------------------------- -checkStx :: Options- -> Set FilePath- -> FilePath- -> Ghc (String, Bool, Set FilePath)+checkStx+ :: Options+ -> Set FilePath+ -> FilePath+ -> Ghc (String, Bool, Set FilePath) checkStx opt set file = do set' <- newFileSet set file let files = S.toList set' eret <- check opt files case eret of Right ret -> return (ret, True, set')- Left ret -> return (ret, True, set) -- fxime: set+ Left ret -> return (ret, True, set) -- fxime: set newFileSet :: Set FilePath -> FilePath -> Ghc (Set FilePath) newFileSet set file = do let set1- | S.member file set = set- | otherwise = S.insert file set+ | S.member file set = set+ | otherwise = S.insert file set mf <- getMainFileToBeDeleted file return $ case mf of- Nothing -> set1+ Nothing -> set1 Just mainfile -> S.delete mainfile set1 ---------------------------------------------------------------- -findSym :: Options -> Set FilePath -> String -> MVar SymMdlDb- -> Ghc (String, Bool, Set FilePath)+findSym+ :: Options+ -> Set FilePath+ -> String+ -> MVar SymMdlDb+ -> Ghc (String, Bool, Set FilePath) findSym opt set sym mvar = do db <- liftIO $ readMVar mvar let ret = lookupSym opt sym db return (ret, True, set) -lintStx :: Options -> Set FilePath -> FilePath- -> Ghc (String, Bool, Set FilePath)+lintStx+ :: Options+ -> Set FilePath+ -> FilePath+ -> Ghc (String, Bool, Set FilePath) lintStx opt set optFile = liftIO $ do- ret <-lintSyntax opt' file+ ret <- lintSyntax opt' file return (ret, True, set) where- (opts,file) = parseLintOptions optFile+ (opts, file) = parseLintOptions optFile hopts = if opts == "" then [] else read opts- opt' = opt { hlintOpts = hopts }+ opt' = opt{hlintOpts = hopts} -- | -- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name"@@ -199,53 +224,57 @@ -- ([], "file name") parseLintOptions :: String -> (String, String) parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of- ("","") -> ([], optFile)- (opt',file') -> (opt', dropWhile (== ' ') file')+ ("", "") -> ([], optFile)+ (opt', file') -> (opt', dropWhile (== ' ') file') where- brk _ [] = ([],[])- brk p (x:xs')- | p x = ([x],xs')- | otherwise = let (ys,zs) = brk p xs' in (x:ys,zs)+ brk _ [] = ([], [])+ brk p (x : xs')+ | p x = ([x], xs')+ | otherwise = let (ys, zs) = brk p xs' in (x : ys, zs) ---------------------------------------------------------------- -showInfo :: Options- -> Set FilePath- -> FilePath- -> Ghc (String, Bool, Set FilePath)+showInfo+ :: Options+ -> Set FilePath+ -> FilePath+ -> Ghc (String, Bool, Set FilePath) showInfo opt set fileArg = do let (file, expr) = case words fileArg of- [file0, expr0] -> (file0, expr0)- _ -> error "showInfo"+ [file0, expr0] -> (file0, expr0)+ _ -> error "showInfo" set' <- newFileSet set file ret <- info opt file expr return (ret, True, set') -showType :: Options- -> Set FilePath- -> FilePath- -> Ghc (String, Bool, Set FilePath)-showType opt set fileArg = do+showType+ :: Options+ -> Set FilePath+ -> FilePath+ -> Ghc (String, Bool, Set FilePath)+showType opt set fileArg = do let (file, line, column) = case words fileArg of- [file0, line0, column0] -> (file0, line0, column0)- _ -> error "showInfo"+ [file0, line0, column0] -> (file0, line0, column0)+ _ -> error "showInfo" set' <- newFileSet set file ret <- types opt file (read line) (read column) return (ret, True, set') ---------------------------------------------------------------- -bootIt :: Options- -> Set FilePath- -> Ghc (String, Bool, Set FilePath)+bootIt+ :: Options+ -> Set FilePath+ -> Ghc (String, Bool, Set FilePath) bootIt opt set = do ret <- boot opt return (ret, True, set) -browseIt :: Options- -> Set FilePath- -> ModuleString- -> Ghc (String, Bool, Set FilePath)+browseIt+ :: Options+ -> Set FilePath+ -> ModuleString+ -> Ghc (String, Bool, Set FilePath) browseIt opt set mdl = do ret <- browse opt mdl return (ret, True, set)
test/BrowseSpec.hs view
@@ -18,12 +18,14 @@ describe "browseModule -d" $ do it "lists up symbols with type info in the module" $ do cradle <- findCradle- syms <- lines <$> browseModule defaultOptions { detailed = True } cradle "Data.Either"+ syms <-+ lines <$> browseModule defaultOptions{detailed = True} cradle "Data.Either" syms `shouldContain` ["either :: (a -> c) -> (b -> c) -> Either a b -> c"] it "lists up data constructors with type info in the module" $ do cradle <- findCradle- syms <- lines <$> browseModule defaultOptions { detailed = True} cradle "Data.Either"+ syms <-+ lines <$> browseModule defaultOptions{detailed = True} cradle "Data.Either" syms `shouldContain` ["Left :: a -> Either a b"] describe "browseModule local" $ do
test/CabalApiSpec.hs view
@@ -3,7 +3,7 @@ module CabalApiSpec where import Control.Exception-import System.Environment (unsetEnv, setEnv)+import System.Environment (setEnv, unsetEnv) import Test.Hspec import Hhp.CabalApi@@ -12,55 +12,72 @@ spec = do describe "parseCabalFile" $ do it "throws an exception if the cabal file is broken" $ do- parseCabalFile "test/data/broken-cabal/broken.cabal" `shouldThrow` (\(_::IOException) -> True)+ parseCabalFile "test/data/broken-cabal/broken.cabal"+ -- GHC 9.8 or earlier: IOException+ -- GHC 9.10 or later: VerboseException+ `shouldThrow` (\(_ :: SomeException) -> True) -{- For success, "test/data/cabal.sandbox.config" must contain absolute paths.- describe "getCompilerOptions" $ do- it "gets necessary CompilerOptions" $ do- withDirectory "test/data/subdir1/subdir2" $ \dir -> do- cradle <- findCradle- pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile cradle- print cradle- res <- getCompilerOptions [] cradle pkgDesc- let res' = res {- ghcOptions = ghcOptions res- , includeDirs = map (toRelativeDir dir) (includeDirs res)- }- ghcOptions res' `shouldBe` ["-global-package-db", "-no-user-package-db","-package-db","test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"]- includeDirs res' `shouldBe` ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"]- depPackages res' `shouldSatisfy` (("Cabal", "1.18.1.3", "2b161c6bf77657aa17e1681d83cb051b")`elem`)--}+ {- For success, "test/data/cabal.sandbox.config" must contain absolute paths.+ describe "getCompilerOptions" $ do+ it "gets necessary CompilerOptions" $ do+ withDirectory "test/data/subdir1/subdir2" $ \dir -> do+ cradle <- findCradle+ pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile cradle+ print cradle+ res <- getCompilerOptions [] cradle pkgDesc+ let res' = res {+ ghcOptions = ghcOptions res+ , includeDirs = map (toRelativeDir dir) (includeDirs res)+ }+ ghcOptions res' `shouldBe` ["-global-package-db", "-no-user-package-db","-package-db","test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"]+ includeDirs res' `shouldBe` ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"]+ depPackages res' `shouldSatisfy` (("Cabal", "1.18.1.3", "2b161c6bf77657aa17e1681d83cb051b")`elem`)+ -} describe "cabalDependPackages" $ do it "extracts dependent packages" $ do- pkgs <- cabalDependPackages . cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal"- pkgs `shouldBe` ["Cabal","base","template-haskell"]+ pkgs <-+ cabalDependPackages . cabalAllBuildInfo+ <$> parseCabalFile "test/data/cabalapi.cabal"+ pkgs `shouldBe` ["Cabal", "base", "template-haskell"] describe "cabalSourceDirs" $ do it "extracts all hs-source-dirs" $ do- dirs <- cabalSourceDirs . cabalAllBuildInfo <$> parseCabalFile "test/data/check-test-subdir/check-test-subdir.cabal"+ dirs <-+ cabalSourceDirs . cabalAllBuildInfo+ <$> parseCabalFile "test/data/check-test-subdir/check-test-subdir.cabal" dirs `shouldBe` ["src", "test"] it "extracts all hs-source-dirs including \".\"" $ do- dirs <- cabalSourceDirs . cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal"+ dirs <-+ cabalSourceDirs . cabalAllBuildInfo+ <$> parseCabalFile "test/data/cabalapi.cabal" dirs `shouldBe` [".", "test"] describe "cabal-subLibraries" $ do it "dependent packages with sublib" $ do- pkgs <- cabalDependPackages . cabalAllBuildInfo <$> parseCabalFile "test/data/check-sublib/check-sublib.cabal"+ pkgs <-+ cabalDependPackages . cabalAllBuildInfo+ <$> parseCabalFile "test/data/check-sublib/check-sublib.cabal" pkgs `shouldBe` ["array", "base", "bytestring"] describe "HHP_CABAL_FLAGS" $ do it "dependent packages without flags" $ do unsetEnv "HHP_CABAL_FLAGS"- pkgs <- cabalDependPackages . cabalAllBuildInfo <$> parseCabalFile "test/data/check-flags/check-flags.cabal"+ pkgs <-+ cabalDependPackages . cabalAllBuildInfo+ <$> parseCabalFile "test/data/check-flags/check-flags.cabal" pkgs `shouldBe` ["base", "directory"] it "dependent packages with foo flag" $ do setEnv "HHP_CABAL_FLAGS" "foo"- pkgs <- cabalDependPackages . cabalAllBuildInfo <$> parseCabalFile "test/data/check-flags/check-flags.cabal"+ pkgs <-+ cabalDependPackages . cabalAllBuildInfo+ <$> parseCabalFile "test/data/check-flags/check-flags.cabal" pkgs `shouldBe` ["base", "directory", "filepath"] it "dependent packages with foo and -bar flag" $ do setEnv "HHP_CABAL_FLAGS" "foo -bar"- pkgs <- cabalDependPackages . cabalAllBuildInfo <$> parseCabalFile "test/data/check-flags/check-flags.cabal"+ pkgs <-+ cabalDependPackages . cabalAllBuildInfo+ <$> parseCabalFile "test/data/check-flags/check-flags.cabal" pkgs `shouldBe` ["base", "filepath"] {-
test/CheckSpec.hs view
@@ -1,6 +1,6 @@ module CheckSpec where -import Data.List (isSuffixOf, isInfixOf, isPrefixOf)+import Data.List (isInfixOf, isPrefixOf, isSuffixOf) import System.FilePath import Test.Hspec @@ -16,13 +16,20 @@ withDirectory_ "test/data/hhp-check" $ do cradle <- findCradleWithoutSandbox res <- checkSyntax defaultOptions cradle ["main.hs"]- res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\n"+ res+ `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\n" - it "can check even if a test module imports another test module located at different directory" $ do+ it+ "can check even if a test module imports another test module located at different directory" $ do withDirectory_ "test/data/check-test-subdir" $ do cradle <- findCradleWithoutSandbox res <- checkSyntax defaultOptions cradle ["test/Bar/Baz.hs"]- res `shouldSatisfy` (("test" </> "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: String\n") `isSuffixOf`)+ res+ `shouldSatisfy` ( ( "test"+ </> "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: String\n"+ )+ `isSuffixOf`+ ) it "can detect mutually imported modules" $ do withDirectory_ "test/data" $ do@@ -34,7 +41,7 @@ withDirectory_ "test/data" $ do cradle <- findCradleWithoutSandbox res <- checkSyntax defaultOptions cradle ["Baz.hs"]- res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`)+ res `shouldSatisfy` ("Baz.hs:7:1:Warning:" `isPrefixOf`) context "without errors" $ do it "doesn't output empty line" $ do
test/Dir.hs view
@@ -6,19 +6,23 @@ import System.FilePath (addTrailingPathSeparator) withDirectory_ :: FilePath -> IO a -> IO a-withDirectory_ dir action = bracket getCurrentDirectory- setCurrentDirectory- (\_ -> setCurrentDirectory dir >> action)+withDirectory_ dir action =+ bracket+ getCurrentDirectory+ setCurrentDirectory+ (\_ -> setCurrentDirectory dir >> action) withDirectory :: FilePath -> (FilePath -> IO a) -> IO a-withDirectory dir action = bracket getCurrentDirectory- setCurrentDirectory- (\d -> setCurrentDirectory dir >> action d)+withDirectory dir action =+ bracket+ getCurrentDirectory+ setCurrentDirectory+ (\d -> setCurrentDirectory dir >> action d) toRelativeDir :: FilePath -> FilePath -> FilePath toRelativeDir dir file- | dir' `isPrefixOf` file = drop len file- | otherwise = file+ | dir' `isPrefixOf` file = drop len file+ | otherwise = file where dir' = addTrailingPathSeparator dir len = length dir'
test/GhcPkgSpec.hs view
@@ -2,8 +2,8 @@ import Test.Hspec -import Hhp.Types import Hhp.GhcPkg+import Hhp.Types spec :: Spec spec = do@@ -19,4 +19,5 @@ it "find a config file and extracts packages" $ do sdb <- getSandboxDb "test/data/check-packageid" pkgs <- ghcPkgListEx [PackageDb sdb]- pkgs `shouldBe` [("template-haskell","2.8.0.0","32d4f24abdbb6bf41272b183b2e23e9c")]+ pkgs+ `shouldBe` [("template-haskell", "2.8.0.0", "32d4f24abdbb6bf41272b183b2e23e9c")]
test/InfoSpec.hs view
@@ -19,19 +19,22 @@ withDirectory_ "test/data/hhp-check" $ do cradle <- findCradleWithoutSandbox res <- typeExpr defaultOptions cradle "Data/Foo.hs" 9 5- res `shouldBe` "9 5 11 40 \"Int -> t -> t -> t\"\n7 1 11 40 \"Int -> Integer\"\n"+ res+ `shouldBe` "9 5 11 44 \"Int -> t -> t -> t\"\n7 1 11 44 \"Int -> Integer\"\n" it "works with a module using TemplateHaskell" $ do withDirectory_ "test/data" $ do cradle <- findCradleWithoutSandbox- res <- typeExpr defaultOptions cradle "Bar.hs" 5 1- res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]+ res <- typeExpr defaultOptions cradle "Bar.hs" 7 1+ res `shouldBe` unlines ["7 1 7 20 \"[Char]\""] it "works with a module that imports another module using TemplateHaskell" $ do withDirectory_ "test/data" $ do cradle <- findCradleWithoutSandbox res <- typeExpr defaultOptions cradle "Main.hs" 3 8- res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]+ res+ `shouldBe` unlines+ ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""] describe "infoExpr" $ do it "works for non-export functions" $ do@@ -53,6 +56,8 @@ res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`) it "doesn't fail on unicode output" $ do- hhpcPath <- replace "\\t\\" "\\x\\" . replace "/t/" "/x/" . replace "spec" "hhpc" <$> getExecutablePath+ hhpcPath <-+ replace "\\t\\" "\\x\\" . replace "/t/" "/x/" . replace "spec" "hhpc"+ <$> getExecutablePath code <- rawSystem hhpcPath ["info", "test/data/Unicode.hs", "unicode"] code `shouldSatisfy` (== ExitSuccess)
test/LintSpec.hs view
@@ -1,5 +1,8 @@+{-# LANGUAGE CPP #-}+ module LintSpec where +#ifdef HLINT import Data.List.Extra import Test.Hspec @@ -18,3 +21,11 @@ it "doesn't output empty line" $ do res <- lintSyntax defaultOptions "test/data/hhp-check/Data/Foo.hs" res `shouldBe` ""+#else+import Test.Hspec++spec :: Spec+spec = do+ describe "lintSyntax" $ do+ it "check syntax with HLint" $ do True `shouldBe` True+#endif
test/data/Bar.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE TemplateHaskell #-}+ module Bar (bar) where+ import Foo (foo) bar = $foo ++ "bar"
test/data/Baz.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE QuasiQuotes #-}+ module Baz (baz) where+ import Foo (fooQ) baz = [fooQ| foo bar baz |]
test/data/Foo.hs view
@@ -1,6 +1,7 @@ module Foo (foo, fooQ) where+ import Language.Haskell.TH-import Language.Haskell.TH.Quote (QuasiQuoter(..))+import Language.Haskell.TH.Quote (QuasiQuoter (..)) foo :: ExpQ foo = stringE "foo"
test/data/check-test-subdir/test/Bar/Baz.hs view
@@ -1,4 +1,5 @@ module Bar.Baz (baz) where+ import Foo (foo) baz :: String
test/data/check-test-subdir/test/Main.hs view
@@ -1,4 +1,5 @@ module Main where+ import Bar.Baz (baz) main :: IO ()
test/data/hhp-check/Data/Foo.hs view
@@ -7,5 +7,5 @@ fibonacci n = fib 1 0 1 where fib m x y- | n == m = y- | otherwise = fib (m+1) y (x + y)+ | n == m = y+ | otherwise = fib (m + 1) y (x + y)
test/data/hlint.hs view
@@ -2,5 +2,5 @@ main :: IO () main = do- putStrLn $ foldr (+) 0 [0..10]+ putStrLn $ foldr (+) 0 [0 .. 10] putStrLn "Hello"