diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/elisp/hhp-check.el b/elisp/hhp-check.el --- a/elisp/hhp-check.el +++ b/elisp/hhp-check.el @@ -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) diff --git a/elisp/hhp-func.el b/elisp/hhp-func.el --- a/elisp/hhp-func.el +++ b/elisp/hhp-func.el @@ -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) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/hhp.cabal b/hhp.cabal --- a/hhp.cabal +++ b/hhp.cabal @@ -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 @@ -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 diff --git a/lib/Hhp.hs b/lib/Hhp.hs --- a/lib/Hhp.hs +++ b/lib/Hhp.hs @@ -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 diff --git a/lib/Hhp/Boot.hs b/lib/Hhp/Boot.hs --- a/lib/Hhp/Boot.hs +++ b/lib/Hhp/Boot.hs @@ -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" + ] diff --git a/lib/Hhp/Browse.hs b/lib/Hhp/Browse.hs --- a/lib/Hhp/Browse.hs +++ b/lib/Hhp/Browse.hs @@ -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 diff --git a/lib/Hhp/CabalApi.hs b/lib/Hhp/CabalApi.hs --- a/lib/Hhp/CabalApi.hs +++ b/lib/Hhp/CabalApi.hs @@ -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 diff --git a/lib/Hhp/Check.hs b/lib/Hhp/Check.hs --- a/lib/Hhp/Check.hs +++ b/lib/Hhp/Check.hs @@ -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 diff --git a/lib/Hhp/Cradle.hs b/lib/Hhp/Cradle.hs --- a/lib/Hhp/Cradle.hs +++ b/lib/Hhp/Cradle.hs @@ -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 diff --git a/lib/Hhp/Debug.hs b/lib/Hhp/Debug.hs --- a/lib/Hhp/Debug.hs +++ b/lib/Hhp/Debug.hs @@ -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 diff --git a/lib/Hhp/Doc.hs b/lib/Hhp/Doc.hs --- a/lib/Hhp/Doc.hs +++ b/lib/Hhp/Doc.hs @@ -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} ---------------------------------------------------------------- diff --git a/lib/Hhp/Find.hs b/lib/Hhp/Find.hs --- a/lib/Hhp/Find.hs +++ b/lib/Hhp/Find.hs @@ -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 diff --git a/lib/Hhp/Flag.hs b/lib/Hhp/Flag.hs --- a/lib/Hhp/Flag.hs +++ b/lib/Hhp/Flag.hs @@ -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-"] + ] diff --git a/lib/Hhp/GHCApi.hs b/lib/Hhp/GHCApi.hs --- a/lib/Hhp/GHCApi.hs +++ b/lib/Hhp/GHCApi.hs @@ -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 diff --git a/lib/Hhp/Ghc.hs b/lib/Hhp/Ghc.hs --- a/lib/Hhp/Ghc.hs +++ b/lib/Hhp/Ghc.hs @@ -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. diff --git a/lib/Hhp/GhcPkg.hs b/lib/Hhp/GhcPkg.hs --- a/lib/Hhp/GhcPkg.hs +++ b/lib/Hhp/GhcPkg.hs @@ -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] diff --git a/lib/Hhp/Info.hs b/lib/Hhp/Info.hs --- a/lib/Hhp/Info.hs +++ b/lib/Hhp/Info.hs @@ -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 diff --git a/lib/Hhp/Internal.hs b/lib/Hhp/Internal.hs --- a/lib/Hhp/Internal.hs +++ b/lib/Hhp/Internal.hs @@ -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 diff --git a/lib/Hhp/Lint.hs b/lib/Hhp/Lint.hs --- a/lib/Hhp/Lint.hs +++ b/lib/Hhp/Lint.hs @@ -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 diff --git a/lib/Hhp/List.hs b/lib/Hhp/List.hs --- a/lib/Hhp/List.hs +++ b/lib/Hhp/List.hs @@ -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] diff --git a/lib/Hhp/PkgDoc.hs b/lib/Hhp/PkgDoc.hs --- a/lib/Hhp/PkgDoc.hs +++ b/lib/Hhp/PkgDoc.hs @@ -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") diff --git a/lib/Hhp/Syb.hs b/lib/Hhp/Syb.hs --- a/lib/Hhp/Syb.hs +++ b/lib/Hhp/Syb.hs @@ -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 diff --git a/lib/Hhp/Things.hs b/lib/Hhp/Things.hs --- a/lib/Hhp/Things.hs +++ b/lib/Hhp/Things.hs @@ -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) diff --git a/lib/Hhp/Types.hs b/lib/Hhp/Types.hs --- a/lib/Hhp/Types.hs +++ b/lib/Hhp/Types.hs @@ -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 diff --git a/src/hhpc.hs b/src/hhpc.hs --- a/src/hhpc.hs +++ b/src/hhpc.hs @@ -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] [:] [[:] ...]\n" - ++ "\t hhpc check" ++ ghcOptHelp ++ "\n" - ++ "\t hhpc expand" ++ ghcOptHelp ++ "\n" - ++ "\t hhpc debug" ++ ghcOptHelp ++ "\n" - ++ "\t hhpc info" ++ ghcOptHelp ++ " \n" - ++ "\t hhpc type" ++ ghcOptHelp ++ " \n" + ++ "\t hhpc browse" + ++ ghcOptHelp + ++ "[-l] [-o] [-d] [-q] [:] [[:] ...]\n" + ++ "\t hhpc check" + ++ ghcOptHelp + ++ "\n" + ++ "\t hhpc expand" + ++ ghcOptHelp + ++ "\n" + ++ "\t hhpc debug" + ++ ghcOptHelp + ++ "\n" + ++ "\t hhpc info" + ++ ghcOptHelp + ++ " \n" + ++ "\t hhpc type" + ++ ghcOptHelp + ++ " \n" ++ "\t hhpc find \n" ++ "\t hhpc lint [-h opt] \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 diff --git a/src/hhpi.hs b/src/hhpi.hs --- a/src/hhpi.hs +++ b/src/hhpi.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} -- Commands: -- check @@ -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) diff --git a/test/BrowseSpec.hs b/test/BrowseSpec.hs --- a/test/BrowseSpec.hs +++ b/test/BrowseSpec.hs @@ -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 diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -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"] {- diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -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 diff --git a/test/Dir.hs b/test/Dir.hs --- a/test/Dir.hs +++ b/test/Dir.hs @@ -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' diff --git a/test/GhcPkgSpec.hs b/test/GhcPkgSpec.hs --- a/test/GhcPkgSpec.hs +++ b/test/GhcPkgSpec.hs @@ -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")] diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs --- a/test/InfoSpec.hs +++ b/test/InfoSpec.hs @@ -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) diff --git a/test/LintSpec.hs b/test/LintSpec.hs --- a/test/LintSpec.hs +++ b/test/LintSpec.hs @@ -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 diff --git a/test/data/Bar.hs b/test/data/Bar.hs --- a/test/data/Bar.hs +++ b/test/data/Bar.hs @@ -1,5 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} + module Bar (bar) where + import Foo (foo) bar = $foo ++ "bar" diff --git a/test/data/Baz.hs b/test/data/Baz.hs --- a/test/data/Baz.hs +++ b/test/data/Baz.hs @@ -1,5 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} + module Baz (baz) where + import Foo (fooQ) baz = [fooQ| foo bar baz |] diff --git a/test/data/Foo.hs b/test/data/Foo.hs --- a/test/data/Foo.hs +++ b/test/data/Foo.hs @@ -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" diff --git a/test/data/check-test-subdir/test/Bar/Baz.hs b/test/data/check-test-subdir/test/Bar/Baz.hs --- a/test/data/check-test-subdir/test/Bar/Baz.hs +++ b/test/data/check-test-subdir/test/Bar/Baz.hs @@ -1,4 +1,5 @@ module Bar.Baz (baz) where + import Foo (foo) baz :: String diff --git a/test/data/check-test-subdir/test/Main.hs b/test/data/check-test-subdir/test/Main.hs --- a/test/data/check-test-subdir/test/Main.hs +++ b/test/data/check-test-subdir/test/Main.hs @@ -1,4 +1,5 @@ module Main where + import Bar.Baz (baz) main :: IO () diff --git a/test/data/hhp-check/Data/Foo.hs b/test/data/hhp-check/Data/Foo.hs --- a/test/data/hhp-check/Data/Foo.hs +++ b/test/data/hhp-check/Data/Foo.hs @@ -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) diff --git a/test/data/hlint.hs b/test/data/hlint.hs --- a/test/data/hlint.hs +++ b/test/data/hlint.hs @@ -2,5 +2,5 @@ main :: IO () main = do - putStrLn $ foldr (+) 0 [0..10] + putStrLn $ foldr (+) 0 [0 .. 10] putStrLn "Hello"