buildwrapper 0.8.10 → 0.8.11
raw patch · 9 files changed
+100/−266 lines, 9 filesdep +ghc-pkg-lib
Dependencies added: ghc-pkg-lib
Files
- buildwrapper.cabal +7/−5
- src/Language/Haskell/BuildWrapper/API.hs +1/−1
- src/Language/Haskell/BuildWrapper/Cabal.hs +1/−1
- src/Language/Haskell/BuildWrapper/GHC.hs +1/−1
- src/Language/Haskell/BuildWrapper/GHCStorage.hs +8/−7
- src/Language/Haskell/BuildWrapper/Packages.hs +0/−222
- src/Language/Haskell/BuildWrapper/Src.hs +36/−27
- test/Language/Haskell/BuildWrapper/CMDTests.hs +45/−1
- test/Language/Haskell/BuildWrapper/UsagesTests.hs +1/−1
buildwrapper.cabal view
@@ -1,5 +1,5 @@ name: buildwrapper-version: 0.8.10+version: 0.8.11 cabal-version: >= 1.8 build-type: Custom license: BSD3@@ -43,7 +43,8 @@ bytestring, attoparsec>=0.11 && <0.13, transformers,- deepseq+ deepseq,+ ghc-pkg-lib ghc-options: -Wall -fno-warn-unused-do-bind exposed-modules: Language.Haskell.BuildWrapper.API,@@ -53,7 +54,6 @@ extensions: CPP other-modules: Language.Haskell.BuildWrapper.GHCStorage,- Language.Haskell.BuildWrapper.Packages, Language.Haskell.BuildWrapper.Src if impl(ghc >= 7.6) build-depends: @@ -85,7 +85,8 @@ text, aeson, bytestring,- transformers+ transformers,+ ghc-pkg-lib ghc-options: -Wall -fno-warn-unused-do-bind -optl -s -- see https://ghc.haskell.org/trac/ghc/ticket/8376 -- if impl(ghc >= 7.8) && impl(ghc < 7.8.4)@@ -118,7 +119,8 @@ transformers, vector, unordered-containers,- containers+ containers,+ ghc-pkg-lib main-is: Main.hs ghc-options: -Wall -fno-warn-unused-do-bind -optl -s other-modules:
src/Language/Haskell/BuildWrapper/API.hs view
@@ -440,7 +440,7 @@ (mast,bwns)<-getAST fp mccn case mast of Just (ParseOk ast)->do - --liftIO $ Prelude.print ast + -- liftIO $ Prelude.print $ snd ast let ods=getHSEOutline ast let (es,is)=getHSEImportExport ast return (OutlineResult ods es is,bwns)
src/Language/Haskell/BuildWrapper/Cabal.hs view
@@ -12,7 +12,7 @@ module Language.Haskell.BuildWrapper.Cabal where import Language.Haskell.BuildWrapper.Base -import Language.Haskell.BuildWrapper.Packages +import Language.Haskell.Packages import Control.Monad.State
src/Language/Haskell/BuildWrapper/GHC.hs view
@@ -959,7 +959,7 @@ | ('#':_)<-l =addPPToken "PP" (l,c) (ts2,l2,lineBehavior l f) | Just (l',s,e,f2)<-pragmaExtract l f= (TokenDef "P" (mkFileSpan c s c e) : ts2 ,l':l2,f2)- -- | "{-# " `List.isPrefixOf` l=addPPToken "P" (l,c) (ts2,"":l2,pragmaBehavior l f) + -- "{-# " `List.isPrefixOf` l=addPPToken "P" (l,c) (ts2,"":l2,pragmaBehavior l f) | (Indent n)<-f=(ts2,l:(replicate n (takeWhile (== ' ') l) ++ l2),Start) | otherwise =(ts2,l:l2,Start) ppSLit :: ([TokenDef],[String],PPBehavior) -> (String,Int) -> ([TokenDef],[String],PPBehavior)
src/Language/Haskell/BuildWrapper/GHCStorage.hs view
@@ -40,7 +40,6 @@ import qualified Data.HashMap.Lazy as HM import qualified Data.Map as DM import qualified Data.Vector as V -import Data.Attoparsec.Number (Number(I)) #if __GLASGOW_HASKELL__ < 706 import System.Time (ClockTime) #else @@ -54,7 +53,9 @@ import Data.List (sortBy) --import GHC.SYB.Utils (Stage(..), showData) import qualified MonadUtils as GMU +#if __GLASGOW_HASKELL__ < 707 import TcRnTypes (tcg_type_env,tcg_rdr_env) +#endif import qualified CoreUtils (exprType) import Desugar (deSugarExpr) import Control.Monad (liftM) @@ -273,7 +274,7 @@ var v = return $ typedVar v (varType v) #if __GLASGOW_HASKELL__ >= 708 rDataCon (RealDataCon dc)=dataCon dc - rDataCon_ = Null + rDataCon _ = Null #endif dataCon :: DataCon -> Value dataCon d = let @@ -346,17 +347,17 @@ getType :: HscEnv -> TypecheckedModule -> LHsExpr Var -> IO(Maybe Type) --getType _ _ (L _ (HsDo ArrowExpr _ _))=return Nothing --getType _ _ (L _ (HsArrApp {}))=return Nothing -getType hs_env tcm e = do #if __GLASGOW_HASKELL__ >= 707 +getType hs_env _ e = do (_, mbe) <- GMU.liftIO $ deSugarExpr hs_env e #else +getType hs_env tcm e = do + modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm + rn_env = tcg_rdr_env $ fst $ tm_internals_ tcm + ty_env = tcg_type_env $ fst $ tm_internals_ tcm (_, mbe) <- GMU.liftIO $ deSugarExpr hs_env modu rn_env ty_env e #endif return $ fmap CoreUtils.exprType mbe - where - modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm - rn_env = tcg_rdr_env $ fst $ tm_internals_ tcm - ty_env = tcg_type_env $ fst $ tm_internals_ tcm -- | show SDoc wrapper showSD :: Bool
− src/Language/Haskell/BuildWrapper/Packages.hs
@@ -1,222 +0,0 @@-{-# LANGUAGE CPP, ScopedTypeVariables #-} --- | --- Module : Language.Haskell.BuildWrapper.Packages --- Copyright : (c) Thiago Arrais 2009 --- License : BSD3 --- --- Maintainer : jpmoresmau@gmail.com --- Stability : beta --- Portability : portable --- --- Packages from packages databases (global, user). --- see <http://stackoverflow.com/questions/1522104/how-to-programmatically-retrieve-ghc-package-information> -module Language.Haskell.BuildWrapper.Packages ( getPkgInfos ) where - -import Language.Haskell.BuildWrapper.Base - -import Prelude hiding (Maybe) -import qualified Config -import qualified System.Info -import Data.List -import Data.Maybe -import Control.Monad -import Distribution.InstalledPackageInfo -import Distribution.Text -import System.Directory -import System.Environment (getEnv) -import System.FilePath -import System.IO -import qualified Control.Exception as Exc - -import GHC.Paths - -import qualified Control.Exception as Exception - --- This was borrowed from the ghc-pkg source: -type InstalledPackageInfoString = InstalledPackageInfo_ String - --- | Types of cabal package databases -data CabalPkgDBType = - PkgDirectory FilePath - | PkgFile FilePath - -type InstalledPackagesList = [(FilePath, [InstalledPackageInfo])] - --- | Fetch the installed package info from the global and user package.conf --- databases, mimicking the functionality of ghc-pkg. - -getPkgInfos :: Maybe FilePath -- ^ the path to the cabal-dev sandbox if any - -> IO InstalledPackagesList -getPkgInfos msandbox= - let - -- | Test for package database's presence in a given directory - -- NB: The directory is returned for later scanning by listConf, - -- which parses the actual package database file(s). - lookForPackageDBIn :: FilePath -> IO (Maybe InstalledPackagesList) - lookForPackageDBIn dir = - let - path_dir = dir </> "package.conf.d" - path_file = dir </> "package.conf" - path_sd_dir= dir </> ("packages-" ++ ghcVersion ++ ".conf") - -- cabal sandboxes - path_ghc_dir= dir </> currentArch ++ '-' : currentOS ++ "-ghc-" ++ ghcVersion ++ "-packages.conf.d" - - in do - exists_dir <- doesDirectoryExist path_dir - if exists_dir - then do - pkgs <- readContents (PkgDirectory path_dir) - return $ Just pkgs - else do - exists_file <- doesFileExist path_file - if exists_file - then do - pkgs <- readContents (PkgFile path_file) - return $ Just pkgs - else do - exists_dirSd <- doesDirectoryExist path_sd_dir - if exists_dirSd - then do - pkgs <- readContents (PkgDirectory path_sd_dir) - return $ Just pkgs - else do - exists_dirGhc <- doesDirectoryExist path_ghc_dir - if exists_dirGhc - then do - pkgs <- readContents (PkgDirectory path_ghc_dir) - return $ Just pkgs - else return Nothing - currentArch :: String - currentArch = System.Info.arch - - currentOS :: String - currentOS = System.Info.os - - ghcVersion :: String - ghcVersion = Config.cProjectVersion - in do - -- Get the global package configuration database: - global_conf <- do - r <- lookForPackageDBIn getLibDir - case r of - Nothing -> ioError $ userError ("Can't find package database in " ++ getLibDir) - Just pkgs -> return pkgs - - -- Get the user package configuration database - user_conf <- case msandbox of - Nothing -> do - e_appdir <- Exc.try $ getAppUserDataDirectory "ghc" - case e_appdir of - Left (_::Exc.IOException) -> return [] - Right appdir -> do - let subdir - = currentArch ++ '-' : currentOS ++ '-' : ghcVersion - dir = appdir </> subdir - r <- lookForPackageDBIn dir - case r of - Nothing -> return [] - Just pkgs -> return pkgs - Just sd->do - r <- lookForPackageDBIn sd - case r of - Nothing -> return [] - Just pkgs -> return pkgs - -- Process GHC_PACKAGE_PATH, if present: - e_pkg_path <- Exc.try (getEnv "GHC_PACKAGE_PATH") - env_stack <- case e_pkg_path of - Left (_::Exc.IOException) -> return [] - Right path -> do - pkgs <- mapM readContents [PkgDirectory pkg | pkg <- splitSearchPath path] - return $ concat pkgs - - -- Send back the combined installed packages list: - return (env_stack ++ user_conf ++ global_conf) - --- | Read the contents of the given directory, searching for ".conf" files, and parse the --- package contents. Returns a singleton list (directory, [installed packages]) - -readContents :: CabalPkgDBType -- ^ The package database - -> IO [(FilePath, [InstalledPackageInfo])] -- ^ Installed packages - -readContents pkgdb = - let - -- | List package configuration files that might live in the given directory - listConf :: FilePath -> IO [FilePath] - listConf dbdir = do - conf_dir_exists <- doesDirectoryExist dbdir - if conf_dir_exists - then do - files <- getDirectoryContents dbdir - return [ dbdir </> file | file <- files, ".conf" `isSuffixOf` file] - else return [] - - -- | Read a file, ensuring that UTF8 coding is used for GCH >= 6.12 - readUTF8File :: FilePath -> IO String - readUTF8File file = do - h <- openFile file ReadMode -#if __GLASGOW_HASKELL__ >= 612 - -- fix the encoding to UTF-8 - hSetEncoding h utf8 - Exc.catch (hGetContents h) (\(err :: Exc.IOException)->do - print err - hClose h - h' <- openFile file ReadMode - hSetEncoding h' localeEncoding - hGetContents h' - ) -#else - hGetContents h -#endif - - - -- | This function was lifted directly from ghc-pkg. Its sole purpose is - -- parsing an input package description string and producing an - -- InstalledPackageInfo structure. - convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo - convertPackageInfoIn - (pkgconf@(InstalledPackageInfo { exposedModules = e, - hiddenModules = h })) = - pkgconf{ exposedModules = convert e, - hiddenModules = convert h } - where convert = mapMaybe simpleParse - - -- | Utility function that just flips the arguments to Control.Exception.catch - catchError :: IO a -> (String -> IO a) -> IO a - catchError io handler = io `Exception.catch` handler' - where handler' (Exception.ErrorCall err) = handler err - - -- | Slightly different approach in Cabal 1.8 series, with the package.conf.d - -- directories, where individual package configuration files are association - -- pairs. - pkgInfoReader :: FilePath - -> IO [InstalledPackageInfo] - pkgInfoReader f = - Exc.catch ( - do - pkgStr <- readUTF8File f - let pkgInfo = parseInstalledPackageInfo pkgStr - case pkgInfo of - ParseOk _ info -> return [info] - ParseFailed err -> do - print err - return [emptyInstalledPackageInfo] - ) (\(_::Exc.IOException)->return [emptyInstalledPackageInfo]) - - in case pkgdb of - (PkgDirectory pkgdbDir) -> do - confs <- listConf pkgdbDir - pkgInfoList <- mapM pkgInfoReader confs - return [(pkgdbDir, join pkgInfoList)] - - (PkgFile dbFile) -> do - pkgStr <- readUTF8File dbFile - let pkgs = map convertPackageInfoIn $ readObj "InstalledPackageInfo" pkgStr - pkgInfoList <- - Exception.evaluate pkgs - `catchError` - (\e-> ioError $ userError $ "parsing " ++ dbFile ++ ": " ++ show e) - return [(takeDirectory dbFile, pkgInfoList)] - --- GHC.Path sets libdir for us... -getLibDir :: String -getLibDir = libdir
src/Language/Haskell/BuildWrapper/Src.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances,OverloadedStrings,CPP #-} +{-# LANGUAGE TypeSynonymInstances,OverloadedStrings,CPP, PatternGuards #-} -- | -- Module : Language.Haskell.BuildWrapper.Src -- Copyright : (c) JP Moresmau 2011 @@ -11,6 +11,7 @@ -- Use haskell-src-exts to get a module outline module Language.Haskell.BuildWrapper.Src where +import Data.Maybe (isNothing) import Language.Haskell.BuildWrapper.Base import Language.Haskell.Exts.Annotated @@ -21,7 +22,7 @@ import qualified Data.Text as T import Data.Char (isSpace) import Data.List (foldl', isPrefixOf) -import Control.Monad.Trans.State.Lazy (State, get, evalState, put)+import Control.Monad.Trans.State.Lazy (State, get, evalState, put, runState) -- | get the AST getHSEAST :: String -- ^ input text @@ -54,7 +55,10 @@ -- | get the ouline from the AST getHSEOutline :: (Module SrcSpanInfo, [Comment]) -- ^ the commented AST -> [OutlineDef] -getHSEOutline (Module _ _ _ _ decls,comments)=evalState (mapM addComment $ concatMap declOutline decls) commentMap +getHSEOutline (Module _ _ _ _ decls,comments)=let + odecls = concatMap declOutline decls + (d2,m2) = runState (mapM (addComment False) odecls) $ commentMap + in evalState (mapM (addComment True) d2) m2 where declOutline :: Decl SrcSpanInfo -> [OutlineDef] declOutline (DataFamDecl l _ h _) = [mkOutlineDef (headDecl h) [Data,Family] (makeSpan l)] @@ -168,27 +172,32 @@ Just (ty,ss2)->if srcSpanEndLine (srcInfoSpan ss2) == (srcSpanStartLine (srcInfoSpan ss1) - 1) then (Just ty,combSpanInfo ss2 ss1) else (Just ty,ss1) - commentMap:: DM.Map Int (Int,Int,T.Text) + commentMap:: DM.Map Int (Int,Int,Bool,T.Text) commentMap = foldl' buildCommentMap DM.empty comments - addComment:: OutlineDef -> State (DM.Map Int (Int,Int,T.Text)) OutlineDef - addComment od=do + addComment:: Bool -> OutlineDef -> State (DM.Map Int (Int,Int,Bool,T.Text)) OutlineDef + addComment checkNext od =do cm<-get let st=iflLine $ ifsStart$ odLoc od -- search for comment before declaration (line above, same column) - pl=DM.lookup (st-1) cm - (cm2,od2)= case pl of + pl=map (flip DM.lookup cm) [st-1,st,st+1] + (cm2,od2)= if isNothing $ odComment od + then case (pl,checkNext) of -- | stc <= iflColumn (ifsStart $ odLoc od) -- stc ) - Just (_,stl,t)-> ( DM.delete (st-1) cm,od{odComment=Just t,odStartLineComment=Just stl}) - _ -> let - -- search for comment after declaration (same line) - pl2=DM.lookup st cm - in case pl2 of - Just (_,_,t)-> (DM.delete st cm,od{odComment=Just t}) - Nothing -> (cm,od) - children=evalState (mapM addComment $ odChildren od2) cm2 - put cm2 + ((Just (_,stl,True,t):_),_)-> ( DM.delete (st-1) cm,od{odComment=Just t,odStartLineComment=Just stl}) + ((_:Just (_,_,False,t):_),_) -> (DM.delete st cm,od{odComment=Just t}) + ((_:_:Just (_,_,False,t):_),True) -> (DM.delete (st+1) cm,od{odComment=Just t}) + _ -> (cm,od) +-- _ -> let +-- -- search for comment after declaration (same line) +-- pl2=DM.lookup st cm +-- in case pl2 of +-- Just (_,_,False,t)-> (DM.delete st cm,od{odComment=Just t}) +-- Nothing -> (cm,od) + else (cm,od) + (children,cm3)=runState (mapM (addComment checkNext) $ odChildren od2) cm2 + put cm3 return od2{odChildren=children} getHSEOutline _ = [] @@ -201,22 +210,22 @@ -- | build the comment map -buildCommentMap :: DM.Map Int (Int,Int,T.Text) -- ^ the map: key is line, value is start column, start line and comment text +buildCommentMap :: DM.Map Int (Int,Int,Bool,T.Text) -- ^ the map: key is line, value is start column, start line, comment is for after/before, and comment text -> Comment -- ^ the comment - -> DM.Map Int (Int,Int,T.Text) + -> DM.Map Int (Int,Int,Bool,T.Text) buildCommentMap m (Comment _ ss txt)=let txtTrimmed=dropWhile isSpace txt st=srcSpanStartLine ss stc=srcSpanStartColumn ss in case txtTrimmed of - ('|':rest)->DM.insert (srcSpanEndLine ss) (stc,srcSpanStartLine ss,T.pack $ dropWhile isSpace rest) m - ('^':rest)->DM.insert st (-1,st,T.pack $ dropWhile isSpace rest) m - _-> let - pl=DM.lookup (st-1) m - in case pl of - -- we merge the comment text with the comment before it - Just (stc2,sl,t)->DM.insert st (stc2,sl,T.concat [t,"\n",T.pack txt]) (DM.delete st m) - Nothing-> m + ('|':rest)->DM.insert (srcSpanEndLine ss) (stc,srcSpanStartLine ss,True,T.pack $ dropWhile isSpace rest) m + ('^':rest)->DM.insert st (-1,st,False,T.pack $ dropWhile isSpace rest) m + -- we merge the comment text with the comment before it + _ | Just (stc2,sl,pos,t) <- DM.lookup (st-1) m -> let + -- to lookup properly we use the last line for pre comment and the first for post comments + key = if pos then st else st-1 + in DM.insert key (stc2,sl,pos,T.concat [t,"\n",T.pack txt]) $ DM.delete (st-1) m + _ -> m -- | get the import/export declarations
test/Language/Haskell/BuildWrapper/CMDTests.hs view
@@ -28,7 +28,7 @@ import Control.Monad -import Data.Attoparsec+import Data.Attoparsec.ByteString import Data.Aeson import Data.Aeson.Parser import qualified Data.ByteString.Char8 as BS@@ -712,6 +712,50 @@ ] Nothing (Just "Type for an entry in file") (Just 3)] assertEqual (length expected) (length defs) mapM_ (uncurry assertEqual) (zip expected defs)+ +test_OutlineCommentsNextLine :: Assertion+test_OutlineCommentsNextLine= do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ let rel="src"</>"A.hs"+ -- use api to write temp file+ write api root rel $ unlines [+ "module Module1 where",+ "", + "-- | Type for an entry in file",+ "data CblEntry = ",+ " -- | This is the documentation for the 1. constructor",+ " CblCondition { cblCondition :: String }",+ " -- | This is the documentation for the FV",+ " | CblFieldValue { ",+ " cblFldName :: String",+ " -- ^ name of the field",+ " -- continued on a second line",+ " ,cblFldValues :: [String]",+ " -- ^ values of the field",+ " } -- ^ field-values pair" ]+ (_,nsErrors3f)<-getBuildFlags api root rel+ assertBool (null nsErrors3f) + (OutlineResult defs es is,nsErrors1)<-getOutline api root rel+ assertBool (null nsErrors1)+ assertEqual [] es+ assertEqual [] is+ let expected=[+ OutlineDef "CblEntry" [Data] (InFileSpan (InFileLoc 4 1)(InFileLoc 14 6)) [+ OutlineDef "CblCondition" [Constructor] (InFileSpan (InFileLoc 6 3) (InFileLoc 6 42))+ [+ OutlineDef "cblCondition" [Field] (InFileSpan (InFileLoc 6 18) (InFileLoc 6 40)) [] Nothing Nothing Nothing+ ] Nothing (Just "This is the documentation for the 1. constructor") (Just 5) + , OutlineDef "CblFieldValue" [Constructor] (InFileSpan (InFileLoc 8 5) (InFileLoc 14 6))+ [+ OutlineDef "cblFldName" [Field] (InFileSpan (InFileLoc 9 5) (InFileLoc 9 25)) [] Nothing (Just "name of the field\n continued on a second line") Nothing+ ,OutlineDef "cblFldValues" [Field] (InFileSpan (InFileLoc 12 6) (InFileLoc 12 30)) [] Nothing (Just "values of the field") Nothing+ ] Nothing (Just "This is the documentation for the FV") (Just 7) + ] Nothing (Just "Type for an entry in file") (Just 3)]+ assertEqual (length expected) (length defs)+ mapM_ (uncurry assertEqual) (zip expected defs)+ test_OutlinePreproc :: Assertion test_OutlinePreproc = do
test/Language/Haskell/BuildWrapper/UsagesTests.hs view
@@ -21,7 +21,7 @@ import System.Directory import System.FilePath -import System.Time +--import System.Time import qualified Data.ByteString.Lazy as BS -- import qualified Data.ByteString.Lazy.Char8 as BSC (putStrLn)