buildwrapper 0.4.1 → 0.5.0
raw patch · 16 files changed
+1262/−2136 lines, 16 filesdep +transformersdep ~vector
Dependencies added: transformers
Dependency ranges changed: vector
Files
- buildwrapper.cabal +13/−9
- src-exe/Language/Haskell/BuildWrapper/CMD.hs +62/−34
- src-exe/Main.hs +1/−0
- src/Language/Haskell/BuildWrapper/API.hs +90/−95
- src/Language/Haskell/BuildWrapper/Base.hs +187/−108
- src/Language/Haskell/BuildWrapper/Cabal.hs +205/−237
- src/Language/Haskell/BuildWrapper/Find.hs +0/−711
- src/Language/Haskell/BuildWrapper/GHC.hs +150/−496
- src/Language/Haskell/BuildWrapper/GHCStorage.hs +112/−58
- src/Language/Haskell/BuildWrapper/Packages.hs +16/−17
- src/Language/Haskell/BuildWrapper/Src.hs +105/−122
- test/Language/Haskell/BuildWrapper/APITest.hs +2/−25
- test/Language/Haskell/BuildWrapper/CMDTests.hs +6/−6
- test/Language/Haskell/BuildWrapper/GHCTests.hs +29/−18
- test/Language/Haskell/BuildWrapper/Tests.hs +284/−178
- test/Main.hs +0/−22
buildwrapper.cabal view
@@ -1,5 +1,5 @@ name: buildwrapper -version: 0.4.1 +version: 0.5.0 cabal-version: >= 1.8 build-type: Simple license: BSD3 @@ -31,7 +31,7 @@ ghc-syb-utils, text, containers, - vector, + vector >= 0.8, haskell-src-exts, cpphs, old-time, @@ -39,7 +39,8 @@ unordered-containers, utf8-string, bytestring, - attoparsec + attoparsec, + transformers ghc-options: -Wall -fno-warn-unused-do-bind exposed-modules: Language.Haskell.BuildWrapper.API, @@ -48,23 +49,26 @@ Language.Haskell.BuildWrapper.GHC extensions: CPP other-modules: - Language.Haskell.BuildWrapper.Find, + Language.Haskell.BuildWrapper.GHCStorage, Language.Haskell.BuildWrapper.Packages, - Language.Haskell.BuildWrapper.Src, - Language.Haskell.BuildWrapper.GHCStorage + Language.Haskell.BuildWrapper.Src executable buildwrapper hs-source-dirs: src-exe main-is: Main.hs - build-depends: base < 5, buildwrapper, cmdargs, filepath, Cabal, directory, mtl, ghc, cpphs,haskell-src-exts, old-time, ghc-syb-utils, ghc-paths - ,vector, containers, syb, process, regex-tdfa, text, aeson >=0.4, bytestring + build-depends: + base < 5, buildwrapper, cmdargs, filepath, Cabal, directory, mtl, ghc, cpphs,haskell-src-exts, old-time, ghc-syb-utils, ghc-paths + ,vector >= 0.8, containers, syb, process, regex-tdfa, text, aeson >=0.4, bytestring, + transformers ghc-options: -Wall -fno-warn-unused-do-bind other-modules: Language.Haskell.BuildWrapper.CMD test-suite buildwrapper-test type: exitcode-stdio-1.0 hs-source-dirs: test - build-depends: base < 5, buildwrapper, HUnit, mtl, filepath, directory, Cabal, old-time, aeson >=0.4, text, process, bytestring, attoparsec, test-framework, test-framework-hunit + build-depends: + base < 5, buildwrapper, HUnit, mtl, filepath, directory, Cabal, old-time, aeson >=0.4, text, process, bytestring, attoparsec, test-framework, test-framework-hunit, + transformers main-is: Main.hs ghc-options: -Wall -fno-warn-unused-do-bind x-uses-tf: true
src-exe/Language/Haskell/BuildWrapper/CMD.hs view
@@ -13,14 +13,15 @@ module Language.Haskell.BuildWrapper.CMD where import Language.Haskell.BuildWrapper.API -import Language.Haskell.BuildWrapper.Base +import Language.Haskell.BuildWrapper.Base hiding (tempFolder,cabalPath, cabalFile, cabalFlags,verbosity) import Control.Monad.State -import System.Console.CmdArgs hiding (Verbosity(..)) +import System.Console.CmdArgs hiding (Verbosity(..),verbosity) import Paths_buildwrapper import Data.Aeson import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BSC import Data.Version (showVersion) @@ -28,6 +29,7 @@ type CabalPath = FilePath type TempFolder = FilePath +-- | all the different actions and their parameters data BWCmd=Synchronize {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, force::Bool} | Synchronize1 {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, force::Bool, file:: FilePath} | Write {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, file:: FilePath, contents::String} @@ -37,70 +39,96 @@ | Outline {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, file:: FilePath} | TokenTypes {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, file:: FilePath} | Occurrences {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, file:: FilePath,token::String} - | ThingAtPoint {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, file:: FilePath, line::Int, column::Int, qualify::Bool, typed::Bool} + | ThingAtPointCmd {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, file:: FilePath, line::Int, column::Int} | NamesInScope {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, file:: FilePath} | Dependencies {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String} | Components {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String} | GetBuildFlags {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, file:: FilePath} deriving (Show,Read,Data,Typeable) - + +tf :: TempFolder tf=".dist-buildwrapper" &= typDir &= help "temporary folder, relative to cabal file folder" +cp :: CabalPath cp="cabal" &= typFile &= help "location of cabal executable" +cf :: CabalFile cf=def &= typFile &= help "cabal file" +fp :: FilePath fp=def &= typFile &= help "relative path of file to process" +ff :: Bool ff=def &= help "overwrite newer file" +uf :: String uf=def &= help "user cabal flags" +v :: Verbosity v=Normal &= help "verbosity" +wc :: WhichCabal wc=Target &= help "which cabal file to use: original or temporary" +msynchronize :: BWCmd msynchronize = Synchronize tf cp cf uf ff +msynchronize1 :: BWCmd msynchronize1 = Synchronize1 tf cp cf uf ff fp +mconfigure :: BWCmd mconfigure = Configure tf cp cf uf v wc +mwrite :: BWCmd mwrite= Write tf cp cf uf fp (def &= help "file contents") +mbuild :: BWCmd mbuild = Build tf cp cf uf v (def &= help "output compilation and linking result") wc +mbuild1 :: BWCmd mbuild1 = Build1 tf cp cf uf fp +mgetbf :: BWCmd mgetbf = GetBuildFlags tf cp cf uf fp +moutline :: BWCmd moutline = Outline tf cp cf uf fp +mtokenTypes :: BWCmd mtokenTypes= TokenTypes tf cp cf uf fp +moccurrences :: BWCmd moccurrences=Occurrences tf cp cf uf fp (def &= help "text to search occurrences of" &= name "token") -mthingAtPoint=ThingAtPoint tf cp cf uf fp +mthingAtPoint :: BWCmd +mthingAtPoint=ThingAtPointCmd tf cp cf uf fp (def &= help "line" &= name "line") (def &= help "column" &= name "column") - (def &= help "qualify results") - (def &= help "type results") +mnamesInScope :: BWCmd mnamesInScope=NamesInScope tf cp cf uf fp +mdependencies :: BWCmd mdependencies=Dependencies tf cp cf uf +mcomponents :: BWCmd mcomponents=Components tf cp cf uf -cmdMain = (cmdArgs $ - modes [msynchronize, msynchronize1, mconfigure,mwrite,mbuild,mbuild1,mgetbf, moutline, mtokenTypes,moccurrences,mthingAtPoint,mnamesInScope,mdependencies,mcomponents] - &= helpArg [explicit, name "help", name "h"] - &= help "buildwrapper executable" - &= program "buildwrapper" - &= summary ("buildwrapper executable, version " ++ (showVersion version)) - ) - >>= handle +-- | main method for command handling +cmdMain :: IO () +cmdMain = cmdArgs + (modes + [msynchronize, msynchronize1, mconfigure, mwrite, mbuild, mbuild1, + mgetbf, moutline, mtokenTypes, moccurrences, mthingAtPoint, + mnamesInScope, mdependencies, mcomponents] + &= helpArg [explicit, name "help", name "h"] + &= help "buildwrapper executable" + &= program "buildwrapper" + &= + summary + ("buildwrapper executable, version " ++ showVersion version)) + >>= handle where handle ::BWCmd -> IO () - handle (Synchronize tf cp cf uf ff )=run tf cp cf uf (synchronize ff) - handle (Synchronize1 tf cp cf uf ff fp)=run tf cp cf uf (synchronize1 ff fp) - handle (Write tf cp cf uf fp s)=run tf cp cf uf (write fp s) - handle (Configure tf cp cf uf v wc)=runV v tf cp cf uf (configure wc) - handle (Build tf cp cf uf v output wc)=runV v tf cp cf uf (build output wc) - handle (Build1 tf cp cf uf fp)=runV v tf cp cf uf (build1 fp) - handle (GetBuildFlags tf cp cf uf fp)=runV v tf cp cf uf (getBuildFlags fp) - handle (Outline tf cp cf uf fp)=run tf cp cf uf (getOutline fp) - handle (TokenTypes tf cp cf uf fp)=run tf cp cf uf (getTokenTypes fp) - handle (Occurrences tf cp cf uf fp token)=run tf cp cf uf (getOccurrences fp token) - handle (ThingAtPoint tf cp cf uf fp line column qual typed)=run tf cp cf uf (getThingAtPoint fp line column qual typed) - handle (NamesInScope tf cp cf uf fp)=run tf cp cf uf (getNamesInScope fp) - handle (Dependencies tf cp cf uf)=run tf cp cf uf getCabalDependencies - handle (Components tf cp cf uf)=run tf cp cf uf getCabalComponents - run:: (ToJSON a) => FilePath -> FilePath -> FilePath -> String -> StateT BuildWrapperState IO a -> IO () - run = runV Normal - runV:: (ToJSON a) => Verbosity -> FilePath -> FilePath -> FilePath -> String -> StateT BuildWrapperState IO a -> IO () - runV v tf cp cf uf f=(evalStateT f (BuildWrapperState tf cp cf v uf)) - >>= BS.putStrLn . BS.append "build-wrapper-json:" . encode + handle c@Synchronize{force=f}=runCmd c (synchronize f) + handle c@Synchronize1{force=f,file=fi}=runCmd c (synchronize1 f fi) + handle c@Write{file=fi,contents=s}=runCmd c (write fi s) + handle c@Configure{cabalTarget=w}=runCmd c (configure w) + handle c@Build{verbosity=ve,output=o,cabalTarget=w}=runCmdV ve c (build o w) + handle c@Build1{file=fi}=runCmd c (build1 fi) + handle c@GetBuildFlags{file=fi}=runCmd c (getBuildFlags fi) + handle c@Outline{file=fi}=runCmd c (getOutline fi) + handle c@TokenTypes{file=fi}=runCmd c (getTokenTypes fi) + handle c@Occurrences{file=fi,token=t}=runCmd c (getOccurrences fi t) + handle c@ThingAtPointCmd{file=fi,line=l,column=co}=runCmd c (getThingAtPoint fi l co) + handle c@NamesInScope{file=fi}=runCmd c (getNamesInScope fi) + handle c@Dependencies{}=runCmd c getCabalDependencies + handle c@Components{}=runCmd c getCabalComponents + runCmd :: (ToJSON a) => BWCmd -> StateT BuildWrapperState IO a -> IO () + runCmd=runCmdV Normal + runCmdV:: (ToJSON a) => Verbosity -> BWCmd -> StateT BuildWrapperState IO a -> IO () + runCmdV vb cmd f=evalStateT f (BuildWrapperState (tempFolder cmd) (cabalPath cmd) (cabalFile cmd) vb (cabalFlags cmd)) + >>= BSC.putStrLn . BS.append "build-wrapper-json:" . encode
src-exe/Main.hs view
@@ -13,5 +13,6 @@ import Language.Haskell.BuildWrapper.CMD +-- | main entry point main::IO() main = cmdMain
src/Language/Haskell/BuildWrapper/API.hs view
@@ -30,86 +30,72 @@ import Data.Maybe import System.Directory import System.FilePath ---import System.Time import GHC (TypecheckedSource) -synchronize :: Bool -> BuildWrapper(OpResult [FilePath]) +-- | copy all files from the project to the temporary folder +synchronize :: Bool -- ^ if true copy all files, if false only copy files newer than their corresponding temp files + -> BuildWrapper(OpResult [FilePath]) -- ^ return the list of files copied synchronize force =do cf<-gets cabalFile m<-copyFromMain force $ takeFileName cf (fileList,ns)<-getFilesToCopy - --liftIO $ putStrLn ("filelist:" ++ (show fileList)) - --let fileList=case motherFiles of - -- Nothing ->[] - -- Just fps->fps m1<-mapM (copyFromMain force)( "Setup.hs": "Setup.lhs": fileList) return (catMaybes (m : m1), ns) - -synchronize1 :: Bool -> FilePath -> BuildWrapper(Maybe FilePath) +-- | synchronize one file only +synchronize1 :: Bool -- ^ always copy the file, if false only copy the file if it is newer than its corresponding temp file + -> FilePath -- ^ the source file in the project folder + -> BuildWrapper(Maybe FilePath) -- ^ return Nothing if no copy or Just file if copied synchronize1 force fp = do m1<-mapM (copyFromMain force) [fp] return $ head m1 -write :: FilePath -> String -> BuildWrapper() +-- | write contents to temporary file +write :: FilePath -- ^ the source file in the project folder + -> String -- ^ the contents + -> BuildWrapper() write fp s= do real<-getTargetPath fp --liftIO $ putStrLn ("contents:"++s) liftIO $ writeFile real s -configure :: WhichCabal -> BuildWrapper (OpResult Bool) +-- | run cabal configure +configure :: WhichCabal -- ^ use the source or temp cabal + -> BuildWrapper (OpResult Bool) -- ^ True if configure succeeded configure which= do - --synchronize (mlbi,msgs)<-cabalConfigure which return (isJust mlbi,msgs) -build :: Bool -> WhichCabal -> BuildWrapper (OpResult BuildResult) +-- | run cabal build +build :: Bool -- ^ do we want output (True) or just compilation without linking? + -> WhichCabal -- ^ use original cabal or temp cabal file + -> BuildWrapper (OpResult BuildResult) build = cabalBuild -build1 :: FilePath -> BuildWrapper (OpResult Bool) +-- | build one source file in GHC +build1 :: FilePath -- ^ the source file + -> BuildWrapper (OpResult Bool) -- ^ True if build is successful build1 fp=do (mtm,msgs)<-getGHCAST fp return (isJust mtm,msgs) --- (bool,bwns)<-configure --- if bool --- then do --- (ret,bwns2)<-cabalBuild --- return (ret,(bwns++bwns2)) --- else --- return (bool,bwns) - --- ppContents :: String -> String --- ppContents = unlines . (map f) . lines --- where f ('#':_) = "" --- f x = x - -preproc :: CabalBuildInfo -> FilePath -> IO String -preproc cbi tgt= do - inputOrig<-readFile tgt - let lit=".lhs" == takeExtension tgt - let cppo=fileCppOptions cbi ++ ["-D__GLASGOW_HASKELL__=" ++ show (__GLASGOW_HASKELL__::Int)] ++ (if lit then ["--unlit"] else []) - --Prelude.putStrLn $ "cppo=" ++ (show cppo) - if not $ null cppo - then do - let epo=parseOptions cppo - case epo of - Right opts2->runCpphs opts2 tgt inputOrig - Left _->return inputOrig - else return inputOrig - -preprocF :: BuildFlags -> FilePath -> IO String -preprocF bf tgt= do +-- | preprocess a file +preproc :: BuildFlags -- ^ the build flags + -> FilePath -- ^ the file to preprocess + -> IO String -- ^ the resulting code +preproc bf tgt= do inputOrig<-readFile tgt let epo=parseOptions $ bf_preproc bf case epo of Right opts2->runCpphs opts2 tgt inputOrig Left _->return inputOrig -getBuildFlags :: FilePath -> BuildWrapper (OpResult BuildFlags) +-- | get the build flags for a source file +getBuildFlags :: FilePath -- ^ the source file + -> BuildWrapper (OpResult BuildFlags) getBuildFlags fp=do tgt<-getTargetPath fp src<-getCabalFile Source @@ -121,34 +107,51 @@ (mcbi,bwns)<-getBuildInfo fp ret<-case mcbi of Just cbi->do - let (modName,opts)=cabalExtensions $ snd cbi (_,opts2)<-fileGhcOptions cbi - let lit=".lhs" == takeExtension fp - let cppo=(fileCppOptions $ snd cbi) ++ ["-D__GLASGOW_HASKELL__=" ++ show (__GLASGOW_HASKELL__::Int)] ++ (if lit then ["--unlit"] else []) - let modS=moduleToString modName + let + (modName,opts)=cabalExtensions $ snd cbi + lit=".lhs" == takeExtension fp + cppo=fileCppOptions (snd cbi) ++ ["-D__GLASGOW_HASKELL__=" ++ show (__GLASGOW_HASKELL__ :: Int)] ++ ["--unlit" | lit] + modS=moduleToString modName return (BuildFlags (opts ++ opts2) cppo (Just modS),bwns) Nothing -> return (BuildFlags knownExtensionNames [] Nothing,[]) liftIO $ storeBuildFlagsInfo tgt ret return ret -getAST :: FilePath -> BuildWrapper (OpResult (Maybe (ParseResult (Module SrcSpanInfo, [Comment])))) +-- | get haskell-src-exts commented AST for source file +getAST :: FilePath -- ^ the source file + -> BuildWrapper (OpResult (Maybe (ParseResult (Module SrcSpanInfo, [Comment])))) getAST fp=do (bf,ns)<-getBuildFlags fp tgt<-getTargetPath fp - input<-liftIO $ preprocF bf tgt + input<-liftIO $ preproc bf tgt pr<- liftIO $ getHSEAST input (bf_ast bf) return (Just pr,ns) - -getGHCAST :: FilePath -> BuildWrapper (OpResult (Maybe TypecheckedSource)) +-- | get GHC typechecked AST for source file +getGHCAST :: FilePath -- ^ the source file + -> BuildWrapper (OpResult (Maybe TypecheckedSource)) getGHCAST fp = withGHCAST' fp (\_->BwGHC.getAST) -withGHCAST :: FilePath -> (FilePath -> FilePath -> String -> [String] -> IO a) -> BuildWrapper (OpResult (Maybe a)) +-- | perform an action on the GHC AST +withGHCAST :: FilePath -- ^ the source file + -> (FilePath -- ^ the source file + -> FilePath -- ^ the base directory + -> String -- ^ the module name + -> [String] -- ^ the GHC options + -> IO a) + -> BuildWrapper (OpResult (Maybe a)) withGHCAST fp f=withGHCAST' fp (\n a b c d->do r<- f a b c d - return $ ((Just r),n)) + return (Just r,n)) -withGHCAST' :: FilePath -> ([BWNote] -> FilePath -> FilePath -> String -> [String] -> IO (OpResult (Maybe a))) -> BuildWrapper (OpResult (Maybe a)) +withGHCAST' :: FilePath -- ^ the source file + -> ([BWNote] -- ^ the notes from getting the flags + -> FilePath -- ^ the source file + -> FilePath -- ^ the base directory + -> String -- ^ the module name + -> [String] -- ^ the GHC options + -> IO (OpResult (Maybe a))) -> BuildWrapper (OpResult (Maybe a)) withGHCAST' fp f= do (bf,ns)<-getBuildFlags fp case bf of @@ -163,76 +166,68 @@ return (pr,ns ++ bwns2) _ -> return (Nothing,ns) - -getOutline :: FilePath -> BuildWrapper (OpResult OutlineResult) +-- | get outline for source file +getOutline :: FilePath -- ^ source file + -> BuildWrapper (OpResult OutlineResult) getOutline fp=do (mast,bwns)<-getAST fp - --liftIO $ putStrLn $ show mast case mast of Just (ParseOk ast)->do + liftIO $ Prelude.print ast let ods=getHSEOutline ast let (es,is)=getHSEImportExport ast return (OutlineResult ods es is,bwns) - Just (ParseFailed loc err)->return (OutlineResult [] [] [],(BWNote BWError err (BWLocation fp (srcLine loc) (srcColumn loc))):bwns) + Just (ParseFailed failLoc err)->return (OutlineResult [] [] [],BWNote BWError err (BWLocation fp (srcLine failLoc) (srcColumn failLoc)) :bwns) _ -> return (OutlineResult [] [] [],bwns) -getTokenTypes :: FilePath -> BuildWrapper (OpResult [TokenDef]) +-- | get lexer token types for source file +getTokenTypes :: FilePath -- ^ the source file + -> BuildWrapper (OpResult [TokenDef]) getTokenTypes fp=do --- c1<-liftIO $ getClockTime --- (mcbi,bwns)<-getBuildInfo fp --- case mcbi of --- Just(cbi)->do --- let (_,opts)=cabalExtensions $ snd cbi --- tgt<-getTargetPath fp --- ett<-liftIO $ do --- input<-readFile tgt --- putStrLn $ show $ length input --- ett2<-BwGHC.tokenTypesArbitrary tgt input (".lhs" == (takeExtension fp)) opts --- c2<-getClockTime --- putStrLn ("getTokenTypes: " ++ (show $ tdPicosec $ diffClockTimes c2 c1)) --- return ett2 --- case ett of --- Right tt->return (tt,bwns) --- Left bw -> return ([],bw:bwns) --- Nothing-> do tgt<-getTargetPath fp ett<-liftIO $ do - --let dir=takeDirectory cf - --liftIO $ putStrLn "not in cabal" - input<-readFile tgt --(dir </> fp) - ett2<-BwGHC.tokenTypesArbitrary tgt input (".lhs" == (takeExtension fp)) knownExtensionNames - --case ett2 of - -- Right tt-> putStrLn ("getTokenTypes: " ++ (show $ length tt)) - -- Left _->return() - --c2<-getClockTime - --putStrLn ("getTokenTypes: " ++ (show $ (\x->div x 1000000000) $ tdPicosec $ diffClockTimes c2 c1) ++"ms") - return ett2 + input<-readFile tgt + BwGHC.tokenTypesArbitrary tgt input (".lhs" == takeExtension fp) knownExtensionNames case ett of - Right tt->return (tt,[]) -- bwns - Left bw -> return ([],bw:[]) -- bwns + Right tt->return (tt,[]) + Left bw -> return ([],[bw]) - -getOccurrences :: FilePath -> String -> BuildWrapper (OpResult [TokenDef]) +-- ^ get all occurrences of a token in the file +getOccurrences :: FilePath -- ^ the source file + -> String -- ^ the token to search for + -> BuildWrapper (OpResult [TokenDef]) getOccurrences fp query=do - ((BuildFlags opts _ _),_)<-getBuildFlags fp + (BuildFlags opts _ _, _)<-getBuildFlags fp tgt<-getTargetPath fp input<-liftIO $ readFile tgt - ett<-liftIO $ BwGHC.occurrences tgt input (T.pack query) (".lhs" == (takeExtension fp)) opts + ett<-liftIO $ BwGHC.occurrences tgt input (T.pack query) (".lhs" == takeExtension fp) opts case ett of Right tt->return (tt,[]) Left bw -> return ([],[bw]) - -getThingAtPoint :: FilePath -> Int -> Int -> Bool -> Bool -> BuildWrapper (OpResult (Maybe String)) -getThingAtPoint fp line col qual typed=withGHCAST fp $ BwGHC.getThingAtPointJSON line col qual typed +-- | get thing at point +getThingAtPoint :: FilePath -- ^ the source file + -> Int -- ^ the line + -> Int -- ^ the column +-- -> Bool -- ^ do we want the result qualified? +-- -> Bool -- ^ do we want the result typed? + -> BuildWrapper (OpResult (Maybe ThingAtPoint)) +getThingAtPoint fp line col=do + mm<-withGHCAST fp $ BwGHC.getThingAtPointJSON line col + return $ case mm of + (Just m,ns)->(m,ns) + (Nothing,ns)-> (Nothing,ns) +-- | get all names in scope (GHC API) getNamesInScope :: FilePath-> BuildWrapper (OpResult (Maybe [String])) getNamesInScope fp=withGHCAST fp BwGHC.getGhcNamesInScope +-- | get cabal dependencies getCabalDependencies :: BuildWrapper (OpResult [(FilePath,[CabalPackage])]) getCabalDependencies = cabalDependencies +-- | get cabal components getCabalComponents :: BuildWrapper (OpResult [CabalComponent]) getCabalComponents = cabalComponents
src/Language/Haskell/BuildWrapper/Base.hs view
@@ -24,17 +24,21 @@ import System.Directory import System.FilePath +import Data.List (isPrefixOf) +-- | State type type BuildWrapper=StateT BuildWrapperState IO +-- | the state we keep data BuildWrapperState=BuildWrapperState{ - tempFolder::String, - cabalPath::FilePath, - cabalFile::FilePath, - verbosity::Verbosity, - cabalFlags::String + tempFolder::String -- ^ name of temporary folder + ,cabalPath::FilePath -- ^ path to the cabal executable + ,cabalFile::FilePath -- ^ path of the project cabal file + ,verbosity::Verbosity -- ^ verbosity of logging + ,cabalFlags::String -- ^ flags to pass cabal } +-- | status of notes: error or warning data BWNoteStatus=BWError | BWWarning deriving (Show,Read,Eq) @@ -45,10 +49,11 @@ parseJSON (String t) =return $ read $ T.unpack $ T.append "BW" t parseJSON _= mzero +-- | location of a note/error data BWLocation=BWLocation { - bwl_src::FilePath, - bwl_line::Int, - bwl_col::Int + bwl_src::FilePath -- ^ source file + ,bwl_line::Int -- ^ line + ,bwl_col::Int -- ^ column } deriving (Show,Read,Eq) @@ -62,10 +67,11 @@ v .: "c" parseJSON _= mzero +-- | a note on a source file data BWNote=BWNote { - bwn_status :: BWNoteStatus, - bwn_title :: String, - bwn_location :: BWLocation + bwn_status :: BWNoteStatus -- ^ status of the note + ,bwn_title :: String -- ^ message + ,bwn_location :: BWLocation -- ^ where the note is } deriving (Show,Read,Eq) @@ -81,8 +87,10 @@ v .: "l" parseJSON _= mzero +-- | simple type encapsulating the fact the operations return along with notes generated on files type OpResult a=(a,[BWNote]) +-- | result: success + files impacted data BuildResult=BuildResult Bool [FilePath] deriving (Show,Read,Eq) @@ -95,9 +103,13 @@ v .: "fps" parseJSON _= mzero -data WhichCabal=Source | Target +-- | which cabal file to use operations +data WhichCabal= + Source -- ^ use proper file + | Target -- ^ use temporary file that was saved in temp folder deriving (Show,Read,Eq,Enum,Data,Typeable) +-- | type of elements for the outline data OutlineDefType = Class | Data | @@ -119,10 +131,16 @@ parseJSON (String s) =return $ read $ T.unpack s parseJSON _= mzero -data InFileLoc=InFileLoc {ifl_line::Int,ifl_column::Int} +-- | Location inside a file, the file is known and doesn't need to be repeated +data InFileLoc=InFileLoc {ifl_line::Int -- ^ line + ,ifl_column::Int -- ^ column + } deriving (Show,Read,Eq,Ord) -data InFileSpan=InFileSpan {ifs_start::InFileLoc,ifs_end::InFileLoc} +-- | Span inside a file, the file is known and doesn't need to be repeated +data InFileSpan=InFileSpan {ifs_start::InFileLoc -- ^ start location + ,ifs_end::InFileLoc -- ^ end location + } deriving (Show,Read,Eq,Ord) instance ToJSON InFileSpan where @@ -130,38 +148,63 @@ instance FromJSON InFileSpan where parseJSON (Array v) | - Success v0 <- fromJSON $ (v V.! 0), - Success v1 <- fromJSON $ (v V.! 1), - Success v2 <- fromJSON $ (v V.! 2), - Success v3 <- fromJSON $ (v V.! 3)=return $ InFileSpan (InFileLoc v0 v1) (InFileLoc v2 v3) + Success v0 <- fromJSON (v V.! 0), + Success v1 <- fromJSON (v V.! 1), + Success v2 <- fromJSON (v V.! 2), + Success v3 <- fromJSON (v V.! 3)=return $ InFileSpan (InFileLoc v0 v1) (InFileLoc v2 v3) parseJSON _= mzero - -mkFileSpan :: Int -> Int -> Int -> Int -> InFileSpan +-- | construct a file span +mkFileSpan :: Int -- ^ start line + -> Int -- ^ start column + -> Int -- ^ end line + -> Int -- ^ end column + -> InFileSpan mkFileSpan sr sc er ec=InFileSpan (InFileLoc sr sc) (InFileLoc er ec) +-- | element of the outline result data OutlineDef = OutlineDef - { od_name :: T.Text, - od_type :: [OutlineDefType], - od_loc :: InFileSpan, - od_children :: [OutlineDef] + { od_name :: T.Text -- ^ name + ,od_type :: [OutlineDefType] -- ^ types: can have several to combine + ,od_loc :: InFileSpan -- ^ span in source + ,od_children :: [OutlineDef] -- ^ children (constructors...) + ,od_signature :: Maybe T.Text -- ^ type signature if any + ,od_comment :: Maybe T.Text -- ^ comment if any } deriving (Show,Read,Eq,Ord) +-- | constructs an OutlineDef with no children and no type signature +mkOutlineDef :: T.Text -- ^ name + -> [OutlineDefType] -- ^ types: can have several to combine + -> InFileSpan -- ^ span in source + -> OutlineDef +mkOutlineDef n t l= mkOutlineDefWithChildren n t l [] + +-- | constructs an OutlineDef with children and no type signature +mkOutlineDefWithChildren :: T.Text -- ^ name + -> [OutlineDefType] -- ^ types: can have several to combine + -> InFileSpan -- ^ span in source + -> [OutlineDef] -- ^ children (constructors...) + -> OutlineDef +mkOutlineDefWithChildren n t l c= OutlineDef n t l c Nothing Nothing + instance ToJSON OutlineDef where - toJSON (OutlineDef n tps l c)= object ["n" .= n , "t" .= map toJSON tps, "l" .= l, "c" .= map toJSON c] + toJSON (OutlineDef n tps l c ts d)= object ["n" .= n , "t" .= map toJSON tps, "l" .= l, "c" .= map toJSON c, "s" .= ts, "d" .= d] instance FromJSON OutlineDef where parseJSON (Object v) =OutlineDef <$> v .: "n" <*> v .: "t" <*> v .: "l" <*> - v .: "c" + v .: "c" <*> + v .: "s" <*> + v .: "d" parseJSON _= mzero +-- | Lexer token data TokenDef = TokenDef { - td_name :: T.Text, - td_loc :: InFileSpan + td_name :: T.Text -- ^ type of token + ,td_loc :: InFileSpan -- ^ location } deriving (Show,Eq) @@ -175,11 +218,12 @@ Success v0 <- fromJSON b=return $ TokenDef a v0 parseJSON _= mzero -data ImportExportType = IEVar - | IEAbs - | IEThingAll - | IEThingWith - | IEModule +-- | Type of import/export directive +data ImportExportType = IEVar -- ^ Var + | IEAbs -- ^ Abs + | IEThingAll -- ^ import/export everythin + | IEThingWith -- ^ specific import/export list + | IEModule -- ^ reexport module deriving (Show,Read,Eq,Ord,Enum) instance ToJSON ImportExportType where @@ -189,11 +233,12 @@ parseJSON (String s) =return $ read $ T.unpack s parseJSON _= mzero +-- | definition of export data ExportDef = ExportDef { - e_name :: T.Text, - e_type :: ImportExportType, - e_loc :: InFileSpan, - e_children :: [T.Text] + e_name :: T.Text -- ^ name + ,e_type :: ImportExportType -- ^ type + ,e_loc :: InFileSpan -- ^ location in source file + ,e_children :: [T.Text] -- ^ children (constructor names, etc.) } deriving (Show,Eq) instance ToJSON ExportDef where @@ -207,11 +252,12 @@ v .: "c" parseJSON _= mzero +-- | definition of an import element data ImportSpecDef = ImportSpecDef { - is_name :: T.Text, - is_type :: ImportExportType, - is_loc :: InFileSpan, - is_children :: [T.Text] + is_name :: T.Text -- ^ name + ,is_type :: ImportExportType -- ^ type + ,is_loc :: InFileSpan -- ^ location in source file + ,is_children :: [T.Text] -- ^ children (constructor names, etc.) } deriving (Show,Eq) instance ToJSON ImportSpecDef where @@ -225,13 +271,14 @@ v .: "c" parseJSON _= mzero +-- | definition of an import statement data ImportDef = ImportDef { - i_module :: T.Text, - i_loc :: InFileSpan, - i_qualified :: Bool, - i_hiding :: Bool, - i_alias :: T.Text, - i_children :: Maybe [ImportSpecDef] + i_module :: T.Text -- ^ module name + ,i_loc :: InFileSpan -- ^ location in source file + ,i_qualified :: Bool -- ^ is the import qualified + ,i_hiding :: Bool -- ^ is the import element list for hiding or exposing + ,i_alias :: T.Text -- ^ alias name + ,i_children :: Maybe [ImportSpecDef] -- ^ specific import elements } deriving (Show,Eq) instance ToJSON ImportDef where @@ -246,11 +293,12 @@ v .: "a" <*> v .: "c" parseJSON _= mzero - + +-- | complete result for outline data OutlineResult = OutlineResult { - or_outline :: [OutlineDef], - or_exports :: [ExportDef], - or_imports :: [ImportDef] + or_outline :: [OutlineDef] -- ^ outline contents + ,or_exports :: [ExportDef] -- ^ exports + ,or_imports :: [ImportDef] -- ^ imports } deriving (Show,Eq) @@ -264,11 +312,11 @@ v .: "i" parseJSON _= mzero - +-- | build flags for a specific file data BuildFlags = BuildFlags { - bf_ast :: [String], - bf_preproc :: [String], - bf_modName :: Maybe String + bf_ast :: [String] -- ^ flags for GHC + ,bf_preproc :: [String] -- ^ flags for preprocessor + ,bf_modName :: Maybe String -- ^ module name if known } deriving (Show,Read,Eq,Data,Typeable) @@ -282,47 +330,74 @@ v .: "m" parseJSON _= mzero - - ---withCabal :: (GenericPackageDescription -> BuildWrapper a) -> BuildWrapper (Either BWNote a) ---withCabal f =do --- cf<-gets cabalFile --- pr<-parseCabal --- case pr of --- ParseOk _ a ->(liftM Right) $ f a --- ParseFailed p->return $ Left $ peErrorToBWNote (takeFileName cf) p --- ---parseCabal :: BuildWrapper(ParseResult GenericPackageDescription) ---parseCabal = do --- cf<-gets cabalFile --- return $ parsePackageDescription cf - -getFullTempDir :: BuildWrapper(FilePath) +data ThingAtPoint = ThingAtPoint { + tapName :: String, + tapModule :: Maybe String, + tapType :: Maybe String, + tapQType :: Maybe String, + tapHType :: Maybe String, + tapGType :: Maybe String + } + deriving (Show,Read,Eq,Data,Typeable) + +instance ToJSON ThingAtPoint where + toJSON (ThingAtPoint name modu stype qtype htype gtype)=object ["Name" .= name, "Module" .= modu, "Type" .= stype, "QType" .= qtype, "HType" .= htype, "GType" .= gtype] + +instance FromJSON ThingAtPoint where + parseJSON (Object v)=ThingAtPoint <$> + v .: "Name" <*> + v .: "Module" <*> + v .: "Type" <*> + v .: "QType" <*> + v .: "HType" <*> + v .: "GType" + parseJSON _= mzero + +-- | get the full path for the temporary directory +getFullTempDir :: BuildWrapper FilePath getFullTempDir = do cf<-gets cabalFile temp<-gets tempFolder - let dir=(takeDirectory cf) - return $ (dir </> temp) + let dir=takeDirectory cf + return (dir </> temp) -getDistDir :: BuildWrapper(FilePath) +-- | get the full path for the temporary dist directory (where cabal will write its output) +getDistDir :: BuildWrapper FilePath getDistDir = do temp<-getFullTempDir - return $ (temp </> "dist") + return (temp </> "dist") -getTargetPath :: FilePath -> BuildWrapper(FilePath) +-- | get full path in temporary folder for source file (i.e. where we're going to write the temporary contents of an edited file) +getTargetPath :: FilePath -- ^ relative path of source file + -> BuildWrapper FilePath getTargetPath src=do temp<-getFullTempDir let path=temp </> src liftIO $ createDirectoryIfMissing True (takeDirectory path) return path -getFullSrc :: FilePath -> BuildWrapper(FilePath) +-- | get the full, canonicalized path of a source +canonicalizeFullPath :: FilePath -- ^ relative path of source file + -> BuildWrapper FilePath +canonicalizeFullPath fp =do + full<-getFullSrc fp + ex<-liftIO $ doesFileExist full -- on OSX with GHC 7.0, canonicalizePath fails on non existing paths, so let's be defensive + if ex + then liftIO $ canonicalizePath full + else return full + +-- | get the full path of a source +getFullSrc :: FilePath -- ^ relative path of source file + -> BuildWrapper FilePath getFullSrc src=do cf<-gets cabalFile - let dir=(takeDirectory cf) - return $ (dir </> src) + let dir=takeDirectory cf + return (dir </> src) -copyFromMain :: Bool -> FilePath -> BuildWrapper(Maybe FilePath) +-- | copy a file from the normal folders to the temp folder +copyFromMain :: Bool -- ^ copy even if temp file is newer + -> FilePath -- ^ relative path of source file + -> BuildWrapper(Maybe FilePath) -- ^ return Just the file if copied, Nothing if no copy was done copyFromMain force src=do fullSrc<-getFullSrc src exSrc<-liftIO $ doesFileExist fullSrc @@ -330,40 +405,43 @@ then do fullTgt<-getTargetPath src ex<-liftIO $ doesFileExist fullTgt - shouldCopy<- if (force || (not ex)) - then return True - else do - modSrc<-liftIO $ getModificationTime fullSrc - modTgt<-liftIO $ getModificationTime fullTgt - return (modSrc>=modTgt) + shouldCopy<- if force || not ex + then return True + else + do modSrc <- liftIO $ getModificationTime fullSrc + modTgt <- liftIO $ getModificationTime fullTgt + return (modSrc >= modTgt) -- if same date, we may thing precision is not good enough to be 100% sure tgt is newer, so we copy if shouldCopy then do - liftIO $ copyFileFull fullSrc fullTgt + liftIO $ copyFile fullSrc fullTgt return $ Just src else return Nothing else return Nothing -copyFileFull :: FilePath -> FilePath -> IO() -copyFileFull src tgt=do - --createDirectoryIfMissing True (takeDirectory tgt) - --putStrLn tgt - copyFile src tgt - +-- | replace relative file path by module name fileToModule :: FilePath -> String fileToModule fp=map rep (dropExtension fp) where rep '/' = '.' rep '\\' = '.' rep a = a - + +-- | Verbosity settings data Verbosity = Silent | Normal | Verbose | Deafening deriving (Show, Read, Eq, Ord, Enum, Bounded,Data,Typeable) +-- | component in cabal file data CabalComponent - = CCLibrary { cc_buildable :: Bool} - | CCExecutable { cc_exe_name :: String - , cc_buildable :: Bool} - | CCTestSuite { cc_test_name :: String - , cc_buildable :: Bool} + = CCLibrary -- ^ library + { cc_buildable :: Bool -- ^ is the library buildable + } + | CCExecutable -- executable + { cc_exe_name :: String -- ^ executable name + , cc_buildable :: Bool -- ^ is the executable buildable + } + | CCTestSuite -- est suite + { cc_test_name :: String -- ^ test suite name + , cc_buildable :: Bool -- ^ is the test suite buildable + } deriving (Eq, Show) instance ToJSON CabalComponent where @@ -379,12 +457,13 @@ | otherwise = mzero parseJSON _= mzero +-- | a cabal package data CabalPackage=CabalPackage { - cp_name::String, - cp_version::String, - cp_exposed::Bool, - cp_dependent::[CabalComponent], - cp_exposedModules::[String] + cp_name::String -- ^ name of package + ,cp_version::String -- ^ version + ,cp_exposed::Bool -- ^ is the package exposed or hidden + ,cp_dependent::[CabalComponent] -- ^ components in the cabal file that use this package + ,cp_exposedModules::[String] -- ^ exposed modules } deriving (Eq, Show) @@ -404,7 +483,7 @@ getRecursiveContents :: FilePath -> IO [FilePath] getRecursiveContents topdir = do names <- getDirectoryContents topdir - let properNames = filter (`notElem` [".", ".."]) names + let properNames = filter (not . isPrefixOf ".") names paths <- forM properNames $ \name -> do let path = topdir </> name isDirectory <- doesDirectoryExist path @@ -413,14 +492,14 @@ else return [path] return (concat paths) - +-- | debug method: fromJust with a message to display when we get Nothing fromJustDebug :: String -> Maybe a -> a fromJustDebug s Nothing=error ("fromJust:" ++ s) fromJustDebug _ (Just a)=a - +-- | remove a base directory from a string representing a full path removeBaseDir :: FilePath -> String -> String -removeBaseDir base_dir s= loop s +removeBaseDir base_dir = loop where loop [] = [] loop str =
src/Language/Haskell/BuildWrapper/Cabal.hs view
@@ -19,7 +19,7 @@ import Data.Char -import Data.Function (on) +import Data.Ord (comparing) import Data.List import Data.Maybe import qualified Data.Map as DM @@ -29,8 +29,8 @@ import Distribution.ModuleName import Distribution.PackageDescription ( otherModules,library,executables,testSuites,Library,hsSourceDirs,libBuildInfo,Executable(..),exeName,modulePath,buildInfo,TestSuite(..),testName,TestSuiteInterface(..),testInterface,testBuildInfo,BuildInfo,cppOptions,defaultExtensions,otherExtensions,oldExtensions ) import Distribution.Simple.GHC -import Distribution.Simple.LocalBuildInfo - +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Compiler(OptimisationLevel(..)) import qualified Distribution.PackageDescription as PD import Distribution.Package import Distribution.InstalledPackageInfo as IPI @@ -46,53 +46,17 @@ import System.Exit import System.FilePath import System.Process ---import System.Time - - +import Data.Functor.Identity (runIdentity) getFilesToCopy :: BuildWrapper(OpResult [FilePath]) getFilesToCopy =do (mfps,bwns)<-withCabal Source getAllFiles return $ case mfps of - Just fps->(nub $ concatMap (\(_,_,_,_,ls)->map snd ls) fps,bwns) + Just fps->(nub $ concatMap (map snd . cbiModulePaths) fps,bwns) Nothing ->([],bwns); ---maybe (return []) (\f->concat $ (map (\(_,_,ls)->ls)) f) getAllFiles - -{--withCabal True (\gpd->do - let pd=localPkgDescr gpd - let libs=maybe [] extractFromLib $ library pd - let exes=concatMap extractFromExe $ executables pd - let tests=concatMap extractFromTest $ testSuites pd - return (libs ++ exes ++ tests) - ) - where - extractFromLib :: Library -> [FilePath] - extractFromLib l=let - modules=(exposedModules l) ++ (otherModules $ libBuildInfo l) - in copyModules modules (hsSourceDirs $ libBuildInfo l) - extractFromExe :: Executable -> [FilePath] - extractFromExe e=let - modules= (otherModules $ buildInfo e) - hsd=hsSourceDirs $ buildInfo e - in (copyFiles [modulePath e] hsd)++ (copyModules modules hsd) - extractFromTest :: TestSuite -> [FilePath] - extractFromTest e =let - modules= (otherModules $ testBuildInfo e) - hsd=hsSourceDirs $ testBuildInfo e - extras=case testInterface e of - (TestSuiteExeV10 _ mp)->(copyFiles [mp] hsd) - (TestSuiteLibV09 _ mn)->copyModules [mn] hsd - _->[] - in extras++ (copyModules modules hsd) - copyModules :: [ModuleName] -> [FilePath] -> [FilePath] - copyModules mods=copyFiles (concatMap (\m->[(toFilePath m) <.> "hs",(toFilePath m) <.> "lhs"]) mods) - copyFiles :: [FilePath] -> [FilePath] -> [FilePath] - copyFiles mods dirs=[d </> m | m<-mods, d<-dirs] - --} - -cabalV :: BuildWrapper (V.Verbosity) +cabalV :: BuildWrapper V.Verbosity cabalV =do v<-gets verbosity return $ toCabalV v @@ -102,8 +66,19 @@ toCabalV Verbose =V.verbose toCabalV Deafening =V.deafening -cabalBuild :: Bool -> WhichCabal -> BuildWrapper (OpResult BuildResult) -cabalBuild output srcOrTgt= do +-- | run cabal build +cabalBuild :: Bool -- ^ do we want output (True) or just compilation without linking? + -> WhichCabal -- ^ use original cabal or temp cabal file + -> BuildWrapper (OpResult BuildResult) +cabalBuild = cabalBuild' True + + +-- | run cabal build +cabalBuild' :: Bool -- ^ can we rerun configure again + -> Bool -- ^ do we want output (True) or just compilation without linking? + -> WhichCabal -- ^ use original cabal or temp cabal file + -> BuildWrapper (OpResult BuildResult) +cabalBuild' reRun output srcOrTgt= do dist_dir<-getDistDir (mr,n)<-withCabal srcOrTgt (\_->do cf<-getCabalFile srcOrTgt @@ -112,7 +87,7 @@ let args=[ "build", - "--verbose="++(show $ fromEnum v), + "--verbose=" ++ show (fromEnum v), "--builddir="++dist_dir ] ++ (if output @@ -122,38 +97,36 @@ liftIO $ do cd<-getCurrentDirectory setCurrentDirectory (takeDirectory cf) - -- c1<-getClockTime - -- f<-readFile ((takeDirectory cf) </> "src" </> "A.hs") - -- putStrLn "cabal build start" (ex,out,err)<-readProcessWithExitCode cp args "" putStrLn err - if (isInfixOf "cannot satisfy -package-id" err) || (isInfixOf "re-run the 'configure'" err) + if isInfixOf "cannot satisfy -package-id" err || isInfixOf "re-run the 'configure'" err then return Nothing else do - --putStrLn ("build out:" ++ out) - let fps=catMaybes $ map getBuiltPath $ lines out - -- c2<-getClockTime - -- putStrLn ("cabal build end" ++ (timeDiffToString $ diffClockTimes c2 c1)) + let fps=(mapMaybe getBuiltPath (lines out)) let ret=parseBuildMessages err setCurrentDirectory cd return $ Just (ex==ExitSuccess,ret,fps) ) case mr of - Nothing -> return ((BuildResult False []),n) - Just Nothing->do + Nothing -> return (BuildResult False [],n) + Just Nothing->if reRun + then do let setup_config = DSC.localBuildInfoFile dist_dir liftIO $ removeFile setup_config - cabalBuild output srcOrTgt - Just (Just (r,n2,fps)) -> return ((BuildResult r fps),n++n2) + cabalBuild' False output srcOrTgt + else return (BuildResult False [],n) + Just (Just (r,n2,fps)) -> return (BuildResult r fps, n ++ n2) -cabalConfigure :: WhichCabal-> BuildWrapper (OpResult (Maybe LocalBuildInfo)) +-- | run cabal configure +cabalConfigure :: WhichCabal -- ^ use original cabal or temp cabal file + -> BuildWrapper (OpResult (Maybe LocalBuildInfo)) -- ^ return the build info on success, or Nothing on failure cabalConfigure srcOrTgt= do cf<-getCabalFile srcOrTgt cp<-gets cabalPath - ok<-liftIO $ doesFileExist cf - if ok + okCF<-liftIO $ doesFileExist cf + if okCF then do v<-cabalV @@ -161,73 +134,42 @@ uf<-gets cabalFlags let args=[ "configure", - "--verbose="++(show $ fromEnum v), + "--verbose=" ++ show (fromEnum v), "--user", "--enable-tests", "--builddir="++dist_dir, "--flags="++uf ] - {--(_,Just hOut,Just hErr)<-liftIO $ createProcess - ((proc cp args){ - cwd = Just $takeDirectory cf, - std_out = CreatePipe, - std_err = CreatePipe - })--} liftIO $ do cd<-getCurrentDirectory setCurrentDirectory (takeDirectory cf) - --c1<-getClockTime - --c<-readFile cf - --putStrLn dist_dir - --putStrLn (takeDirectory cf) - --putStrLn (show $ fromEnum v) - --putStrLn "cabal configure start" (ex,_,err)<-readProcessWithExitCode cp args "" - --c2<-getClockTime - --putStrLn ("cabal configure end: " ++ (timeDiffToString $ diffClockTimes c2 c1)) putStrLn err let msgs=(parseCabalMessages (takeFileName cf) (takeFileName cp) err) -- ++ (parseCabalMessages (takeFileName cf) out) - --putStrLn ("msgs:"++(show $ length msgs)) ret<-case ex of ExitSuccess -> do lbi<-DSC.getPersistBuildConfig dist_dir return (Just lbi,msgs) - ExitFailure _ -> return $ (Nothing,msgs) + ExitFailure ec -> if null msgs + then return (Nothing,[BWNote BWError ("Cabal configure returned error code " ++ show ec) (BWLocation cf 0 1)]) + else return (Nothing, msgs) setCurrentDirectory cd return ret - else return (Nothing,[]) - {-- - v<-gets cabalVerbosity - gen_pkg_descr <- liftIO $ readPackageDescription v cf - dist_dir<-getDistDir - let prog_conf =defaultProgramConfiguration - let user_flags = [] --getSessionSelector userFlags - let config_flags = - (defaultConfigFlags prog_conf) - { configDistPref = Flag dist_dir - , configVerbosity = Flag v - , configUserInstall = Flag True - , configTests = Flag True - -- , configConfigurationsFlags = map (\(n,v)->(FlagName n,v)) user_flags - } - lbi<-liftIO $ handle (\(e :: IOError) -> return $ Left $ BWNote BWError "Cannot configure:" (show e) (BWLocation cf 1 1)) $ do - lbi <- liftIO $ DSC.configure (gen_pkg_descr, (Nothing, [])) - config_flags - liftIO $ DSC.writePersistBuildConfig dist_dir lbi - liftIO $ initialBuildSteps dist_dir (localPkgDescr lbi) lbi v - knownSuffixHandlers - return $ Right lbi - liftIO $ setCurrentDirectory cd - return lbi --} - -- cabal configure --buildir dist_dir -v=verbosity --user --enable-tests + else do + let err="Cabal file"++ cf ++" does not exist" + liftIO $ putStrLn err + return (Nothing,[BWNote BWError err (BWLocation cf 0 1)]) -getCabalFile :: WhichCabal -> BuildWrapper FilePath +-- | get the full path to the cabal file +getCabalFile :: WhichCabal -- ^ use original cabal or temp cabal file + -> BuildWrapper FilePath getCabalFile Source= gets cabalFile -getCabalFile Target= gets cabalFile - >>=return . takeFileName +getCabalFile Target= fmap takeFileName (gets cabalFile) >>=getTargetPath -cabalInit :: WhichCabal -> BuildWrapper (OpResult (Maybe LocalBuildInfo)) +-- | get Cabal build info, running configure if needed +cabalInit :: WhichCabal -- ^ use original cabal or temp cabal file + -> BuildWrapper (OpResult (Maybe LocalBuildInfo)) cabalInit srcOrTgt= do cabal_file<-getCabalFile srcOrTgt dist_dir<-getDistDir @@ -250,23 +192,25 @@ Nothing -> do liftIO $ putStrLn "configuring because persist build config not present" cabalConfigure srcOrTgt - Just _lbi -> do - return $ (Just _lbi,[]) - + Just _lbi -> return (Just _lbi, []) -withCabal :: WhichCabal -> (LocalBuildInfo -> BuildWrapper (a))-> BuildWrapper (OpResult (Maybe a)) +-- | run a action with the cabal build info +withCabal :: WhichCabal -- ^ use original cabal or temp cabal file + -> (LocalBuildInfo -> BuildWrapper a) -- ^ action to run if we get a build info + -> BuildWrapper (OpResult (Maybe a)) -- ^ the result of the action, or Nothing if we could get Cabal info withCabal srcOrTgt f=do (mlbi,notes)<-cabalInit srcOrTgt case mlbi of - Nothing-> do - --liftIO $ putStrLn (show err) - return $ (Nothing,notes) + Nothing-> return (Nothing, notes) Just lbi ->do - r<-(f lbi) + r<-f lbi return (Just r, notes) - -parseCabalMessages :: FilePath -> FilePath -> String -> [BWNote] +-- | parse cabal error messages and transform them in notre +parseCabalMessages :: FilePath -- ^ cabal file + -> FilePath -- ^ path to cabal executable + -> String -- ^ error output + -> [BWNote] parseCabalMessages cf cabalExe s=let (m,ls)=foldl parseCabalLine (Nothing,[]) $ lines s in nub $ case m of @@ -276,24 +220,24 @@ setupExe :: String setupExe=addExtension "setup" $ takeExtension cabalExe dropPrefixes :: [String] -> String -> Maybe String - dropPrefixes prfxs s=foldr (stripPrefixIfNeeded s) Nothing prfxs + dropPrefixes prfxs s2=foldr (stripPrefixIfNeeded s2) Nothing prfxs stripPrefixIfNeeded :: String -> String -> Maybe String -> Maybe String - stripPrefixIfNeeded _ _ j@(Just r)=j - stripPrefixIfNeeded s prfx _=stripPrefix prfx s + stripPrefixIfNeeded _ _ j@(Just _)=j + stripPrefixIfNeeded s3 prfx _=stripPrefix prfx s3 parseCabalLine :: (Maybe (BWNote,[String]),[BWNote]) -> String ->(Maybe (BWNote,[String]),[BWNote]) parseCabalLine (currentNote,ls) l - | isPrefixOf "Error:" l=(Just (BWNote BWError "" (BWLocation cf 1 1),[dropWhile isSpace $ drop 6 l]),addCurrent currentNote ls) - | isPrefixOf "Warning:" l=let + | "Error:" `isPrefixOf` l=(Just (BWNote BWError "" (BWLocation cf 1 1),[dropWhile isSpace $ drop 6 l]),addCurrent currentNote ls) + | "Warning:" `isPrefixOf` l=let msg=(dropWhile isSpace $ drop 8 l) - msg2=if isPrefixOf cf msg - then dropWhile isSpace $ drop ((length cf) + 1) msg + msg2=if cf `isPrefixOf` msg + then dropWhile isSpace $ drop (length cf + 1) msg else msg in (Just (BWNote BWWarning "" (BWLocation cf (extractLine msg2) 1),[msg2]),addCurrent currentNote ls) - | Just s <- dropPrefixes [cabalExe,setupExe] l= + | Just s4 <- dropPrefixes [cabalExe,setupExe] l= let - s2=dropWhile isSpace $ drop 1 s -- drop 1 for ":" that follows file name - in if isPrefixOf "At least the following" s2 - then (Just $ (BWNote BWError "" (BWLocation cf 1 1),[s2]),addCurrent currentNote ls) + s2=dropWhile isSpace $ drop 1 s4 -- drop 1 for ":" that follows file name + in if "At least the following" `isPrefixOf` s2 + then (Just (BWNote BWError "" (BWLocation cf 1 1), [s2]),addCurrent currentNote ls) else let (loc,rest)=span (/= ':') s2 @@ -307,7 +251,7 @@ else (loc,line',tail msg') in (Just (BWNote BWError "" (BWLocation realloc (read line) 1),[msg]),addCurrent currentNote ls) | Just (jcn,msgs)<-currentNote= - if (not $ null l) + if not $ null l then (Just (jcn,l:msgs),ls) else (Nothing,ls++[makeNote jcn msgs]) | otherwise =(Nothing,ls) @@ -317,20 +261,22 @@ (_,_,_,ls)=el =~ "\\(line ([0-9]*)\\)" :: (String,String,String,[String]) in if null ls then 1 - else (read $ head ls) + else read $ head ls - -parseBuildMessages :: String -> [BWNote] +-- | parse messages from build +parseBuildMessages :: String -- | the build output + -> [BWNote] parseBuildMessages s=let (m,ls)=foldl parseBuildLine (Nothing,[]) $ lines s - in ((nub $ case m of - Nothing -> ls - Just (bwn,msgs)->ls++[makeNote bwn msgs])) + in (nub $ + case m of + Nothing -> ls + Just (bwn, msgs) -> ls ++ [makeNote bwn msgs]) where parseBuildLine :: (Maybe (BWNote,[String]),[BWNote]) -> String ->(Maybe (BWNote,[String]),[BWNote]) parseBuildLine (currentNote,ls) l | Just (jcn,msgs)<-currentNote= - if (not $ null l) && (' ' ==(head l)) + if not (null l) && (' ' == head l) then (Just (jcn,l:msgs),ls) else (Nothing,ls++[makeNote jcn msgs]) -- | Just fp<-getBuiltPath l=(currentNote,ls,fp:fps) @@ -339,37 +285,67 @@ extractLocation el=let (_,_,aft,ls)=el =~ "(.+):([0-9]+):([0-9]+):" :: (String,String,String,[String]) in case ls of - (loc:line:col:[])-> (Just $ BWNote BWError (dropWhile isSpace aft) (BWLocation loc (read line) (read col))) + (loc:line:col:[])-> Just $ BWNote BWError (dropWhile isSpace aft) (BWLocation loc (read line) (read col)) _ -> Nothing -makeNote :: BWNote -> [String] ->BWNote +-- | add a message to the note +makeNote :: BWNote -- ^ original note + -> [String] -- ^ message lines + ->BWNote makeNote bwn msgs=let title=dropWhile isSpace $ unlines $ reverse msgs - in if isPrefixOf "Warning:" title + in if "Warning:" `isPrefixOf` title then bwn{bwn_title=dropWhile isSpace $ drop 8 title,bwn_status=BWWarning} else bwn{bwn_title=title} -getBuiltPath :: String -> Maybe FilePath +-- | get the path of a file getting compiled +getBuiltPath :: String -- ^ the message line + -> Maybe FilePath -- ^ the path if we could parse it getBuiltPath line=let (_,_,_,ls)=line =~ "\\[[0-9]+ of [0-9]+\\] Compiling .+\\( (.+), (.+)\\)" :: (String,String,String,[String]) in case ls of (src:_:[])->Just src _ -> Nothing -type CabalBuildInfo=(BuildInfo,ComponentLocalBuildInfo,FilePath,Bool,[(ModuleName,FilePath)]) +-- | the cabal build info for a specific component +data CabalBuildInfo=CabalBuildInfo { + cbiBuildInfo::BuildInfo -- ^ the build info + ,cbiComponentBuildInfo :: ComponentLocalBuildInfo -- ^ the component local build info + ,cbiBuildFolder::FilePath -- ^ the folder to build that component into + ,cbiIsLibrary::Bool -- ^ is the component the library + ,cbiModulePaths::[(ModuleName,FilePath)] -- ^ the module name and corresponding source file for each contained Haskell module + } -canonicalizeBuildInfo :: CabalBuildInfo -> IO CabalBuildInfo -canonicalizeBuildInfo (n1,n2,n3,n4,ls)=do - lsC<-mapM (\(m,path)->do - pathC<-canonicalizePath path - return (m,pathC)) ls - return (n1,n2,n3,n4,lsC) - -getBuildInfo :: FilePath -> BuildWrapper (OpResult (Maybe (LocalBuildInfo,CabalBuildInfo))) +-- | canonicalize the paths in the build info +canonicalizeBuildInfo :: CabalBuildInfo -> BuildWrapper CabalBuildInfo +canonicalizeBuildInfo =onModulePathsM (mapM (\(m,path)->do + pathC<-canonicalizeFullPath path + return (m,pathC))) + +-- | apply a function on the build info modules and paths, in a monad +onModulePathsM :: (Monad a) + =>([(ModuleName,FilePath)] -> a [(ModuleName,FilePath)]) -- ^ the function to apply + -> CabalBuildInfo -- ^ the original build info + -> a CabalBuildInfo -- ^ the result +onModulePathsM f cbi=do + let ls=cbiModulePaths cbi + fls<-f ls + return cbi{cbiModulePaths=fls} + +-- | apply a function on the build info modules and paths +onModulePaths :: ([(ModuleName,FilePath)] -> [(ModuleName,FilePath)]) -- ^ the function to apply + -> CabalBuildInfo -- ^ the original build info + -> CabalBuildInfo -- ^ the result +onModulePaths f =runIdentity . onModulePathsM (return . f) + +-- | get the build info for a given source file +-- if a source file is in several component, get the first one +getBuildInfo :: FilePath -- ^the source file + -> BuildWrapper (OpResult (Maybe (LocalBuildInfo,CabalBuildInfo))) getBuildInfo fp=do (mmr,bwns)<-go getReferencedFiles case mmr of - Just (Just a)->return $ ((Just a),bwns) + Just (Just a)->return (Just a, bwns) _ -> do (mmr2,bwns2)<-go getAllFiles return $ case mmr2 of @@ -378,58 +354,51 @@ where go f=withCabal Source (\lbi->do fps<-f lbi - fpC<-liftIO $ canonicalizePath fp - fpsC<-liftIO $ mapM canonicalizeBuildInfo fps - --liftIO $ putStrLn $ (show $ length fps) - --liftIO $ mapM_ (\(_,_,_,_,ls)->mapM_ (putStrLn . snd) ls) fps - let ok=filter (\(_,_,_,_,ls)->not $ null ls ) $ - --b==fpC || b==("." </> fpC) - map (\(n1,n2,n3,n4,ls)->(n1,n2,n3,n4,filter (\(_,b)->equalFilePath fpC b) ls) ) - fpsC - --liftIO $ putStrLn $ (show $ length ok) - --liftIO $ mapM_ (\(_,_,_,_,ls)->mapM_ (putStrLn . snd) ls) ok + fpC<-canonicalizeFullPath fp + fpsC<-mapM canonicalizeBuildInfo fps + let ok=filter (not . null . cbiModulePaths) $ + map (onModulePaths (filter (\(_,b)->equalFilePath fpC b))) fpsC return $ if null ok then Nothing - else Just $ (lbi,head ok)) - -fileGhcOptions :: (LocalBuildInfo,CabalBuildInfo) -> BuildWrapper(ModuleName,[String]) -fileGhcOptions (lbi,(bi,clbi,fp,isLib,ls))=do + else Just (lbi, head ok)) + +-- | get GHC options for a file +fileGhcOptions :: (LocalBuildInfo,CabalBuildInfo) -- ^ the cabal info + -> BuildWrapper(ModuleName,[String]) -- ^ the module name and the options to pass GHC +fileGhcOptions (lbi,CabalBuildInfo bi clbi fp isLib ls)=do dist_dir<-getDistDir let inplace=dist_dir </> "package.conf.inplace" inplaceExist<-liftIO $ doesFileExist inplace - let pkg=if isLib - then ["-package-name", display $ packageId $ localPkgDescr lbi ] - else if inplaceExist - then ["-package-conf",inplace] - else [] - return (fst $ head ls,pkg++(ghcOptions lbi bi clbi fp)) - + let pkg + | isLib = + ["-package-name", display $ packageId $ localPkgDescr lbi] + | inplaceExist = ["-package-conf", inplace] + | otherwise = [] + return (fst $ head ls,pkg ++ ghcOptions (lbi{withOptimization=NoOptimisation}) bi clbi fp) - -- libraries, executables, test suite: BuildInfo + all relevant modules - -- find if modules included correspond to a component - -- what about generated modules? - - -- libraryConfig :: Maybe ComponentLocalBuildInfo executableConfigs :: [(String, ComponentLocalBuildInfo)] testSuiteConfigs :: [(String, ComponentLocalBuildInfo)] - - -- ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -- -> FilePath -> [String] - -- ghcOptions lbi bi clbi odir - -fileCppOptions :: CabalBuildInfo -> [String] -fileCppOptions (bi,_,_,_,_)=cppOptions bi +-- | get CPP options for a file +fileCppOptions :: CabalBuildInfo -- ^ the cabal info + -> [String] -- ^ the list of CPP options +fileCppOptions cbi=cppOptions $ cbiBuildInfo cbi -cabalExtensions :: CabalBuildInfo -> (ModuleName,[String]) -cabalExtensions (bi,_,_,_,ls)=(fst $ head ls,map show $ ((otherExtensions bi) ++ (defaultExtensions bi) ++ (oldExtensions bi))) +-- | get the cabal extensions +cabalExtensions :: CabalBuildInfo -- ^ the cabal info + -> (ModuleName,[String]) -- ^ the module name and cabal extensions +cabalExtensions CabalBuildInfo{cbiBuildInfo=bi,cbiModulePaths=ls}=(fst $ head ls,map show (otherExtensions bi ++ defaultExtensions bi ++ oldExtensions bi)) -getSourceDirs :: BuildInfo -> [FilePath] +-- | get the source directory from a build info +getSourceDirs :: BuildInfo -- ^ the build info + -> [FilePath] -- ^ the source paths, guaranteed non null getSourceDirs bi=let hsd=hsSourceDirs bi in case hsd of [] -> ["."] _ -> hsd -getAllFiles :: LocalBuildInfo -> BuildWrapper [CabalBuildInfo] +-- | get all components, referencing all the files found in the source folders +getAllFiles :: LocalBuildInfo -- ^ the build info + -> BuildWrapper [CabalBuildInfo] getAllFiles lbi= do let pd=localPkgDescr lbi let libs=maybe [] extractFromLib $ library pd @@ -437,12 +406,13 @@ let tests=map extractFromTest $ testSuites pd mapM (\(a,b,c,isLib,d)->do mf<-copyAll d - return (a,b,c,isLib,mf)) (libs ++ exes ++ tests) + liftIO $ print $ map snd mf + return (CabalBuildInfo a b c isLib mf)) (libs ++ exes ++ tests) where extractFromLib :: Library -> [(BuildInfo,ComponentLocalBuildInfo,FilePath,Bool,[FilePath])] extractFromLib l=let lib=libBuildInfo l - in [(lib,fromJustDebug "extractFromLibAll" $ libraryConfig lbi,buildDir lbi,True,(getSourceDirs lib))] + in [(lib, fromJustDebug "extractFromLibAll" $ libraryConfig lbi,buildDir lbi, True, getSourceDirs lib)] extractFromExe :: Executable -> (BuildInfo,ComponentLocalBuildInfo,FilePath,Bool,[FilePath]) extractFromExe e@Executable{exeName=exeName'}=let ebi=buildInfo e @@ -459,26 +429,21 @@ in (tbi,fromJustDebug "extractFromTestAll" $ lookup testName' $ testSuiteConfigs lbi,testDir,False,hsd) copyAll :: [FilePath] -> BuildWrapper [(ModuleName,FilePath)] copyAll fps= do --- cf<-gets cabalFile --- let dir=(takeDirectory cf) --- ffps<-mapM getFullSrc fps --- allF<-liftIO $ mapM getRecursiveContents ffps --- liftIO $ putStrLn ("allF:" ++ (show allF)) --- return $ map (\f->(fromString $ fileToModule f,f)) $ map (\f->makeRelative dir f) $ concat allF allF<-mapM copyAll' fps return $ concat allF copyAll' :: FilePath -> BuildWrapper [(ModuleName,FilePath)] copyAll' fp=do cf<-gets cabalFile - let dir=(takeDirectory cf) + let dir=takeDirectory cf fullFP<-getFullSrc fp allF<-liftIO $ getRecursiveContents fullFP tf<-gets tempFolder -- exclude every file containing the temp folder name (".buildwrapper" by default) -- which may happen if . is a source path - let notMyself=filter (\f->(not $ isInfixOf tf f)) allF + let notMyself=filter (not . isInfixOf tf) allF return $ map (\f->(fromString $ fileToModule $ makeRelative fullFP f,makeRelative dir f)) notMyself - + +-- | get all components, referencing only the files explicitely indicated in the cabal file getReferencedFiles :: LocalBuildInfo -> BuildWrapper [CabalBuildInfo] getReferencedFiles lbi= do let pd=localPkgDescr lbi @@ -490,8 +455,9 @@ extractFromLib :: Library -> [CabalBuildInfo] extractFromLib l=let lib=libBuildInfo l - modules=(PD.exposedModules l) ++ (otherModules lib) - in [(lib,fromJustDebug "extractFromLibRef" $ libraryConfig lbi,buildDir lbi,True,(copyModules modules (getSourceDirs lib)))] + modules=PD.exposedModules l ++ otherModules lib + in [CabalBuildInfo lib (fromJustDebug "extractFromLibRef" $ libraryConfig lbi) + (buildDir lbi) True (copyModules modules (getSourceDirs lib))] extractFromExe :: Executable ->CabalBuildInfo extractFromExe e@Executable{exeName=exeName'}=let ebi=buildInfo e @@ -499,7 +465,7 @@ exeDir = targetDir </> (exeName' ++ "-tmp") modules= (otherModules ebi) hsd=getSourceDirs ebi - in (ebi,fromJustDebug "extractFromExeRef" $ lookup exeName' $ executableConfigs lbi,exeDir,False, copyMain (modulePath e) hsd++ (copyModules modules hsd) ) + in CabalBuildInfo ebi (fromJustDebug "extractFromExeRef" $ lookup exeName' $ executableConfigs lbi) exeDir False (copyMain (modulePath e) hsd ++ copyModules modules hsd ) extractFromTest :: TestSuite -> CabalBuildInfo extractFromTest t@TestSuite {testName=testName'} =let tbi=testBuildInfo t @@ -508,44 +474,53 @@ modules= (otherModules tbi ) hsd=getSourceDirs tbi extras=case testInterface t of - (TestSuiteExeV10 _ mp)->(copyMain mp hsd) - (TestSuiteLibV09 _ mn)->copyModules [mn] hsd - _->[] - in (tbi,fromJustDebug ("extractFromTestRef:"++testName'++(show $ testSuiteConfigs lbi)) $ lookup testName' $ testSuiteConfigs lbi,testDir,False,extras++ (copyModules modules hsd) ) + (TestSuiteExeV10 _ mp) -> copyMain mp hsd + (TestSuiteLibV09 _ mn) -> copyModules [mn] hsd + _ -> [] + in CabalBuildInfo tbi (fromJustDebug ("extractFromTestRef:"++testName' ++ show (testSuiteConfigs lbi)) $ lookup testName' $ testSuiteConfigs lbi) testDir False (extras ++ copyModules modules hsd) copyModules :: [ModuleName] -> [FilePath] -> [(ModuleName,FilePath)] - copyModules mods=copyFiles (concatMap (\m->[(toFilePath m) <.> "hs",((toFilePath m) <.> "lhs")]) mods) + copyModules mods=copyFiles (concatMap (\m->[toFilePath m <.> "hs", toFilePath m <.> "lhs"]) mods) copyFiles :: [FilePath] -> [FilePath] -> [(ModuleName,FilePath)] copyFiles mods dirs=[(fromString $ fileToModule m,d </> m) | m<-mods, d<-dirs] copyMain :: FilePath ->[FilePath] -> [(ModuleName,FilePath)] - copyMain fs dirs=map (\d->(fromString "Main",d </> fs)) dirs + copyMain fs = map (\ d -> (fromString "Main", d </> fs)) +-- | convert a ModuleName to a String moduleToString :: ModuleName -> String -moduleToString = concat . intersperse ['.'] . components +moduleToString = intercalate "." . components +-- | get all components in the Cabal file cabalComponents :: BuildWrapper (OpResult [CabalComponent]) cabalComponents = do (rs,ns)<-withCabal Source (return . cabalComponentsFromDescription . localPkgDescr) return (fromMaybe [] rs,ns) -cabalDependencies :: BuildWrapper (OpResult [(FilePath,[CabalPackage])]) +-- | get all the dependencies in the cabal file +cabalDependencies :: BuildWrapper (OpResult [(FilePath,[CabalPackage])]) -- ^ the result is an array of tuples: the path to the package database, the list of packages in that db that the Cabal file references cabalDependencies = do - (rs,ns)<-withCabal Source (\lbi-> do - liftIO $ ghandle (\(e :: IOError) -> do - putStrLn $ show e - return []) $ do - pkgs<-liftIO $ getPkgInfos - return $ dependencies (localPkgDescr lbi) pkgs + (rs,ns)<-withCabal Source (\lbi-> liftIO $ + ghandle + (\ (e :: IOError) -> + do print e + return []) + $ + do pkgs <- liftIO getPkgInfos + return $ dependencies (localPkgDescr lbi) pkgs ) return (fromMaybe [] rs,ns) - -dependencies :: PD.PackageDescription -> [(FilePath,[InstalledPackageInfo])] -> [(FilePath,[CabalPackage])] +-- | get all dependencies from the package description and the list of installed packages +dependencies :: PD.PackageDescription -- ^ the cabal description + -> [(FilePath,[InstalledPackageInfo])] -- ^ the installed packages, by package database location + -> [(FilePath,[CabalPackage])] -- ^ the referenced packages, by package database location dependencies pd pkgs=let pkgsMap=foldr buildPkgMap DM.empty pkgs -- build the map of package by name with ordered version (more recent first) allC= cabalComponentsFromDescription pd gdeps=PD.buildDepends pd cpkgs=concat $ DM.elems $ DM.map (\ipis->getDep allC ipis gdeps []) pkgsMap - in DM.assocs $ DM.fromListWith (++) $ ((map (\(a,b)->(a,[b])) cpkgs) ++ (map (\(a,_)->(a,[])) pkgs)) + in DM.assocs $ DM.fromListWith (++) + (map (\ (a, b) -> (a, [b])) cpkgs ++ + map (\ (a, _) -> (a, [])) pkgs) where buildPkgMap :: (FilePath,[InstalledPackageInfo]) -> DM.Map String [(FilePath,InstalledPackageInfo)] -> DM.Map String [(FilePath,InstalledPackageInfo)] buildPkgMap (fp,ipis) m=foldr (\i dm->let @@ -553,34 +528,27 @@ vals=DM.lookup key dm newvals=case vals of Nothing->[(fp,i)] - Just l->sortBy (flip (compare `on` (pkgVersion . sourcePackageId . snd))) ((fp,i):l) + Just l->sortBy (flip (comparing (pkgVersion . sourcePackageId . snd))) ((fp,i):l) in DM.insert key newvals dm ) m ipis getDep :: [CabalComponent] -> [(FilePath,InstalledPackageInfo)] -> [Dependency]-> [(FilePath,CabalPackage)] -> [(FilePath,CabalPackage)] getDep _ [] _ acc= acc getDep allC ((fp,InstalledPackageInfo{sourcePackageId=i,exposed=e,IPI.exposedModules=ems}):xs) deps acc= let - (ds,deps2)=partition (\(Dependency n v)->((pkgName i)==n) && withinRange (pkgVersion i) v) deps -- find if version is referenced, remove the referencing component so that it doesn't match an older version + (ds,deps2)=partition (\(Dependency n v)->(pkgName i == n) && withinRange (pkgVersion i) v) deps -- find if version is referenced, remove the referencing component so that it doesn't match an older version cps=if null ds then [] else allC mns=map display ems in getDep allC xs deps2 ((fp,CabalPackage (display $ pkgName i) (display $ pkgVersion i) e cps mns): acc) -- build CabalPackage structure - --DM.map (sortBy (flip (compare `on` (pkgVersion . sourcePackageId . snd)))) $ DM.fromListWith (++) (map (\i->((display $ pkgName $ sourcePackageId i),[i]) ) ipis) --concatenates all version and sort them, most recent first - -cabalComponentsFromDescription :: PD.PackageDescription -> [CabalComponent] -cabalComponentsFromDescription pd= - (if isJust (PD.library pd) then [CCLibrary (PD.buildable $ PD.libBuildInfo $ fromJust (PD.library pd))] else []) ++ - [ CCExecutable (PD.exeName e) (PD.buildable $ PD.buildInfo e) - | e <- PD.executables pd ] - ++ [ CCTestSuite (PD.testName e) (PD.buildable $ PD.testBuildInfo e) - | e <- PD.testSuites pd ] - - ---class ToBWNote a where --- toBWNote :: a -> BWNote + +-- | get all components from the package description +cabalComponentsFromDescription :: PD.PackageDescription -- ^ the package description + -> [CabalComponent] +cabalComponentsFromDescription pd= [CCLibrary + (PD.buildable $ PD.libBuildInfo $ fromJust (PD.library pd)) + | isJust (PD.library pd)] ++ + [ CCExecutable (PD.exeName e) (PD.buildable $ PD.buildInfo e) + | e <- PD.executables pd ] + ++ [ CCTestSuite (PD.testName e) (PD.buildable $ PD.testBuildInfo e) + | e <- PD.testSuites pd ] ---peErrorToBWNote :: FilePath -> PError -> BWNote ---peErrorToBWNote cf (AmbigousParse t ln)= BWNote BWError "AmbigousParse" t (BWLocation cf ln 1) ---peErrorToBWNote cf (NoParse t ln) = BWNote BWError "NoParse" t (BWLocation cf ln 1) ---peErrorToBWNote cf (TabsError ln) = BWNote BWError "TabsError" "" (BWLocation cf ln 1) ---peErrorToBWNote cf (FromString t mln) = BWNote BWError "FromString" t (BWLocation cf (fromMaybe 1 mln) 1)
− src/Language/Haskell/BuildWrapper/Find.hs
@@ -1,711 +0,0 @@-{-# LANGUAGE UndecidableInstances, FunctionalDependencies, FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-} -{-# LANGUAGE PatternGuards, FlexibleInstances, CPP #-} --- | --- Module : Language.Haskell.BuildWrapper.Find --- Copyright : (c) Thomas Schilling 2008, JP Moresmau 2011 --- License : BSD-style --- --- Maintainer : jpmoresmau@gmail.com --- Stability : beta --- Portability : portable --- --- Find things in a syntax tree. --- -module Language.Haskell.BuildWrapper.Find - ( findHsThing, SearchResult(..), SearchResults, Search - , PosTree(..), PosForest, deepestLeaf, pathToDeepest, searchBindBag - , surrounds, overlaps, haddockType, prettyResult, qualifiedResult, typeOf, start, end -#ifdef SCION_DEBUG - , prop_invCmpOverlap -#endif - ) -where - -import GHC -import Outputable -import Name hiding (varName) - -import BasicTypes ( IPName(..) ) -import Bag -import Var ( varName,varType ) - -#if __GLASGOW_HASKELL__ < 702 -import TypeRep ( Type(..), PredType(..) ) -#else -import TypeRep ( Type(..), Pred(..) ) -#endif - -import Data.Monoid ( mempty, mappend, mconcat ) -import Data.Foldable as F ( maximumBy ) -import Data.Ord ( comparing ) -import qualified Data.Set as S - ------------------------------------------------------------------------------- - - -isRecStmt :: StmtLR idL idR -> Bool - -#if __GLASGOW_HASKELL__ < 611 - -isRecStmt (RecStmt _ _ _ _ _) = True -isRecStmt _ = False - -#else - -isRecStmt (RecStmt _ _ _ _ _ _ _ _) = True -isRecStmt _ = False - -#endif - --- | Pretty-print a search result. -prettyResult :: OutputableBndr id => SearchResult id -> SDoc -prettyResult (FoundId i) = ppr i -prettyResult (FoundName n) = ppr n -prettyResult (FoundCon _ c) = ppr c -prettyResult (FoundModule m) = ppr m -prettyResult r = ppr r - --- | Pretty-print a search result as qualified name -qualifiedResult :: OutputableBndr id => SearchResult id -> SDoc -qualifiedResult (FoundId i) = qualifiedName $ getName i -qualifiedResult (FoundName n) = qualifiedName n -qualifiedResult (FoundCon _ c) = qualifiedName $ getName c -qualifiedResult (FoundModule m) = ppr m -qualifiedResult r = ppr r - -qualifiedName :: Name -> SDoc -qualifiedName n = maybe empty (\x-> (ppr x) <> dot) (nameModule_maybe n) <> (ppr n) - -typeOf :: (SearchResult Id, [SearchResult Id]) -> Maybe Type -typeOf (FoundId ident, path) = - let -- Unwrap a HsWrapper and its associated type - unwrap WpHole t = t - unwrap (WpCompose w1 w2) t = unwrap w1 (unwrap w2 t) - unwrap (WpCast _) t = t -- XXX: really? - unwrap (WpTyApp t') t = AppTy t t' - unwrap (WpTyLam tv) t = ForAllTy tv t - -- do something else with coercion/dict vars? -#if __GLASGOW_HASKELL__ < 700 - unwrap (WpApp v) t = AppTy t (TyVarTy v) - unwrap (WpLam v) t = ForAllTy v t -#else - -- unwrap (WpEvApp v) t = AppTy t (TyVarTy v) - unwrap (WpEvLam v) t = ForAllTy v t - unwrap (WpEvApp _) t = t -#endif - unwrap (WpLet _) t = t -#ifdef WPINLINE - unwrap WpInline t = t -#endif - in case path of - FoundExpr _ (HsVar _) : FoundExpr _ (HsWrap wr _) : _ -> - Just $ reduce_type $ unwrap wr (varType ident) - _ -> Just (varType ident) - --- All other search results produce no type information -typeOf _ = Nothing - --- | Reduce a top-level type application if possible. That is, we perform the --- following simplification step: --- @ --- (forall v . t) t' ==> t [t'/v] --- @ --- where @[t'/v]@ is the substitution of @t'@ for @v@. --- -reduce_type :: Type -> Type -reduce_type (AppTy (ForAllTy tv b) t) = - reduce_type (subst_type tv t b) -reduce_type t = t - -subst_type :: TyVar -> Type -> Type -> Type -subst_type v t' t0 = go t0 - where - go t = case t of - TyVarTy tv - | tv == v -> t' - | otherwise -> t - AppTy t1 t2 -> AppTy (go t1) (go t2) - TyConApp c ts -> TyConApp c (map go ts) - FunTy t1 t2 -> FunTy (go t1) (go t2) - ForAllTy v' bt - | v == v' -> t - | otherwise -> ForAllTy v' (go bt) - PredTy pt -> PredTy (go_pt pt) - - -- XXX: this is probably not right - go_pt (ClassP c ts) = ClassP c (map go ts) - go_pt (IParam i t) = IParam i (go t) - go_pt (EqPred t1 t2) = EqPred (go t1) (go t2) - -data PosTree a = Node { val :: a, children :: PosForest a } - deriving (Eq, Ord) -type PosForest a = S.Set (PosTree a) - --- | Lookup all the things in a certain region. -findHsThing :: Search id a => (SrcSpan -> Bool) -> a -> SearchResults id -findHsThing p a = search p noSrcSpan a - -deepestLeaf :: Ord a => PosTree a -> a -deepestLeaf t = snd $ go (0::Int) t - where - go n (Node x xs) - | S.null xs = (n,x) - | otherwise = maximumBy (comparing fst) (S.map (go (n+1)) xs) - --- | Returns the deepest leaf, together with the path to this leaf. For --- example, for the following tree with root @A@: --- --- @ --- A -+- B --- C --- '- D --- E --- F --- @ --- --- this function will return: --- --- @ --- (F, [E, D, A]) --- @ --- --- If @F@ were missing the result is either @(C, [B,A])@ or @(E, [D,A])@. --- -pathToDeepest :: Ord a => PosForest a -> Maybe (a, [a]) -pathToDeepest forest - | S.null forest = Nothing - | otherwise = Just $ ptl3 $ go_many (0::Int) [] forest - where - go n path (Node x xs) - | S.null xs = (n, x, path) - | otherwise = go_many (n+1) (x:path) xs - go_many n path xs = - maximumBy (comparing fst3) (S.map (go n path) xs) - fst3 (x,_,_) = x - ptl3 (_,x,y) = (x,y) - -haddockType :: SearchResult a -> String -haddockType (FoundName n) - | isValOcc (nameOccName n)="v" - | otherwise= "t" -haddockType (FoundId i) - | isValOcc (nameOccName (Var.varName i))="v" - | otherwise= "t" -haddockType (FoundModule _)="m" -haddockType _="t" - -data SearchResult id - = FoundBind SrcSpan (HsBind id) - | FoundPat SrcSpan (Pat id) - | FoundType SrcSpan (HsType id) - | FoundExpr SrcSpan (HsExpr id) - | FoundStmt SrcSpan (Stmt id) - | FoundId Id - | FoundName Name - | FoundCon SrcSpan DataCon - | FoundLit SrcSpan HsLit - | FoundModule ModuleName - -resLoc :: SearchResult id -> SrcSpan -resLoc (FoundId i) = nameSrcSpan (varName i) -resLoc (FoundName n) = nameSrcSpan n -resLoc (FoundBind s _) = s -resLoc (FoundPat s _) = s -resLoc (FoundType s _) = s -resLoc (FoundExpr s _) = s -resLoc (FoundStmt s _) = s -resLoc (FoundCon s _) = s -resLoc (FoundLit s _) = s -resLoc (FoundModule _) = noSrcSpan - -instance Eq (SearchResult id) where - a == b = resLoc a == resLoc b -- TODO: sufficient? - -instance Ord (SearchResult id) where - compare a b = compare (resLoc a) (resLoc b) - -type SearchResults id = PosForest (SearchResult id) - --- | Given two good SrcSpans (see 'SrcLoc.isGoodSrcSpan'), returns 'EQ' if the --- spans overlap or, if not, the relative ordering of both. -cmpOverlap :: SrcSpan -> SrcSpan -> Ordering -cmpOverlap sp1 sp2 - | not (isGoodSrcSpan sp1) = LT - | not (isGoodSrcSpan sp2) = GT - | end1 < start2 = LT - | end2 < start1 = GT - | otherwise = EQ - where - -- At this point we assume that both spans are good. We also ignore the - -- file names since faststrings seem to be rather unreliable. - start1 = start sp1 - end1 = end sp1 - start2 = start sp2 - end2 = end sp2 - -start, end :: SrcSpan -> (Int,Int) -#if __GLASGOW_HASKELL__ < 702 -start ss= (srcSpanStartLine ss, srcSpanStartCol ss) -end ss= (srcSpanEndLine ss, srcSpanEndCol ss) -#else -start (RealSrcSpan ss)= (srcSpanStartLine ss, srcSpanStartCol ss) -start (UnhelpfulSpan _)=error "UnhelpfulSpan in cmpOverlap start" -end (RealSrcSpan ss)= (srcSpanEndLine ss, srcSpanEndCol ss) -end (UnhelpfulSpan _)=error "UnhelpfulSpan in cmpOverlap start" -#endif - -surrounds :: SrcSpan -> SrcSpan -> Bool -surrounds outer inner = start1 <= start2 && end2 <= end1 - where - start1 = srcSpanStart outer - end1 = srcSpanEnd outer - start2 = srcSpanStart inner - end2 = srcSpanEnd inner - -overlaps :: SrcSpan -> SrcSpan -> Bool -overlaps sp1 sp2 = cmpOverlap sp1 sp2 == EQ - - -#ifdef SCION_DEBUG - -prop_invCmpOverlap :: SrcSpan -> SrcSpan -> Bool -prop_invCmpOverlap s1 s2 = - case cmpOverlap s1 s2 of - LT -> cmpOverlap s2 s1 == GT - EQ -> cmpOverlap s2 s1 == EQ - GT -> cmpOverlap s2 s1 == LT - --- prop_sane : if overlap -> there is some point which is in both spans - -#endif - - ------------------------------------------------------------------------------- - -instance (OutputableBndr id, Outputable id) - => Outputable (SearchResult id) where - ppr (FoundBind s b) = text "bind:" <+> ppr s $$ nest 4 (ppr b) - ppr (FoundPat s b) = text "pat: " <+> ppr s $$ nest 4 (ppr b) - ppr (FoundType s t) = text "type:" <+> ppr s $$ nest 4 (ppr t) - ppr (FoundExpr s e) = text "expr:" <+> ppr s $$ nest 4 (ppr e) - ppr (FoundStmt s t) = text "stmt:" <+> ppr s $$ nest 4 (ppr t) - ppr (FoundId i) = text "id: " <+> ppr i - ppr (FoundName n) = text "name:" <+> ppr n - ppr (FoundCon s c) = text "con: " <+> ppr s $$ nest 4 (ppr c) - ppr (FoundLit s l) = text "lit: " <+> ppr s $$ nest 4 (ppr l) - ppr (FoundModule m) = text "mod: " <+> ppr m - -instance Outputable a => Outputable (PosTree a) where - ppr (Node v cs) = ppr v $$ nest 2 (vcat (map ppr (S.toList cs))) - -class Search id a | a -> id where - search :: (SrcSpan -> Bool) -> SrcSpan -> a -> SearchResults id - -only :: SearchResult id -> SearchResults id -only r = S.singleton (Node r S.empty) - -above :: SearchResult id -> SearchResults id -> SearchResults id -above r rest = S.singleton (Node r rest) - -instance Search id Id where - search _ _ i = only (FoundId i) - -instance Search Name Name where - search _ _ i = only (FoundName i) - -instance Search id DataCon where - search _ s d = only (FoundCon s d) - -instance Search id HsLit where - search _ s l = only (FoundLit s l) - -instance Search id id => Search id (IPName id) where - search p s (IPName i) = search p s i - ---instance Search id id => Search id (Located (HsBindLR id id)) where --- search p s (L _ a@AbsBinds{})= search p s a --- search p _ (L s a) --- | p s = search p s a --- | otherwise = mempty - --- at least in GHC7 if you have a AbsBind with a type signature the SrcSpan of the AbsBind covers only the type signature... -searchBindBag :: Search id id => (SrcSpan -> Bool) -> SrcSpan -> Bag (Located (HsBindLR id id)) -> SearchResults id -searchBindBag p s bs = mconcat $ fmap (searchBinds p s) (bagToList bs) - -searchBinds :: Search id id => (SrcSpan -> Bool) -> SrcSpan -> (Located (HsBindLR id id)) -> SearchResults id -searchBinds p s (L _ a@AbsBinds{})= search p s a -- ignore location of the absbinds -searchBinds p _ (L s a) - | p s = search p s a - | otherwise = mempty - -instance Search id a => Search id (Located a) where - search p _ (L s a) - | p s = search p s a - | otherwise = mempty - -instance Search id a => Search id (Bag a) where - search p s bs = mconcat $ fmap (search p s) (bagToList bs) - -instance Search id a => Search id [a] where - search p s bs = mconcat $ fmap (search p s) bs - -instance Search id a => Search id (Maybe a) where - search _ _ Nothing = mempty - search p s (Just a) = search p s a - -instance (Search id id) => Search id (HsGroup id) where - search p s grp = - search p s (hs_valds grp) - -- TODO - -instance (Search id id) => Search id (HsBindLR id id) where - search p s b = FoundBind s b `above` search_inside - where - search_inside = - case b of - FunBind { fun_id = i, fun_matches = ms } -> - search p s i `mappend` search p s ms - AbsBinds { abs_binds = bs } -> searchBindBag p s bs - PatBind { pat_lhs = lhs, pat_rhs = rhs } -> - search p s lhs `mappend` search p s rhs - VarBind { var_rhs = rhs } -> search p s rhs - - -instance (Search id id) => Search id (MatchGroup id) where - search p s (MatchGroup ms _) = search p s ms - -instance (Search id id) => Search id (Match id) where - search p s (Match pats tysig rhss) = - search p s pats `mappend` search p s tysig `mappend` search p s rhss - -instance (Search id id) => Search id (Pat id) where - search p s pat0 = FoundPat s pat0 `above` search_inside - where - search_inside = - case pat0 of - VarPat i -> search p s i -#if __GLASGOW_HASKELL__ < 702 - VarPatOut i _ -> search p s i - TypePat t -> search p s t -#endif - LitPat pat -> search p s pat - LazyPat pat -> search p s pat - AsPat i pat -> search p s i `mappend` search p s pat - ParPat pat -> search p s pat - BangPat pat -> search p s pat - ListPat ps _ -> search p s ps - TuplePat ps _ _ -> search p s ps - PArrPat ps _ -> search p s ps - ConPatIn i d -> search p s i `mappend` search p s d - ConPatOut c _ _ _ d _ -> search p s c `mappend` search p s d - ViewPat e pt _ -> search p s e `mappend` search p s pt - SigPatIn pt t -> search p s pt `mappend` search p s t - SigPatOut pt _ -> search p s pt - NPlusKPat n _ _ _ -> search p s n - QuasiQuotePat qq -> search p s qq - CoPat _ pt _ -> search p s pt - _ -> mempty - --- type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id)) -instance (Search id arg, Search id rec) => Search id (HsConDetails arg rec) where - search p s (PrefixCon args) = search p s args - search p s (RecCon rec) = search p s rec - search p s (InfixCon a1 a2) = search p s a1 `mappend` search p s a2 - ---instance (Search id id) => Search id (HsModule id) where --- search p s m =search p s (hsmodDecls m) - -instance Search Name (RenamedSource) where - search p s (b,d,_,_) = search p s d `mappend` search p s b - -instance (Search id id) => Search id (ImportDecl id) where - search p s id=search p s (ideclName id) - -instance Search id ModuleName where - search _ _ mn = only (FoundModule mn) - -instance (Search id id) => Search id (HsType id) where - search _ s t = only (FoundType s t) - -instance (Search id id) => Search id (GRHSs id) where - search p s (GRHSs rhss local_binds) = - search p s rhss `mappend` search p s local_binds - -instance (Search id id) => Search id (GRHS id) where - search p s (GRHS _guards rhs) = - -- guards look like statements, but we should probably treat them - -- differently - search p s _guards `mappend` search p s rhs - -instance (Search id id) => Search id (HsExpr id) where - search p s e0 = FoundExpr s e0 `above` search_inside - where - search_inside = - case e0 of - HsVar i -> search p s i - HsIPVar i -> search p s i - HsLit l -> search p s l - ExprWithTySigOut e _t -> search p s e --`mappend` search p s t - HsBracketOut _b _ -> mempty -- search p s b - HsLam mg -> search p s mg - HsApp l r -> search p s l `mappend` search p s r - OpApp l o _ r -> search p s l `mappend` search p s o - `mappend` search p s r - NegApp e n -> search p s e `mappend` search p s n - HsPar e -> search p s e - SectionL e o -> search p s e `mappend` search p s o - SectionR o e -> search p s o `mappend` search p s e - HsCase e mg -> search p s e `mappend` search p s mg -#if __GLASGOW_HASKELL__ < 700 - HsIf c t e -> search p s c `mappend` search p s t - `mappend` search p s e -#else - HsIf _ c t e -> search p s c `mappend` search p s t - `mappend` search p s e -#endif - HsLet bs e -> search p s bs `mappend` search p s e -#if __GLASGOW_HASKELL__ < 702 - HsDo _ ss e _ -> search p s ss `mappend` search p s e -#else - HsDo _ ss _ -> search p s ss -#endif - ExplicitList _ es -> search p s es - ExplicitPArr _ es -> search p s es - ExplicitTuple es _ -> search p s es - RecordCon _ _ bs -> search p s bs - RecordUpd es bs _ _ _ -> search p s es `mappend` search p s bs - ExprWithTySig e t -> search p s e `mappend` search p s t - --ExprWithTySigOut e t -> mempty - ArithSeq _ i -> search p s i - PArrSeq _ i -> search p s i - HsSCC _ e -> search p s e - HsCoreAnn _ e -> search p s e - HsBracket b -> search p s b - --HsBracketOut b _ -> search p s b -- - HsSpliceE sp -> search p s sp - HsQuasiQuoteE _ -> mempty - HsProc pat ct -> search p s pat `mappend` search p s ct - HsArrApp f arg _ _ _ -> search p s f `mappend` search p s arg - HsArrForm e _ cmds -> search p s e `mappend` search p s cmds - HsTick _ _ e -> search p s e - HsBinTick _ _ e -> search p s e - HsTickPragma _ e -> search p s e - HsWrap _ e -> search p s e - _ -> mempty - -#if __GLASGOW_HASKELL__ > 610 -instance (Search id id) => Search id (HsTupArg id) where - search p s (Present e) = search p s e - search _ _ _ = mempty -#endif - -instance (Search id id) => Search id (HsLocalBindsLR id id) where - search p s (HsValBinds val_binds) = search p s val_binds - search _ _ _ = mempty - -instance (Search id id) => Search id (HsValBindsLR id id) where - search p s (ValBindsOut rec_binds _) = - mconcat $ fmap (searchBindBag p s . snd) rec_binds - search _ _ _ = mempty - -instance (Search id id) => Search id (HsCmdTop id) where - search p s (HsCmdTop c _ _ _) = search p s c - -instance (Search id id) => Search id (StmtLR id id) where - search p s st - | isRecStmt st = search_inside -- see Note [SearchRecStmt] - | otherwise = FoundStmt s st `above` search_inside - where - search_inside = - case st of - BindStmt pat e _ _ -> search p s pat `mappend` search p s e -#if __GLASGOW_HASKELL__ < 702 - ExprStmt e _ _ -> search p s e - ParStmt ss -> search p s (concatMap fst ss) -#else - ExprStmt e _ _ _ -> search p s e - ParStmt ss _ _ _ -> search p s (concatMap fst ss) -#endif - LetStmt bs -> search p s bs - -#if __GLASGOW_HASKELL__ < 700 - TransformStmt (ss,_) f e -> search p s ss `mappend` search p s f - `mappend` search p s e - GroupStmt (ss, _) g -> search p s ss `mappend` search p s g -#elif __GLASGOW_HASKELL__ < 702 - TransformStmt ss _ f e -> search p s ss `mappend` search p s f - `mappend` search p s e - GroupStmt ss _ g gg -> search p s ss `mappend` search p s g - `mappend` either (search p s) (const mempty) gg -#else - LastStmt e _ -> search p s e - TransStmt _ ss _ f e _ _ _-> search p s ss `mappend` search p s f - `mappend` search p s e -#endif - RecStmt{recS_stmts=sts} -> search p s sts - --- --- Note [SearchRecStmt] --- -------------------- --- --- We only return children of a RecStmt but not the RecStmt itself, even --- though a RecStmt may occur in the source code (under very rare --- circumstances). The reasons are: --- --- * We have no way of knowing whether the RecStmt actually occured in the --- source code. We could add a flag in GHC, but its probably not --- worthwhile due to the other reason. --- --- * GHC may move things out of the recursive group if it detects that these --- things are in fact not recursive at all. Source locations are --- preserved, so this is fine. --- - -#if __GLASGOW_HASKELL__ < 700 -instance (Search id id) => Search id (GroupByClause id) where - search p s (GroupByNothing f) = search p s f - search p s (GroupBySomething using_f e) = - either (search p s) (const mempty) using_f `mappend` search p s e -#endif - -instance (Search id id) => Search id (ArithSeqInfo id) where - search p s (From e) = search p s e - search p s (FromThen e1 e2) = search p s e1 `mappend` search p s e2 - search p s (FromTo e1 e2) = search p s e1 `mappend` search p s e2 - search p s (FromThenTo e1 e2 e3) = - search p s e1 `mappend` search p s e2 `mappend` search p s e3 - --- type HsRecordBinds id = HsRecFields id (LHsExpr id) -instance Search id e => Search id (HsRecFields id e) where - search p s (HsRecFields flds _) = search p s flds - -instance Search id e => Search id (HsRecField id e) where - search p s (HsRecField _lid a _) = search p s a - -instance (Search id id) => Search id (HsBracket id) where - search p s (ExpBr e) = search p s e - search p s (PatBr q) = search p s q -#if __GLASGOW_HASKELL__ < 700 - search p s (DecBr g) = search p s g -#else - search p s (DecBrL g) = search p s g - search p s (DecBrG g) = search p s g -#endif - search p s (TypBr t) = search p s t - search _ _ (VarBr _) = mempty - -instance (Search id id) => Search id (HsSplice id) where - search p s (HsSplice _ e) = search p s e - -#if __GLASGOW_HASKELL__ >= 700 -instance (Search id id) => Search id ([id], [id]) where - search p s (a, b) = search p s a `mappend` search p s b - -instance (Search id id) => Search id (HsDecl id) where - search p s (TyClD e) = search p s e - search p s (InstD e) = search p s e - search p s (DerivD e) = search p s e - search p s (ValD e) = search p s e - search p s (SigD e) = search p s e - search p s (DefD e) = search p s e - search p s (ForD e) = search p s e - search p s (WarningD e) = search p s e - search p s (AnnD e) = search p s e - search p s (RuleD e) = search p s e - search p s (SpliceD e) = search p s e - search p s (DocD e) = search p s e - search p s (QuasiQuoteD e) = search p s e - -instance (Search id id) => Search id (TyClDecl id) where - search p s (ForeignType n _) = search p s n - search p s (TyFamily _ n ns _) = search p s n `mappend` search p s ns - search p s (TyData _ ct n v pt _ c d) = search p s ct `mappend` search p s n - `mappend` search p s v - `mappend` search p s pt - `mappend` search p s c - `mappend` search p s d - search p s (TySynonym n v pt r) = search p s n `mappend` search p s v - `mappend` search p s pt - `mappend` search p s r - search p s (ClassDecl ct n v fd sg m tt dc) = search p s ct `mappend` search p s n - `mappend` search p s v - `mappend` search p s fd - `mappend` search p s sg - `mappend` searchBindBag p s m - `mappend` search p s tt - `mappend` search p s dc - -instance (Search id id) => Search id (InstDecl id) where - search p s (InstDecl t b sg dc) = search p s t `mappend` searchBindBag p s b - `mappend` search p s sg - `mappend` search p s dc - -instance (Search id id) => Search id (DerivDecl id) where - search p s (DerivDecl t) = search p s t - -instance (Search id id) => Search id (Sig id) where - search p s (TypeSig n t) = search p s n `mappend` search p s t - search p s (IdSig i) = search p s i - search p s (FixSig n) = search p s n - search p s (InlineSig n _) = search p s n - search p s (SpecSig n t _) = search p s n `mappend` search p s t - search p s (SpecInstSig t) = search p s t - -instance (Search id id) => Search id (FixitySig id) where - search p s (FixitySig n _) = search p s n - -instance (Search id id) => Search id (DefaultDecl id) where - search p s (DefaultDecl n) = search p s n - -instance (Search id id) => Search id (ForeignDecl id) where - search p s (ForeignImport n t _) = search p s n `mappend` search p s t - search p s (ForeignExport n t _) = search p s n `mappend` search p s t - -instance (Search id id) => Search id (WarnDecl id) where - search p s (Warning n _) = search p s n - -instance (Search id id) => Search id (AnnDecl id) where - search p s (HsAnnotation pr n) = search p s pr `mappend` search p s n - -instance (Search id id) => Search id (AnnProvenance id) where - search p s (ValueAnnProvenance n) = search p s n - search p s (TypeAnnProvenance n) = search p s n - search _ _ (ModuleAnnProvenance) = mempty - -instance (Search id id) => Search id (RuleDecl id) where - search p s (HsRule _ _ bn e1 _ e2 _) = search p s bn `mappend` search p s e1 - `mappend` search p s e2 - -instance (Search id id) => Search id (RuleBndr id) where - search p s (RuleBndr n) = search p s n - search p s (RuleBndrSig n t) = search p s n `mappend` search p s t - -instance (Search id id) => Search id (SpliceDecl id) where - search p s (SpliceDecl n _) = search p s n - -instance (Search id id) => Search id DocDecl where - search _ _ _ = mempty - -instance (Search id id) => Search id (HsQuasiQuote id) where - search _ _ _ = mempty - -instance (Search id id) => Search id (ConDecl id) where - search p s (ConDecl n _ qv ct dt res _ _) = search p s n `mappend` search p s qv - `mappend` search p s ct - `mappend` search p s dt - `mappend` search p s res - -instance (Search id id) => Search id (ConDeclField id) where - search p s (ConDeclField n t _) = search p s n `mappend` search p s t - -instance (Search id id) => Search id (HsPred id) where - search p s (HsClassP n t) = search p s n `mappend` search p s t - search p s (HsEqualP n1 n2) = search p s n1 `mappend` search p s n2 - search p s (HsIParam i n) = search p s i `mappend` search p s n - -instance (Search id id) => Search id (HsTyVarBndr id) where - search p s (UserTyVar n _) = search p s n - search p s (KindedTyVar n _) = search p s n - -instance (Search id id) => Search id (ResType id) where - search _ _ (ResTyH98) = mempty - search p s (ResTyGADT n) = search p s n -#endif
src/Language/Haskell/BuildWrapper/GHC.hs view
@@ -10,15 +10,11 @@ -- Stability : beta -- Portability : portable -- --- Load relevant module in the GHC AST and get GHC messages and thing at point info. +-- Load relevant module in the GHC AST and get GHC messages and thing at point info. Also use the GHC lexer for syntax highlighting. module Language.Haskell.BuildWrapper.GHC where import Language.Haskell.BuildWrapper.Base hiding (Target) -import Language.Haskell.BuildWrapper.Find import Language.Haskell.BuildWrapper.GHCStorage --- import Text.JSON --- import Data.DeriveTH --- import Data.Derive.JSON import Data.Char import Data.Generics hiding (Fixity, typeOf) import Data.Maybe @@ -33,52 +29,73 @@ import DynFlags import ErrUtils ( ErrMsg(..), WarnMsg, mkPlainErrMsg,Messages,ErrorMessages,WarningMessages, Message ) import GHC -import SrcLoc import GHC.Paths ( libdir ) import HscTypes ( srcErrorMessages, SourceError) import Outputable import FastString (FastString,unpackFS,concatFS,fsLit,mkFastString) -import Lexer -import PprTyThing ( pprTypeForUser ) +import Lexer hiding (loc) import Bag +#if __GLASGOW_HASKELL__ >= 702 +import SrcLoc +#endif + #if __GLASGOW_HASKELL__ >= 610 import StringBuffer #endif import System.FilePath ---import System.Time import qualified MonadUtils as GMU -import qualified Data.ByteString.Lazy as BS - -getAST :: FilePath -> FilePath -> String -> [String] -> IO (OpResult (Maybe TypecheckedSource)) -getAST =withASTNotes (\t -> do - return $ tm_typechecked_source t +-- | get the GHC typechecked AST +getAST :: FilePath -- ^ the source file + -> FilePath -- ^ the base directory + -> String -- ^ the module name + -> [String] -- ^ the GHC options + -> IO (OpResult (Maybe TypecheckedSource)) +getAST =withASTNotes (return . tm_typechecked_source ) -withAST :: (TypecheckedModule -> Ghc a) -> FilePath -> FilePath -> String -> [String] -> IO (Maybe a) -withAST f fp base_dir mod options= do - (a,_)<-withASTNotes f fp base_dir mod options +-- | perform an action on the GHC Typechecked module +withAST :: (TypecheckedModule -> Ghc a) -- ^ the action + -> FilePath -- ^ the source file + -> FilePath -- ^ the base directory + -> String -- ^ the module name + -> [String] -- ^ the GHC options + -> IO (Maybe a) +withAST f fp base_dir modul options= do + (a,_)<-withASTNotes f fp base_dir modul options return a -withJSONAST :: (Value -> IO a) -> FilePath -> FilePath -> String -> [String] -> IO (Maybe a) -withJSONAST f fp base_dir mod options=do +-- | perform an action on the GHC JSON AST +withJSONAST :: (Value -> IO a) -- ^ the action + -> FilePath -- ^ the source file + -> FilePath -- ^ the base directory + -> String -- ^ the module name + -> [String] -- ^ the GHC options + -> IO (Maybe a) +withJSONAST f fp base_dir modul options=do mv<-readGHCInfo fp case mv of - Just v-> f v >>= return . Just + Just v-> fmap Just (f v) Nothing->do - (mTc,ns)<-getAST fp base_dir mod options + (mTc,_)<-getAST fp base_dir modul options case mTc of - Just tc->f (dataToJSON tc) >>= return . Just + Just tc->fmap Just (f (dataToJSON tc)) Nothing -> return Nothing -withASTNotes :: (TypecheckedModule -> Ghc a) -> FilePath -> FilePath -> String -> [String] -> IO (OpResult (Maybe a)) -withASTNotes f fp base_dir mod options=do +-- | the main method loading the source contents into GHC +withASTNotes :: (TypecheckedModule -> Ghc a) -- ^ the final action to perform on the result + -> FilePath -- ^ the source file + -> FilePath -- ^ the base directory + -> String -- ^ the module name + -> [String] -- ^ the GHC options + -> IO (OpResult (Maybe a)) +withASTNotes f fp base_dir modul options=do let lflags=map noLoc options - -- putStrLn $ show options + --print options (_leftovers, _) <- parseStaticFlags lflags runGhc (Just libdir) $ do flg <- getSessionDynFlags @@ -94,7 +111,7 @@ -- $ dopt_set (flg' { ghcLink = NoLink , ghcMode = CompManager }) Opt_ForceRecomp addTarget Target { targetId = TargetFile fp Nothing, targetAllowObjCode = True, targetContents = Nothing } --c1<-GMU.liftIO getClockTime - let modName=mkModuleName mod + let modName=mkModuleName modul -- loadWithLogger (logWarnErr ref) res<- load (LoadUpTo modName) -- LoadAllTargets `gcatch` (\(e :: SourceError) -> handle_error ref e) @@ -105,25 +122,29 @@ --GMU.liftIO $ putStrLn ("load all targets: " ++ (timeDiffToString $ diffClockTimes c2 c1)) case res of Succeeded -> do - modSum <- getModSummary $ modName + modSum <- getModSummary modName p <- parseModule modSum --return $ showSDocDump $ ppr $ pm_mod_summary p t <- typecheckModule p d <- desugarModule t -- to get warnings l <- loadModule d --c3<-GMU.liftIO getClockTime +#if __GLASGOW_HASKELL__ < 704 setContext [ms_mod modSum] [] +#else + setContext [IIModule $ ms_mod modSum] +#endif GMU.liftIO $ storeGHCInfo fp (typecheckedSource $ dm_typechecked_module l) --GMU.liftIO $ putStrLn ("parse, typecheck load: " ++ (timeDiffToString $ diffClockTimes c3 c2)) a<-f (dm_typechecked_module l) #if __GLASGOW_HASKELL__ < 702 warns <- getWarnings - return $ (Just a,List.nub $ notes++ (reverse $ ghcMessagesToNotes base_dir (warns, emptyBag))) + return (Just a,List.nub $ notes ++ reverse (ghcMessagesToNotes base_dir (warns, emptyBag))) #else notes2 <- GMU.liftIO $ readIORef ref - return $ (Just a,notes2) + return $ (Just a,List.nub $ notes2) #endif - Failed -> return $ (Nothing,notes) + Failed -> return (Nothing, notes) where -- logWarnErr :: GhcMonad m => IORef [BWNote] -> Maybe SourceError -> m () -- logWarnErr ref err = do @@ -138,7 +159,7 @@ add_warn_err ref warns errs = do let notes = ghcMessagesToNotes base_dir (warns, errs) GMU.liftIO $ modifyIORef ref $ - \ns -> ( ns ++ notes) + \ ns -> ns ++ notes handle_error :: GhcMonad m => IORef [BWNote] -> SourceError -> m SuccessFlag handle_error ref e = do @@ -150,15 +171,14 @@ return Failed logAction :: IORef [BWNote] -> Severity -> SrcSpan -> PprStyle -> Message -> IO () - logAction ref s loc ppr msg + logAction ref s loc style msg | (Just status)<-bwSeverity s=do let n=BWNote { bwn_location = ghcSpanToBWLocation base_dir loc , bwn_status = status - , bwn_title = removeBaseDir base_dir $ removeStatus status $ showSDocForUser (qualName ppr,qualModule ppr) msg + , bwn_title = removeBaseDir base_dir $ removeStatus status $ showSDocForUser (qualName style,qualModule style) msg } - modifyIORef ref $ \ns -> ( ns ++ [n]) - | otherwise=do - return () + modifyIORef ref $ \ ns -> ns ++ [n] + | otherwise=return () bwSeverity :: Severity -> Maybe BWNoteStatus bwSeverity SevWarning = Just BWWarning @@ -166,209 +186,72 @@ bwSeverity SevFatal = Just BWError bwSeverity _ = Nothing - --f $ tm_typechecked_source t - --return $ showSDocDump $ ppr $ pm_parsed_source p - --return $ showSDocDump $ ppr $ tm_typechecked_source t - --return $ makeObj [("parse" , (showJSON $ tm_typechecked_source t))] - --return r -- | Convert 'GHC.Messages' to '[BWNote]'. -- -- This will mix warnings and errors, but you can split them back up -- by filtering the '[BWNote]' based on the 'bw_status'. -ghcMessagesToNotes :: FilePath -> Messages -> [BWNote] -ghcMessagesToNotes base_dir (warns, errs) = - (map_bag2ms (ghcWarnMsgToNote base_dir) warns) ++ - (map_bag2ms (ghcErrMsgToNote base_dir) errs) +ghcMessagesToNotes :: FilePath -- ^ base directory + -> Messages -- ^ GHC messages + -> [BWNote] +ghcMessagesToNotes base_dir (warns, errs) = map_bag2ms (ghcWarnMsgToNote base_dir) warns +++ map_bag2ms (ghcErrMsgToNote base_dir) errs where map_bag2ms f = map f . Bag.bagToList -getGhcNamesInScope :: FilePath -> FilePath -> String -> [String] -> IO [String] -getGhcNamesInScope f base_dir mod options=do +-- | get all names in scope +getGhcNamesInScope :: FilePath -- ^ source path + -> FilePath -- ^ base directory + -> String -- ^ module name + -> [String] -- ^ build options + -> IO [String] +getGhcNamesInScope f base_dir modul options=do names<-withAST (\_->do --c1<-GMU.liftIO getClockTime names<-getNamesInScope --c2<-GMU.liftIO getClockTime --GMU.liftIO $ putStrLn ("getNamesInScope: " ++ (timeDiffToString $ diffClockTimes c2 c1)) - return $ map (showSDocDump . ppr ) names) f base_dir mod options + return $ map (showSDocDump . ppr ) names) f base_dir modul options return $ fromMaybe[] names - - - -getThingAtPoint :: Int -> Int -> Bool -> Bool -> FilePath -> FilePath -> String -> [String] -> IO String -getThingAtPoint line col qual typed fp base_dir mod options= do - t<-withAST (\tcm->do - let loc = srcLocSpan $ mkSrcLoc (fsLit fp) line (scionColToGhcCol col) - uq<-unqualifiedForModule tcm - --liftIO $ debugToJSON (typecheckedSource tcm) - --liftIO $ debugFindInJSON line col (typecheckedSource tcm) - let f=(if typed then (doThingAtPointTyped $ typecheckedSource tcm) else (doThingAtPointUntyped $ renamedSource tcm)) - --tap<- doThingAtPoint loc qual typed tcm (if typed then (typecheckedSource tcm) else (renamedSource tcm)) - let tap=f loc qual tcm uq - --(if typed then (doThingAtPointTyped $ typecheckedSource tcm) - -- else doThingAtPointTyped (renamedSource tcm) loc qual tcm - return tap) fp base_dir mod options - return $ fromMaybe "no info" t - where - doThingAtPointTyped :: TypecheckedSource -> SrcSpan -> Bool -> TypecheckedModule -> PrintUnqualified -> String - doThingAtPointTyped src loc qual tcm uq=let - in_range = overlaps loc - r = searchBindBag in_range noSrcSpan src - unqual = if qual - then alwaysQualify - else uq - --liftIO $ putStrLn $ showData TypeChecker 2 src - in case pathToDeepest r of - Nothing -> "no info" - Just (x,xs) -> - case typeOf (x,xs) of - Just t -> - showSDocForUser unqual - (prettyResult x <+> dcolon <+> - pprTypeForUser True t) - _ -> showSDocForUser unqual (prettyResult x) --(Just (showSDocDebug (ppr x $$ ppr xs ))) - doThingAtPointUntyped :: (Search id a, OutputableBndr id) => a -> SrcSpan -> Bool -> TypecheckedModule -> PrintUnqualified -> String - doThingAtPointUntyped src loc qual tcm uq=let - in_range = overlaps loc - r = findHsThing in_range src - unqual = if qual - then neverQualify - else uq - in case pathToDeepest r of - Nothing -> "no info" - Just (x,_) -> - if qual - then showSDocForUser unqual ((qualifiedResult x) <+> (text $ haddockType x)) - else showSDocForUser unqual ((prettyResult x) <+> (text $ haddockType x)) - -getThingAtPointJSON :: Int -> Int -> Bool -> Bool -> FilePath -> FilePath -> String -> [String] -> IO String -getThingAtPointJSON line col qual typed fp base_dir mod options= do - mr<-withJSONAST (\v->do +-- | get the "thing" at a particular point (line/column) in the source +-- this is using the saved JSON info if available +getThingAtPointJSON :: Int -- ^ line + -> Int -- ^ column +-- -> Bool ^ do we want the result qualified by the module +-- -> Bool ^ do we want the full type or just the haddock type + -> FilePath -- ^ source file path + -> FilePath -- ^ base directory + -> String -- ^ module name + -> [String] -- ^ build flags + -> IO (Maybe ThingAtPoint) +getThingAtPointJSON line col fp base_dir modul options= do + mmf<-withJSONAST (\v->do let f=overlap line (scionColToGhcCol col) let mf=findInJSON f v - BS.putStrLn $ encode (fromJust mf) - return $ findInJSONFormatted qual typed mf - ) fp base_dir mod options - return $ fromMaybe "no info" mr - - -unqualifiedForModule :: TypecheckedMod m => m -> Ghc PrintUnqualified -unqualifiedForModule tcm =fromMaybe alwaysQualify `fmap` mkPrintUnqualifiedForModule (moduleInfo tcm) - ---data S a=S String --- ---instance Show (S a) where --- show (S s)=s --- ---data TestLoc=TestLoc Int Int --- deriving (Show,Data,Typeable) ---data Test=Test [TestLoc] --- deriving (Show,Data,Typeable) --- ---test1=Test [TestLoc 3 4,TestLoc 2 14,TestLoc 3 16] --- ---getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String] ---getThingAtPoint ts line col= everything (++) ([] `mkQ` (\x -> p x )) test1 --- -- synthesize [] toS (mkQ Nothing toS) test1 --- where --- p :: TestLoc -> [String] --- p t@(TestLoc a b)= if a==line || b==col --- then [show t] --- else [] --- + --return $ findInJSONFormatted qual typed mf + return $ findInJSONData mf + ) fp base_dir modul options + return $ fromMaybe Nothing mmf ---getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String] ---getThingAtPoint ts line col= maybeToList $ something (mkQ Nothing toS) test1 --- where --- toS :: TestLoc -> Maybe String --- toS t@(TestLoc a b)=if a==line || b==col --- then Just $ show t --- else Nothing - - ---getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String] ---getThingAtPoint ts line col=map show ((listify (mkQ False (isJust . toS)) test1)::[TestLoc]) --- -- maybeToList $ something (mkQ Nothing toS) test1 --- where --- toS :: TestLoc -> Maybe String --- toS t@(TestLoc a b)=if a==line || b==col --- then Just $ show t --- else Nothing - ---newtype C a = C a deriving (Data,Typeable) --- -----getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String] --- ---coerce :: a -> C a ---coerce = unsafeCoerce ---uncoerce :: C a -> a ---uncoerce = unsafeCoerce --- ---fmapData :: forall t a b. (Typeable a, Data (t (C a)), Data (t a)) => --- (a -> b) -> t a -> t b ---fmapData f input = uc . everything (++) ([] `mkQ` (\(x::C a) -> [coerce (f (uncoerce x))])) --- $ (coerce input) --- where uc = unsafeCoerce --- ---getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String] ---getThingAtPoint ts line col= --map unLoc $ filter (\(L _ o)->not $ null o) $ fmapData overlap (bagToList ts) --- map unLoc $ filter (\(L _ o)->not $ null o) $ everything (++) ([] `mkQ` overlap) (bagToList ts) --- where --- --overlap :: forall b1 . (Outputable b1, Typeable b1) =>Located b1 -> Located String --- overlap :: Located (HsBindLR Id Id) -> [Located String] --- overlap (L loc o)= let --- st=srcSpanStart loc --- en=srcSpanEnd loc --- in if (isGoodSrcLoc st) && (isGoodSrcLoc en) && ((srcLocLine st) <= line) && ((srcLocCol st) <=col) && ((srcLocLine en) >= line) && ((srcLocCol en) >=col) --- then [L loc $ showSDocDump $ ppr o] --- else [] --- --- [showData TypeChecker 4 ts] - - ---getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String] ---getThingAtPoint ts line col= map pr lf --- --maybeToList $ something (mkQ Nothing toS) ts -- listify (mkQ False overlap) ts --- where --- lf :: forall b1 . (Outputable b1, Typeable b1) => [Located b1] --- lf=listify (mkQ False overlap) ts --- --find :: (Outputable a,Typeable a) => TypecheckedSource -> [Located a] --- --find = listify $ overlap --- toS :: forall b1 . (Outputable b1, Typeable b1) =>Located b1 -> Maybe String --- toS l= if overlap l --- then Just $ pr l --- else Nothing --- pr :: forall b1 . (Outputable b1) => Located b1 -> String --- pr=showSDocDump . ppr . unLoc --- --showData TypeChecker 4 --- overlap :: forall b1 . (Outputable b1, Typeable b1) =>Located b1 -> Bool --- overlap (a::Located b1)= let --- (L loc _)=a --- st=srcSpanStart loc --- en=srcSpanEnd loc --- in (isGoodSrcLoc st) && (isGoodSrcLoc en) && ((srcLocLine st) <= line) && ((srcLocCol st) <=col) && ((srcLocLine en) >= line) && ((srcLocCol en) >=col) --- -- overlap _ =False --- --- - -ghcSpanToLocation :: FilePath -- ^ Base directory - -> GHC.SrcSpan + +-- | convert a GHC SrcSpan to a Span, ignoring the actual file info +ghcSpanToLocation ::GHC.SrcSpan -> InFileSpan -ghcSpanToLocation baseDir sp +ghcSpanToLocation sp | GHC.isGoodSrcSpan sp =let (stl,stc)=start sp (enl,enc)=end sp in mkFileSpan stl (ghcColToScionCol stc) - (enl) + enl (ghcColToScionCol enc) | otherwise = mkFileSpan 0 0 0 0 - +-- | convert a GHC SrcSpan to a BWLocation ghcSpanToBWLocation :: FilePath -- ^ Base directory -> GHC.SrcSpan -> BWLocation @@ -385,11 +268,12 @@ | otherwise=c:x:xs f c s=c:s #if __GLASGOW_HASKELL__ < 702 - sfile ss= GHC.srcSpanFile ss + sfile = GHC.srcSpanFile #else sfile (RealSrcSpan ss)= GHC.srcSpanFile ss #endif - + +-- | convert a column info from GHC to our system (1 based) ghcColToScionCol :: Int -> Int #if __GLASGOW_HASKELL__ < 700 ghcColToScionCol c=c+1 -- GHC 6.x starts at 0 for columns @@ -397,6 +281,7 @@ ghcColToScionCol c=c -- GHC 7 starts at 1 for columns #endif +-- | convert a column info from our system (1 based) to GHC scionColToGhcCol :: Int -> Int #if __GLASGOW_HASKELL__ < 700 scionColToGhcCol c=c-1 -- GHC 6.x starts at 0 for columns @@ -428,7 +313,7 @@ #endif let prTS = lexTokenStream sb lexLoc dflags1 case prTS of - POk _ toks -> return $ Right $ (filter ofInterest toks) + POk _ toks -> return $ Right $ filter ofInterest toks PFailed loc msg -> return $ Left $ ghcErrMsgToNote base_dir $ mkPlainErrMsg loc msg #if __GLASGOW_HASKELL__ < 702 @@ -480,25 +365,21 @@ -- | Filter tokens whose span appears legitimate (start line is less than end line, start column is -- less than end column.) ofInterest :: Located Token -> Bool -ofInterest (L span _) = - let (sl,sc) = start span - (el,ec) = end span +ofInterest (L loc _) = + let (sl,sc) = start loc + (el,ec) = end loc in (sl < el) || (sc < ec) ---toInteractive :: Location -> Location ---toInteractive l = --- let (_, sl1, sc1, el1, ec1) = viewLoc l --- in mkLocation interactive sl1 sc1 el1 ec1 -- | Convert a GHC token to an interactive token (abbreviated token type) -tokenToType :: FilePath -> Located Token -> TokenDef -tokenToType base_dir (L sp t) = TokenDef (tokenType t) (ghcSpanToLocation base_dir sp) +tokenToType :: Located Token -> TokenDef +tokenToType (L sp t) = TokenDef (tokenType t) (ghcSpanToLocation sp) -- | Generate the interactive token list used by EclipseFP for syntax highlighting tokenTypesArbitrary :: FilePath -> String -> Bool -> [String] -> IO (Either BWNote [TokenDef]) tokenTypesArbitrary projectRoot contents literate options = generateTokens projectRoot contents literate options convertTokens id where - convertTokens = map (tokenToType projectRoot) + convertTokens = map tokenToType -- | Extract occurrences based on lexing occurrences :: FilePath -- ^ Project root or base directory for absolute path conversion @@ -515,8 +396,8 @@ tokensMatching = filter matchingVal matchingVal :: TokenDef -> Bool matchingVal (TokenDef v _)=query==v - mkTokenDef (L sp t)=TokenDef (tokenValue qualif t) (ghcSpanToLocation projectRoot sp) - in generateTokens projectRoot contents literate options (map mkTokenDef) tokensMatching + mkToken (L sp t)=TokenDef (tokenValue qualif t) (ghcSpanToLocation sp) + in generateTokens projectRoot contents literate options (map mkToken) tokensMatching -- | Parse the current document, generating a TokenDef list, filtered by a function generateTokens :: FilePath -- ^ The project's root directory @@ -532,41 +413,16 @@ >>= (\result -> case result of Right toks -> - let filterResult = filterFunc $ List.sortBy (comparing td_loc) (ppTs ++ (xform toks)) + let filterResult = filterFunc $ List.sortBy (comparing td_loc) (ppTs ++ xform toks) --liftIO $ putStrLn $ show tokenList in return $ Right filterResult Left n -> return $ Left n ) -- | Preprocess some source, returning the literate and Haskell source as tuple. ---preprocessSource :: String -> Bool -> ([TokenDef],String) ---preprocessSource contents literate= --- let --- (ts1,s2)=if literate then ppSF contents ppSLit else ([],contents) --- (ts2,s3)=ppSF s2 ppSCpp --- in (ts1++ts2,s3) --- where --- ppSF contents2 p= let --- linesWithCount=zip (lines contents2) [1..] --- (ts,nc,_)= List.foldl' p (Seq.empty,Seq.empty,False) linesWithCount --- in (F.toList ts, F.concatMap (++ "\n") nc) --- ppSCpp :: (Seq.Seq TokenDef,Seq.Seq String,Bool) -> (String,Int) -> (Seq.Seq TokenDef,Seq.Seq String,Bool) --- ppSCpp (ts2,l2,f) (l,c) --- | f = addPPToken "PP" (l,c) (ts2,l2,'\\' == (last l)) --- | ('#':_)<-l =addPPToken "PP" (l,c) (ts2,l2,'\\' == (last l)) --- | ("{-# " `List.isPrefixOf` l)=addPPToken "D" (l,c) (ts2,l2,False) --- | otherwise =(ts2,l2 Seq.|> l,False) --- ppSLit :: (Seq.Seq TokenDef,Seq.Seq String,Bool) -> (String,Int) -> (Seq.Seq TokenDef,Seq.Seq String,Bool) --- ppSLit (ts2,l2,f) (l,c) --- | "\\begin{code}" `List.isPrefixOf` l=addPPToken "DL" ("\\begin{code}",c) (ts2,l2,True) --- | "\\end{code}" `List.isPrefixOf` l=addPPToken "DL" ("\\end{code}",c) (ts2,l2,False) --- | f = (ts2,l2 Seq.|> l,True) --- | ('>':lCode)<-l=(ts2,l2 Seq.|> (' ':lCode ),f) --- | otherwise =addPPToken "DL" (l,c) (ts2,l2,f) --- addPPToken :: T.Text -> (String,Int) -> (Seq.Seq TokenDef,Seq.Seq String,Bool) -> (Seq.Seq TokenDef,Seq.Seq String,Bool) --- addPPToken name (l,c) (ts2,l2,f) =(ts2 Seq.|> (TokenDef name (mkFileSpan c 1 c ((length l)+1))),l2 Seq.|> "",f) - -preprocessSource :: String -> Bool -> ([TokenDef],String) +preprocessSource :: String -- ^ the source contents + -> Bool -- ^ is the source literate Haskell + -> ([TokenDef],String) -- ^ the preprocessor tokens and the final valid Haskell source preprocessSource contents literate= let (ts1,s2)=if literate then ppSF contents ppSLit else ([],contents) @@ -581,8 +437,8 @@ ppSCpp (ts2,l2,f) (l,c) | (Continue _)<-f = addPPToken "PP" (l,c) (ts2,l2,lineBehavior l f) | ('#':_)<-l =addPPToken "PP" (l,c) (ts2,l2,lineBehavior l f) - | ("{-# " `List.isPrefixOf` l)=addPPToken "D" (l,c) (ts2,"":l2,f) - | (Indent n)<-f=(ts2,l:((replicate n (takeWhile (==' ') l))++l2),Start) + | "{-# " `List.isPrefixOf` l=addPPToken "D" (l,c) (ts2,"":l2,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) ppSLit (ts2,l2,f) (l,c) @@ -592,9 +448,9 @@ | ('>':lCode)<-l=(ts2, (' ':lCode ):l2,f) | otherwise =addPPToken "DL" (l,c) (ts2,"":l2,f) addPPToken :: T.Text -> (String,Int) -> ([TokenDef],[String],PPBehavior) -> ([TokenDef],[String],PPBehavior) - addPPToken name (l,c) (ts2,l2,f) =((TokenDef name (mkFileSpan c 1 c ((length l)+1))):ts2 ,l2,f) + addPPToken name (l,c) (ts2,l2,f) =(TokenDef name (mkFileSpan c 1 c (length l + 1)) : ts2 ,l2,f) lineBehavior l f - | '\\' == (last l) = case f of + | '\\' == last l = case f of Continue n->Continue (n+1) _ -> Continue 1 | otherwise = case f of @@ -605,14 +461,16 @@ data PPBehavior=Continue Int | Indent Int | Start deriving Eq +-- | convert a GHC error message to our note type ghcErrMsgToNote :: FilePath -> ErrMsg -> BWNote ghcErrMsgToNote = ghcMsgToNote BWError +-- | convert a GHC warning message to our note type ghcWarnMsgToNote :: FilePath -> WarnMsg -> BWNote ghcWarnMsgToNote = ghcMsgToNote BWWarning --- Note that we don *not* include the extra info, since that information is --- only useful in the case where we don not show the error location directly +-- Note that we do *not* include the extra info, since that information is +-- only useful in the case where we do not show the error location directly -- in the source. ghcMsgToNote :: BWNoteStatus -> FilePath -> ErrMsg -> BWNote ghcMsgToNote note_kind base_dir msg = @@ -626,12 +484,13 @@ unqual = errMsgContext msg show_msg = showSDocForUser unqual +-- | remove the initial status text from a message removeStatus :: BWNoteStatus -> String -> String removeStatus BWWarning s - | List.isPrefixOf "Warning:" s = List.dropWhile isSpace $ drop 8 s + | "Warning:" `List.isPrefixOf` s = List.dropWhile isSpace $ drop 8 s | otherwise = s removeStatus BWError s - | List.isPrefixOf "Error:" s = List.dropWhile isSpace $ drop 6 s + | "Error:" `List.isPrefixOf` s = List.dropWhile isSpace $ drop 6 s | otherwise = s #if CABAL_VERSION == 106 @@ -639,19 +498,20 @@ deriving instance Data StringBuffer #endif -mkUnqualTokenValue :: FastString +-- | make unqualified token +mkUnqualTokenValue :: FastString -- ^ the name -> T.Text mkUnqualTokenValue = T.pack . unpackFS - -mkQualifiedTokenValue :: FastString - -> FastString +-- | make qualified token: join the qualifier and the name by a dot +mkQualifiedTokenValue :: FastString -- ^ the qualifier + -> FastString -- ^ the name -> T.Text mkQualifiedTokenValue q a = (T.pack . unpackFS . concatFS) [q, dotFS, a] -- | Make a token definition from its source location and Lexer.hs token type. -mkTokenDef :: FilePath -> Located Token -> TokenDef -mkTokenDef base_dir (L sp t) = TokenDef (mkTokenName t) (ghcSpanToLocation base_dir sp) +--mkTokenDef :: Located Token -> TokenDef +--mkTokenDef (L sp t) = TokenDef (mkTokenName t) (ghcSpanToLocation sp) mkTokenName :: Token -> T.Text mkTokenName = T.pack . showConstr . toConstr @@ -807,7 +667,9 @@ tokenType ITcloseQuote="TH" --tokenType ] tokenType (ITidEscape {})="TH" -- $x tokenType ITparenEscape="TH" -- $( +#if __GLASGOW_HASKELL__ < 704 tokenType ITvarQuote="TH" -- ' +#endif tokenType ITtyQuote="TH" -- '' tokenType (ITquasiQuote {})="TH" -- [:...|...|] @@ -847,11 +709,19 @@ tokenType (ITnovect_prag {})="P" #endif + -- 7.4 new token types +#if __GLASGOW_HASKELL__ >= 704 +tokenType ITcapiconv= "EK" +tokenType ITnounpack_prag= "P" +tokenType ITtildehsh= "S" +tokenType ITsimpleQuote="SS" +#endif + dotFS :: FastString dotFS = fsLit "." tokenValue :: Bool -> Token -> T.Text -tokenValue _ t | elem (tokenType t) ["K","EK"] = T.drop 2 $ mkTokenName t +tokenValue _ t | tokenType t `elem` ["K", "EK"] = T.drop 2 $ mkTokenName t tokenValue _ (ITvarid a) = mkUnqualTokenValue a tokenValue _ (ITconid a) = mkUnqualTokenValue a tokenValue _ (ITvarsym a) = mkUnqualTokenValue a @@ -875,231 +745,15 @@ mappend = unionBags mconcat = unionManyBags ---instance JSON SrcLoc --- where showJSON src --- | isGoodSrcLoc src =makeObj [((unpackFS $ srcLocFile src) , (JSArray [showJSON $ srcLocLine src,showJSON $ srcLocCol src])) ] --- | otherwise = JSNull --- ---instance JSON SrcSpan --- where showJSON src --- | isGoodSrcSpan src=makeObj [((unpackFS $ srcSpanFile src) , (JSArray [showJSON $ srcSpanStartLine src,showJSON $ srcSpanStartCol src,showJSON $ srcSpanEndLine src,showJSON $ srcSpanEndCol src])) ] --- | otherwise = JSNull --- ---instance JSON FastString --- where showJSON=JSString . toJSString . unpackFS --- ---instance JSON ModuleName --- where showJSON=JSString . toJSString . moduleNameString --- ---instance JSON OccName --- where showJSON=JSString . toJSString . showSDocDump . ppr --- ---instance JSON Type --- where showJSON =JSString . toJSString . showSDocDump . ppr --- ---instance JSON DataCon --- where showJSON=JSString . toJSString . showSDocDump . ppr --- ---instance JSON Unique --- where showJSON=JSString . toJSString . showSDocDump . ppr --- ---instance JSON Name --- where showJSON=JSString . toJSString . showSDocDump . ppr --- ---instance JSON EvBindsVar --- where showJSON=JSString . toJSString . showSDocDump . ppr --- ---instance JSON PackageId --- where showJSON=JSString . toJSString . showSDocDump . ppr --- ---instance (JSON a)=> JSON (Bag a) --- where showJSON=JSArray . map showJSON . bagToList --- ---instance (JSON a)=> JSON (UniqSet a) --- where showJSON=JSArray . map showJSON . uniqSetToList --- ---instance JSON Rational --- where showJSON=JSRational False --- ---instance JSON Var --- where showJSON v=makeObj [("Name",showJSON $ Var.varName v),("Unique",showJSON $ varUnique v),("Type",showJSON $ varType v)] --- ---instance JSON RdrName --- where --- showJSON (Unqual on) = JSArray [showJSON on] --- showJSON (Qual mn on) = JSArray [showJSON mn,showJSON on] --- ---instance(JSON a)=> JSON (Located a) --- where showJSON (L s o)=case showJSON o of --- JSObject o->let --- ass=fromJSObject o --- in JSObject $ toJSObject (("Loc",(showJSON s)):ass) --- JSNull -> JSNull --- v->makeObj [("Loc",(showJSON s)),("Object" ,v)] --- --- $( derive makeJSON ''HsModule ) --- $( derive makeJSON ''ImportDecl ) --- $( derive makeJSON ''HsDocString ) --- $( derive makeJSON ''HsDecl) --- $( derive makeJSON ''WarningTxt) --- --- --- $( derive makeJSON ''InstDecl ) ----- $( derive makeJSON ''HsBind ) --- $( derive makeJSON ''HsBindLR ) --- $( derive makeJSON ''DefaultDecl ) --- $( derive makeJSON ''WarnDecl ) --- $( derive makeJSON ''RuleDecl ) --- $( derive makeJSON ''DocDecl ) --- $( derive makeJSON ''HsQuasiQuote ) --- $( derive makeJSON ''SpliceDecl ) --- $( derive makeJSON ''AnnDecl ) --- $( derive makeJSON ''ForeignDecl ) --- $( derive makeJSON ''Sig ) --- $( derive makeJSON ''DerivDecl ) --- $( derive makeJSON ''TyClDecl ) --- --- $( derive makeJSON ''NewOrData ) --- $( derive makeJSON ''HsTyVarBndr ) --- $( derive makeJSON ''HsPred ) --- $( derive makeJSON ''HsType ) --- $( derive makeJSON ''ConDecl ) --- $( derive makeJSON ''FamilyFlavour ) --- $( derive makeJSON ''ResType ) --- $( derive makeJSON ''HsConDetails ) --- $( derive makeJSON ''HsExplicitFlag ) --- $( derive makeJSON ''ConDeclField ) --- $( derive makeJSON ''Boxity ) --- $( derive makeJSON ''HsSplice ) --- $( derive makeJSON ''HsBang ) --- $( derive makeJSON ''IPName ) --- $( derive makeJSON ''HsExpr ) --- --- $( derive makeJSON ''HsLit) --- $( derive makeJSON ''MatchGroup) --- $( derive makeJSON ''HsStmtContext) --- $( derive makeJSON ''HsBracket) --- $( derive makeJSON ''Pat) --- $( derive makeJSON ''HsWrapper) --- $( derive makeJSON ''HsCmdTop) --- $( derive makeJSON ''Fixity) --- $( derive makeJSON ''HsArrAppType) --- $( derive makeJSON ''ArithSeqInfo) --- $( derive makeJSON ''HsRecFields ) --- $( derive makeJSON ''HsRecField ) --- $( derive makeJSON ''StmtLR ) --- $( derive makeJSON ''HsLocalBindsLR ) --- $( derive makeJSON ''HsTupArg ) --- $( derive makeJSON ''HsOverLit ) --- $( derive makeJSON ''OverLitVal ) --- $( derive makeJSON ''HsValBindsLR ) --- $( derive makeJSON ''HsIPBinds ) --- $( derive makeJSON ''IPBind ) --- $( derive makeJSON ''FixitySig ) --- $( derive makeJSON ''InlinePragma ) --- $( derive makeJSON ''Match ) --- $( derive makeJSON ''Activation ) --- $( derive makeJSON ''RuleMatchInfo ) --- $( derive makeJSON ''InlineSpec ) --- $( derive makeJSON ''RecFlag ) --- $( derive makeJSON ''GRHSs ) --- $( derive makeJSON ''GRHS ) --- $( derive makeJSON ''FixityDirection ) --- $( derive makeJSON ''EvTerm ) --- $( derive makeJSON ''TcEvBinds ) --- $( derive makeJSON ''ForeignExport ) --- $( derive makeJSON ''ForeignImport ) --- $( derive makeJSON ''HsMatchContext ) --- $( derive makeJSON ''HsGroup ) --- $( derive makeJSON ''CExportSpec ) --- $( derive makeJSON ''CImportSpec ) --- $( derive makeJSON ''CCallConv ) --- $( derive makeJSON ''CCallTarget ) --- $( derive makeJSON ''EvBind ) --- $( derive makeJSON ''Safety ) --- $( derive makeJSON ''AnnProvenance ) --- $( derive makeJSON ''RuleBndr ) --- $( derive makeJSON ''TcSpecPrags ) --- $( derive makeJSON ''TcSpecPrag ) --- ---instance (JSON a)=> JSON (IE a) --- where --- showJSON= showJSON . ieName --- --- {-- --- p <- parseModule modSum --- t <- typecheckModule p --- d <- desugarModule t --- l <- loadModule d --- n <- getNamesInScope --- c <- return $ coreModule d --- --- g <- getModuleGraph --- mapM showModule g --- return $ (parsedSource d,"/n-----/n", typecheckedSource d) --- --} --- ---{-- ---instance ToJSON SrcLoc --- where toJSON src --- | isGoodSrcLoc src =object [(pack $ unpackFS $ srcLocFile src) .= (Array $ fromList [toJSON $ srcLocLine src,toJSON $ srcLocCol src]) ] --- | otherwise = Null --- ---instance ToJSON SrcSpan --- where toJSON src --- | isGoodSrcSpan src=object [(pack $ unpackFS $ srcSpanFile src) .= (Array $ fromList [toJSON $ srcSpanStartLine src,toJSON $ srcSpanStartCol src,toJSON $ srcSpanEndLine src,toJSON $ srcSpanEndCol src]) ] --- | otherwise = Null --- ---instance(ToJSON a)=> ToJSON (Located a) --- where toJSON (L s o)=case toJSON o of --- Object o->Object (M.insert "Loc" (toJSON s) o) --- Null -> Null --- v->object ["Loc" .= (toJSON s),"Object" .= v] --- ---instance (ToJSON a, OutputableBndr a)=> ToJSON (HsModule a) --- where toJSON hsm=object ["ModName" .= (toJSON $ hsmodName hsm), --- "Exports" .= (toJSON $ hsmodExports hsm), --- "Imports" .= (toJSON $ hsmodImports hsm), --- "Decls" .= (toJSON $ hsmodDecls hsm) --- ] --- ---instance ToJSON FastString --- where toJSON=toJSON . pack . unpackFS --- ---instance ToJSON ModuleName --- where toJSON=toJSON . moduleNameString --- ---instance ToJSON OccName --- where toJSON=toJSON . showSDocDump . ppr --- ---instance ToJSON RdrName --- where --- toJSON (Unqual on) = Array $ fromList [toJSON on] --- toJSON (Qual mn on) = Array $ fromList [toJSON mn,toJSON on] --- ---instance (ToJSON a)=> ToJSON (IE a) --- where --- toJSON= toJSON . ieName --} --- {--toJSON (IEVar name)= object ["IEVar" .= toJSON name] --- toJSON (IEThingAbs name)=object ["IEThingAbs" .= toJSON name] --- toJSON (IEThingAll name)= object ["IEThingAll" .= toJSON name] --- toJSON (IEThingWith name ns)= object ["IEVar" .= toJSON name] --- toJSON (IEModuleContents mn)= object ["IEModuleContents" .= toJSON name] --- toJSON (IEGroup i hds)= object ["IEVar" .= toJSON hds] --- toJSON (IEDoc hds)= object ["IEDoc" .= toJSON hds] --- toJSON (IEDocNamed s)= object ["IEDocNamed" .= toJSON s] --} ---{-- ---instance (ToJSON a)=> ToJSON (ImportDecl a) --- where --- toJSON imd=object ["ModName" .= toJSON (ideclName imd), --- "PackageQualified" .= toJSON (ideclPkgQual imd), --- "Source" .= toJSON (ideclSource imd), --- "Qualified" .= toJSON (ideclQualified imd), --- "As" .= toJSON (ideclAs imd), --- "Hiding" .= toJSON (ideclHiding imd) --- ] --- ---instance (ToJSON a, OutputableBndr a)=> ToJSON (HsDecl a) --- where toJSON =toJSON . showSDocDump . ppr --- --- --}+start, end :: SrcSpan -> (Int,Int) +#if __GLASGOW_HASKELL__ < 702 +start ss= (srcSpanStartLine ss, srcSpanStartCol ss) +end ss= (srcSpanEndLine ss, srcSpanEndCol ss) +#else +start (RealSrcSpan ss)= (srcSpanStartLine ss, srcSpanStartCol ss) +start (UnhelpfulSpan _)=error "UnhelpfulSpan in cmpOverlap start" +end (RealSrcSpan ss)= (srcSpanEndLine ss, srcSpanEndCol ss) +end (UnhelpfulSpan _)=error "UnhelpfulSpan in cmpOverlap start" +#endif + +
src/Language/Haskell/BuildWrapper/GHCStorage.hs view
@@ -1,4 +1,16 @@ {-# LANGUAGE CPP,OverloadedStrings,PatternGuards #-} +-- | +-- Module : Language.Haskell.BuildWrapper.GHCStorage +-- Author : JP Moresmau +-- Copyright : (c) JP Moresmau 2012 +-- License : BSD3 +-- +-- Maintainer : jpmoresmau@gmail.com +-- Stability : beta +-- Portability : portable +-- +-- Store to disk in JSON format the results of the GHC AST build, and the build flags +-- this helps us with performance (we only call GHC when the file has changed, not everytime we want to find what's at a given source point module Language.Haskell.BuildWrapper.GHCStorage where import Language.Haskell.BuildWrapper.Base @@ -7,7 +19,6 @@ import System.Directory import System.FilePath --- import qualified GHC.Paths import PprTyThing import GHC import Outputable @@ -24,12 +35,18 @@ #if __GLASGOW_HASKELL__ < 702 import TypeRep ( Type(..), PredType(..) ) -#else +#elif __GLASGOW_HASKELL__ < 704 import TypeRep ( Type(..), Pred(..) ) +#else +import TypeRep ( Type(..) ) #endif +#if __GLASGOW_HASKELL__ >= 704 +import TcEvidence +#endif import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BSC (putStrLn) import qualified Data.ByteString as BSS import Data.Aeson import Data.Maybe @@ -40,28 +57,43 @@ import System.Time (ClockTime) -getInfoFile :: FilePath -> FilePath +-- | get the file storing the information for the given source file +getInfoFile :: FilePath -- ^ the source file + -> FilePath getInfoFile fp= let (dir,file)=splitFileName fp - in combine dir ("." ++ (addExtension file ".bwinfo")) + in combine dir ('.' : addExtension file ".bwinfo") -clearInfo :: FilePath -> IO() +-- | remove the storage file +clearInfo :: FilePath -- ^ the source file + -> IO() clearInfo fp =do let ghcInfoFile=getInfoFile fp removeFile ghcInfoFile -storeBuildFlagsInfo :: FilePath -> (BuildFlags,[BWNote]) -> IO() +-- | store the build flags +storeBuildFlagsInfo :: FilePath -- ^ the source file + -> (BuildFlags,[BWNote]) -- ^ build flags and notes + -> IO() storeBuildFlagsInfo fp bf=setStoredInfo fp "BuildFlags" (toJSON bf) -storeGHCInfo :: FilePath -> TypecheckedSource -> IO() +-- | store the GHC generated AST +storeGHCInfo :: FilePath -- ^ the source file + -> TypecheckedSource -- ^ the GHC AST + -> IO() storeGHCInfo fp tcs=setStoredInfo fp "AST" (dataToJSON tcs) -readGHCInfo :: FilePath -> IO(Maybe Value) +-- | read the GHC AST as a JSON value +readGHCInfo :: FilePath -- ^ the source file + -> IO(Maybe Value) readGHCInfo fp=do (Object hm)<-readStoredInfo fp return $ HM.lookup "AST" hm -readBuildFlagsInfo :: FilePath -> ClockTime -> IO (Maybe (BuildFlags,[BWNote])) +-- | read the build flags and notes as a JSON value +readBuildFlagsInfo :: FilePath -- ^ the source file + -> ClockTime -- ^ time the cabal file was changed. If the file was changed after the storage file, we return Nothing + -> IO (Maybe (BuildFlags,[BWNote])) readBuildFlagsInfo fp ct=do let ghcInfoFile=getInfoFile fp ex<-doesFileExist ghcInfoFile @@ -76,14 +108,20 @@ else return Nothing else return Nothing -setStoredInfo :: FilePath -> T.Text -> Value -> IO() +-- | utility function to store the given value under the given key +setStoredInfo :: FilePath -- ^ the source file + -> T.Text -- ^ the key under which the value will be put + -> Value -- ^ the value + -> IO() setStoredInfo fp k v=do let ghcInfoFile=getInfoFile fp (Object hm)<-readStoredInfo fp let hm2=HM.insert k v hm BSS.writeFile ghcInfoFile $ BSS.concat $ BS.toChunks $ encode $ Object hm2 -readStoredInfo :: FilePath -> IO Value +-- | read the top JSON value containing all the information +readStoredInfo :: FilePath -- ^ the source file + -> IO Value readStoredInfo fp=do let ghcInfoFile=getInfoFile fp ex<-doesFileExist ghcInfoFile @@ -94,6 +132,7 @@ else return Nothing return $ fromMaybe (object []) mv +-- | convert a Data into a JSON value, with specific treatment for interesting GHC AST objects, and avoiding the holes dataToJSON :: Data a =>a -> Value dataToJSON = generic `ext1Q` list `extQ` string `extQ` fastString `extQ` srcSpan @@ -105,20 +144,20 @@ -- object [(T.pack $ showConstr (toConstr t)) .= sub ] string = Data.Aeson.String . T.pack :: String -> Value fastString:: FastString -> Value - fastString fs= object ["FastString" .= (T.pack $ show fs)] + fastString fs= object ["FastString" .= T.pack (show fs)] list l = arr $ map dataToJSON l arr a = let - sub=filter (/= Null) $ a + sub=filter (/= Null) a in case sub of [] -> Null [x] -> x _ -> toJSON sub name :: Name -> Value - name n = object ((nameAndModule n) ++["GType" .= (string $ "Name"),"HType".= (string $ (if isValOcc (nameOccName n) then "v" else "t"))]) + name n = object (nameAndModule n ++["GType" .= string "Name","HType".= string (if isValOcc (nameOccName n) then "v" else "t")]) occName :: OccName -> Value - occName o = object ["OccName" .= (string $ OccName.occNameString o),"HType".= (string $ (if isValOcc o then "v" else "t"))] + occName o = object ["Name" .= string (OccName.occNameString o),"HType" .= string (if isValOcc o then "v" else "t")] modName :: ModuleName -> Value - modName m= object [ "Name" .= (string $ showSDoc $ ppr m),"GType" .= (string "ModuleName"),"HType".= (string $ "m")] + modName m= object [ "Name" .= string (showSDoc $ ppr m),"GType" .= string "ModuleName","HType" .= string "m"] srcSpan :: SrcSpan -> Value srcSpan src | isGoodSrcSpan src = object[ "SrcSpan" .= toJSON [srcLoc $ srcSpanStart src, srcLoc $ srcSpanEnd src]] @@ -136,7 +175,7 @@ var :: Var -> Value var v = typedVar v (varType v) dataCon :: DataCon -> Value - dataCon d = object ((nameAndModule $ dataConName d) ++["GType" .= (string $ "DataCon")]) + dataCon d = object (nameAndModule (dataConName d) ++ ["GType" .= string "DataCon"]) -- simple:: T.Text -> String -> Value -- simple nm v=object [nm .= T.pack v] simpleV:: T.Text -> Value -> Value @@ -154,11 +193,11 @@ Just (t,v)-> typedVar v t Nothing->generic ev typedVar :: Var -> Type -> Value - typedVar v t=object ((nameAndModule $ varName v)++ [ - "GType" .= (string "Var") - ,"Type" .= (string $ showSDocUnqual $ pprTypeForUser True $ t) - ,"QType" .= (string $ showSDoc $ pprTypeForUser True $ t) - ,"HType".= (string $ (if isValOcc (nameOccName (Var.varName v)) then "v" else "t"))]) + typedVar v t=object (nameAndModule (varName v) ++ + ["GType" .= string "Var", + "Type" .= string (showSDocUnqual $ pprTypeForUser True t), + "QType" .= string (showSDoc $ pprTypeForUser True t), + "HType" .= string (if isValOcc (nameOccName (Var.varName v)) then "v" else "t")]) nameSet = const $ Data.Aeson.String "{!NameSet placeholder here!}" :: NameSet -> Value @@ -170,11 +209,13 @@ nameAndModule n=let mn=maybe "" (showSDoc . ppr . moduleName) $ nameModule_maybe n na=showSDocUnqual $ ppr n - in ["Module" .= (string mn), "Name" .= (string na)] + in ["Module" .= string mn, "Name" .= string na] +-- | debug function: shows on standard output the JSON representation of the given data debugToJSON :: Data a =>a -> IO() -debugToJSON = BS.putStrLn . encode . dataToJSON +debugToJSON = BSC.putStrLn . encode . dataToJSON +-- | debug searching thing at point in given data debugFindInJSON :: Data a => Int -> Int -> a -> IO() debugFindInJSON l c a= do let v=dataToJSON a @@ -182,59 +223,80 @@ case mv of Just rv->do putStrLn "something found!" - BS.putStrLn $ encode rv + BSC.putStrLn $ encode rv Nothing->putStrLn "nothing found!" -type FindFunc=(Value -> Bool) - +-- | simple type for search function +type FindFunc= Value -> Bool -findInJSONFormatted :: Bool -> Bool -> Maybe Value -> String +-- | find in JSON AST and return the string result +findInJSONFormatted :: Bool -- ^ should the output be qualified? + -> Bool -- ^ should the output be fully typed? + -> Maybe Value -- ^ result of search + -> String findInJSONFormatted qual typed (Just (Object m)) | Just (String name)<-HM.lookup "Name" m=let tn=T.unpack name qn=if qual then - let mo=maybe "" (\(String s)->(T.unpack s)++".") $ HM.lookup "Module" m + let mo=maybe "" addDot $ HM.lookup "Module" m in mo ++ tn else tn in if typed then let mt=HM.lookup (if qual then "QType" else "Type") m in case mt of - Just (String t)->qn ++ " :: " ++ (T.unpack t) + Just (String t)->qn ++ " :: " ++ T.unpack t _ -> tn else let mt=HM.lookup "HType" m in case mt of - Just (String t)->qn ++ " " ++ (T.unpack t) + Just (String t)->qn ++ " " ++ T.unpack t _ -> tn + where + addDot :: Value -> String + addDot (String s)=T.unpack s ++ "." + addDot _=error "expected String value for Module key" findInJSONFormatted _ _ _="no info" -findInJSON :: FindFunc -> Value -> Maybe Value +findInJSONData :: Maybe Value -> Maybe ThingAtPoint +findInJSONData (Just o@(Object m)) | Just (String _)<-HM.lookup "Name" m=case fromJSON o of + Success tap->tap + Error _ -> Nothing +findInJSONData _=Nothing + +-- | find in JSON AST +findInJSON :: FindFunc -- ^ the evaluation function + -> Value -- ^ the root object containing the AST + -> Maybe Value findInJSON f (Array arr) | not $ V.null arr=let v1=arr V.! 0 - in if f v1 && V.length arr==2 + in if f v1 && V.length arr==2 -- we have an array of two elements, the first one being a matching SrcSpan we go down the second element then let mv=findInJSON f $ arr V.! 1 in case mv of - Just rv-> Just rv - Nothing -> Just $ arr V.! 1 + Just rv-> Just rv -- found something underneath + Nothing -> Just $ arr V.! 1 -- found nothing underneath, return second element of the array else - let rvs=catMaybes $ V.toList $ fmap (findInJSON f) arr + let rvs=catMaybes $ V.toList $ fmap (findInJSON f) arr -- other case of arrays: check on each element in case rvs of - (x:_)->Just x + (x:_)->Just x -- return first match []->Nothing -findInJSON f (Object obj)=let rvs=mapMaybe (findInJSON f) $ HM.elems obj +findInJSON f (Object obj)=let rvs=mapMaybe (findInJSON f) $ HM.elems obj -- in a complex object: check on contained elements in case rvs of (x:_)->Just x []->Nothing findInJSON _ _= Nothing -overlap :: Int -> Int -> Value -> Bool +-- | overlap function: find whatever is at the given line and column +overlap :: Int -- ^ line + -> Int -- ^ column + -> FindFunc overlap l c (Object m) | Just pos<-HM.lookup "SrcSpan" m, Just (l1,c1,l2,c2)<-extractSourceSpan pos=l1<=l && c1<=c && l2>=l && c2>=c overlap _ _ _=False +-- | extract the source span from JSON extractSourceSpan :: Value -> Maybe (Int,Int,Int,Int) extractSourceSpan (Array arr) | V.length arr==2 = do let v1=arr V.! 0 @@ -244,13 +306,14 @@ return (l1,c1,l2,c2) extractSourceSpan _ =Nothing +-- | extract the source location from JSON extractSourceLoc :: Value -> Maybe (Int,Int) extractSourceLoc (Object m) | Just (Number(I l))<-HM.lookup "line" m, Just (Number(I c))<-HM.lookup "column" m=Just (fromIntegral l,fromIntegral c) extractSourceLoc _ = Nothing - +-- | resolve the type of an expression typeOfExpr :: HsExpr Var -> Maybe (Type,Var) typeOfExpr (HsWrap wr (HsVar ident)) = let -- Unwrap a HsWrapper and its associated type @@ -272,7 +335,7 @@ #ifdef WPINLINE unwrap WpInline t = t #endif - in Just $ (reduce_type $ unwrap wr (varType ident),ident) + in Just (reduceType $ unwrap wr (varType ident), ident) -- All other search results produce no type information typeOfExpr _ = Nothing @@ -283,13 +346,13 @@ -- @ -- where @[t'/v]@ is the substitution of @t'@ for @v@. -- -reduce_type :: Type -> Type -reduce_type (AppTy (ForAllTy tv b) t) = - reduce_type (subst_type tv t b) -reduce_type t = t +reduceType :: Type -> Type +reduceType (AppTy (ForAllTy tv b) t) = + reduceType (substType tv t b) +reduceType t = t -subst_type :: TyVar -> Type -> Type -> Type -subst_type v t' t0 = go t0 +substType :: TyVar -> Type -> Type -> Type +substType v t' t0 = go t0 where go t = case t of TyVarTy tv @@ -301,21 +364,12 @@ ForAllTy v' bt | v == v' -> t | otherwise -> ForAllTy v' (go bt) +#if __GLASGOW_HASKELL__ < 704 PredTy pt -> PredTy (go_pt pt) -- XXX: this is probably not right go_pt (ClassP c ts) = ClassP c (map go ts) go_pt (IParam i t) = IParam i (go t) go_pt (EqPred t1 t2) = EqPred (go t1) (go t2) - - ---haddockType :: SearchResult a -> String ---haddockType (FoundName n) --- | isValOcc (nameOccName n)="v" --- | otherwise= "t" ---haddockType (FoundId i) --- | isValOcc (nameOccName (Var.varName i))="v" --- | otherwise= "t" ---haddockType (FoundModule _)="m" ---haddockType _="t" +#endif
src/Language/Haskell/BuildWrapper/Packages.hs view
@@ -84,28 +84,27 @@ r <- lookForPackageDBIn getLibDir case r of Nothing -> ioError $ userError ("Can't find package database in " ++ getLibDir) - Just pkgs -> return $ pkgs + Just pkgs -> return pkgs -- Get the user package configuration database e_appdir <- try $ getAppUserDataDirectory "ghc" - user_conf <- do - case e_appdir of - Left _ -> return [] - Right appdir -> do - let subdir = currentArch ++ '-':currentOS ++ '-':ghcVersion - dir = appdir </> subdir - r <- lookForPackageDBIn dir - case r of - Nothing -> return [] - Just pkgs -> return pkgs + user_conf <- case e_appdir of + Left _ -> return [] + Right appdir -> do + let subdir + = currentArch ++ '-' : currentOS ++ '-' : ghcVersion + dir = appdir </> subdir + r <- lookForPackageDBIn dir + case r of + Nothing -> return [] + Just pkgs -> return pkgs -- Process GHC_PACKAGE_PATH, if present: e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH") - env_stack <- do - case e_pkg_path of + env_stack <- case e_pkg_path of Left _ -> return [] Right path -> do - pkgs <- mapM readContents [(PkgDirectory pkg) | pkg <- splitSearchPath path] + pkgs <- mapM readContents [PkgDirectory pkg | pkg <- splitSearchPath path] return $ concat pkgs -- Send back the combined installed packages list: @@ -126,7 +125,7 @@ if conf_dir_exists then do files <- getDirectoryContents dbdir - return [ dbdir </> file | file <- files, isSuffixOf ".conf" file] + return [ dbdir </> file | file <- files, ".conf" `isSuffixOf` file] else return [] -- | Read a file, ensuring that UTF8 coding is used for GCH >= 6.12 @@ -177,7 +176,7 @@ case pkgInfo of ParseOk _ info -> return [info] ParseFailed err -> do - putStrLn (show err) + (print err) return [emptyInstalledPackageInfo] ) (\_->return [emptyInstalledPackageInfo]) @@ -193,7 +192,7 @@ pkgInfoList <- Exception.evaluate pkgs `catchError` - (\e-> ioError $ userError $ "parsing " ++ dbFile ++ ": " ++ (show e)) + (\e-> ioError $ userError $ "parsing " ++ dbFile ++ ": " ++ show e) return [(takeDirectory dbFile, pkgInfoList)] -- GHC.Path sets libdir for us...
src/Language/Haskell/BuildWrapper/Src.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE TypeSynonymInstances,OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Language.Haskell.BuildWrapper.Src -- Author : JP Moresmau @@ -17,76 +16,84 @@ import Language.Haskell.Exts.Annotated +import qualified Data.Map as DM import qualified Data.Text as T ---import Text.JSON ---import Data.DeriveTH ---import Data.Derive.JSON +import Data.Char (isSpace) +import Data.List (foldl') -getHSEAST :: String -> [String] -> IO (ParseResult (Module SrcSpanInfo, [Comment])) +-- | get the AST +getHSEAST :: String -- ^ input text + -> [String] -- ^ options + -> IO (ParseResult (Module SrcSpanInfo, [Comment])) getHSEAST input options=do - --putStrLn $ show options let exts=map classifyExtension options - let extsFull=if elem "-fglasgow-exts" options + let extsFull=if "-fglasgow-exts" `elem` options then exts ++ glasgowExts else exts - --putStrLn input - --putStrLn $ show exts -- fixities necessary (see http://trac.haskell.org/haskell-src-exts/ticket/189 and https://sourceforge.net/projects/eclipsefp/forums/forum/371922/topic/4808590) - let mode=defaultParseMode {extensions=extsFull,ignoreLinePragmas=False,ignoreLanguagePragmas=False,fixities = Just baseFixities} - return $ parseFileContentsWithComments mode input - --return $ makeObj [("parse" , (showJSON $ pr))] - -getHSEOutline :: (Module SrcSpanInfo, [Comment]) -> [OutlineDef] -getHSEOutline (Module _ _ _ _ decls,comments)=concat $ map declOutline decls + let parseMode=defaultParseMode {extensions=extsFull,ignoreLinePragmas=False,ignoreLanguagePragmas=False,fixities = Just baseFixities} + return $ parseFileContentsWithComments parseMode input + +-- | get the ouline from the AST +getHSEOutline :: (Module SrcSpanInfo, [Comment]) -- ^ the commented AST + -> [OutlineDef] +getHSEOutline (Module _ _ _ _ decls,comments)=map addComment $ concatMap declOutline decls where declOutline :: Decl SrcSpanInfo -> [OutlineDef] - declOutline (DataFamDecl l _ h _) = [OutlineDef (headDecl h) [Data,Family] (makeSpan l) []] - declOutline (DataInsDecl l _ t cons _) = [OutlineDef (typeDecl t) [Data,Instance] (makeSpan l) (map qualConDeclOutline cons)] + declOutline (DataFamDecl l _ h _) = [mkOutlineDef (headDecl h) [Data,Family] (makeSpan l)] + declOutline (DataInsDecl l _ t cons _) = [mkOutlineDefWithChildren (typeDecl t) [Data,Instance] (makeSpan l) (map qualConDeclOutline cons)] --declOutline (GDataInsDecl l _ t cons _) = [OutlineDef (typeDecl t) [Data,Instance] (makeSpan l) (map qualConDeclOutline cons)] - declOutline (DataDecl l _ _ h cons _) = [OutlineDef (headDecl h) [Data] (makeSpan l) (map qualConDeclOutline cons)] + declOutline (DataDecl l _ _ h cons _) = [mkOutlineDefWithChildren (headDecl h) [Data] (makeSpan l) (map qualConDeclOutline cons)] --declOutline (GDataDecl l _ _ h cons _) = [OutlineDef (headDecl h) [Data] (makeSpan l) (map qualConDeclOutline cons)] - declOutline (TypeFamDecl l h _) = [OutlineDef (headDecl h) [Type,Family] (makeSpan l) []] - declOutline (TypeInsDecl l t1 _) = [OutlineDef ((typeDecl t1) ) [Type,Instance] (makeSpan l) []] -- ++ " "++(typeDecl t2) - declOutline (TypeDecl l h _) = [OutlineDef (headDecl h) [Type] (makeSpan l) []] - declOutline (ClassDecl l _ h _ cdecls) = [OutlineDef (headDecl h) [Class] (makeSpan l) (maybe [] (concatMap classDecl) cdecls)] - declOutline (FunBind l matches) = [OutlineDef (matchDecl $ head matches) [Function] (makeSpan l) []] - declOutline (PatBind l (PVar _ n) _ _ _)=[OutlineDef (nameDecl n) [Function] (makeSpan l) []] - declOutline (InstDecl l _ h idecls)=[OutlineDef (iheadDecl h) [Instance] (makeSpan l) (maybe [] (concatMap instDecl) idecls)] - declOutline (SpliceDecl l e)=[OutlineDef (spliceDecl e) [Splice] (makeSpan l) []] + declOutline (TypeFamDecl l h _) = [mkOutlineDef (headDecl h) [Type,Family] (makeSpan l)] + declOutline (TypeInsDecl l t1 _) = [mkOutlineDef (typeDecl t1) [Type,Instance] (makeSpan l)] -- ++ " "++(typeDecl t2) + declOutline (TypeDecl l h t) = [OutlineDef (headDecl h) [Type] (makeSpan l) [] (Just $ typeDecl t) Nothing] + declOutline (ClassDecl l _ h _ cdecls) = [mkOutlineDefWithChildren (headDecl h) [Class] (makeSpan l) (maybe [] (concatMap classDecl) cdecls)] + declOutline (FunBind l matches) = let + n=matchDecl $ head matches + (ty,l2)=addTypeInfo n l + in [OutlineDef n [Function] (makeSpan l2) [] ty Nothing] + declOutline (PatBind l (PVar _ n) _ _ _)=let + nd=nameDecl n + (ty,l2)=addTypeInfo nd l + in [OutlineDef nd [Function] (makeSpan l2) [] ty Nothing] + declOutline (InstDecl l _ h idecls)=[mkOutlineDefWithChildren (iheadDecl h) [Instance] (makeSpan l) (maybe [] (concatMap instDecl) idecls)] + declOutline (SpliceDecl l e)=[mkOutlineDef (spliceDecl e) [Splice] (makeSpan l)] declOutline _ = [] qualConDeclOutline :: QualConDecl SrcSpanInfo-> OutlineDef qualConDeclOutline (QualConDecl l _ _ con)=let (n,defs)=conDecl con - in OutlineDef n [Constructor] (makeSpan l) defs + in mkOutlineDefWithChildren n [Constructor] (makeSpan l) defs declOutlineInClass :: Decl SrcSpanInfo -> [OutlineDef] - declOutlineInClass (TypeSig l ns _)=map (\n->OutlineDef (nameDecl n) [Function] (makeSpan l) []) ns + declOutlineInClass (TypeSig l ns _)=map (\n->mkOutlineDef (nameDecl n) [Function] (makeSpan l)) ns declOutlineInClass o=declOutline o headDecl :: DeclHead a -> T.Text headDecl (DHead _ n _)=nameDecl n headDecl (DHInfix _ _ n _)=nameDecl n headDecl (DHParen _ h)=headDecl h typeDecl :: Type a -> T.Text - typeDecl (TyForall _ _ _ t)=typeDecl t - typeDecl (TyVar _ n )=nameDecl n - typeDecl (TyCon _ qn )=qnameDecl qn - typeDecl (TyList _ t )=T.concat ["[",(typeDecl t),"]"] - typeDecl (TyParen _ t )=typeDecl t - typeDecl (TyApp _ t1 t2)=T.concat [(typeDecl t1) , " ",(typeDecl t2)] - typeDecl _ = "" +-- typeDecl (TyForall _ mb mc t)=typeDecl t +-- typeDecl (TyVar _ n )=nameDecl n +-- typeDecl (TyCon _ qn )=qnameDecl qn +-- typeDecl (TyList _ t )=T.concat ["[", typeDecl t, "]"] +-- typeDecl (TyParen _ t )=typeDecl t +-- typeDecl (TyApp _ t1 t2)=T.concat [typeDecl t1, " ", typeDecl t2] +-- typeDecl (TyFun _ t1 t2)=T.concat [typeDecl t1, " -> ", typeDecl t2] + typeDecl = T.pack . prettyPrint matchDecl :: Match a -> T.Text matchDecl (Match _ n _ _ _)=nameDecl n matchDecl (InfixMatch _ _ n _ _ _)=nameDecl n iheadDecl :: InstHead a -> T.Text - iheadDecl (IHead _ qn ts)= T.concat [(qnameDecl qn) , " " , (T.intercalate " " (map typeDecl ts))] - iheadDecl (IHInfix _ t1 qn t2)= T.concat [(typeDecl t1), " ", (qnameDecl qn) , " " , (typeDecl t2)] + iheadDecl (IHead _ qn ts)= T.concat [qnameDecl qn, " ", T.intercalate " " (map typeDecl ts)] + iheadDecl (IHInfix _ t1 qn t2)= T.concat [typeDecl t1, " ", qnameDecl qn, " ", typeDecl t2] iheadDecl (IHParen _ i)=iheadDecl i conDecl :: ConDecl SrcSpanInfo -> (T.Text,[OutlineDef]) conDecl (ConDecl _ n _)=(nameDecl n,[]) conDecl (InfixConDecl _ _ n _)=(nameDecl n,[]) conDecl (RecDecl _ n fields)=(nameDecl n,concatMap fieldDecl fields) fieldDecl :: FieldDecl SrcSpanInfo -> [OutlineDef] - fieldDecl (FieldDecl l ns _)=map (\n->OutlineDef (nameDecl n) [Field] (makeSpan l) []) ns + fieldDecl (FieldDecl l ns _)=map (\n->mkOutlineDef (nameDecl n) [Field] (makeSpan l)) ns classDecl :: ClassDecl SrcSpanInfo -> [OutlineDef] classDecl (ClsDecl _ d) = declOutlineInClass d classDecl _ = [] @@ -101,10 +108,65 @@ spliceName :: Splice SrcSpanInfo -> T.Text spliceName (IdSplice _ n)=T.pack n spliceName (ParenSplice _ e)=spliceDecl e - + -- | a type map name -> Type + typeMap :: DM.Map T.Text (T.Text,SrcSpanInfo) + typeMap = foldr buildTypeMap DM.empty decls + buildTypeMap :: Decl SrcSpanInfo -> DM.Map T.Text (T.Text,SrcSpanInfo) -> DM.Map T.Text (T.Text,SrcSpanInfo) + buildTypeMap (TypeSig ssi ns t) m=let + td=typeDecl t + in if T.null td + then m + else foldr (\n2 m2->DM.insert (nameDecl n2) (td,ssi) m2) m ns + buildTypeMap _ m=m + addTypeInfo :: T.Text -> SrcSpanInfo -> (Maybe T.Text,SrcSpanInfo) + addTypeInfo t ss1=let + m=DM.lookup t typeMap + in case m of + Nothing->(Nothing,ss1) + -- the type ends just before us: merge src info + 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,T.Text) + commentMap = foldl' buildCommentMap DM.empty comments + addComment:: OutlineDef -> OutlineDef + addComment od=let + st=ifl_line $ ifs_start $ od_loc od + -- search for comment before declaration (line above, same column) + pl=DM.lookup (st-1) commentMap + od2= case pl of + Just (stc,t) | stc == ifl_column (ifs_start $ od_loc od) -> od{od_comment=Just t} + _ -> let + -- search for comment after declaration (same line) + pl2=DM.lookup st commentMap + in case pl2 of + Just (_,t)-> od{od_comment=Just t} + Nothing -> od + in od2{od_children=map addComment $ od_children od2} getHSEOutline _ = [] -getHSEImportExport :: (Module SrcSpanInfo, [Comment]) -> ([ExportDef],[ImportDef]) +-- | build the comment map +buildCommentMap :: DM.Map Int (Int,T.Text) -- ^ the map: key is line, value is start column and comment text + -> Comment -- ^ the comment + -> DM.Map Int (Int,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,T.pack $ dropWhile isSpace rest) m + ('^':rest)->DM.insert st (-1,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,t)->DM.insert st (stc2,T.concat [t,"\n",T.pack txt]) (DM.delete st m) + Nothing-> m + + +-- | get the import/export declarations +getHSEImportExport :: (Module SrcSpanInfo, [Comment]) -- ^ the AST + -> ([ExportDef],[ImportDef]) getHSEImportExport (Module _ mhead _ imps _,_)=(headExp mhead,impDefs imps) where headExp :: Maybe (ModuleHead SrcSpanInfo) ->[ExportDef] @@ -134,7 +196,7 @@ child (IAbs l n)=ImportSpecDef (nameDecl n) IEAbs (makeSpan l) [] child (IThingAll l n) = ImportSpecDef (nameDecl n) IEThingAll (makeSpan l) [] child (IThingWith l n cns) = ImportSpecDef (nameDecl n) IEThingWith (makeSpan l) (map cnameDecl cns) - +getHSEImportExport _=([],[]) nameDecl :: Name a -> T.Text nameDecl (Ident _ s)=T.pack s @@ -149,6 +211,7 @@ mnnameDecl :: ModuleName a -> T.Text mnnameDecl (ModuleName _ s)=T.pack s +-- | convert a HSE span into a buildwrapper span makeSpan :: SrcSpanInfo -> InFileSpan makeSpan si=let sis=srcInfoSpan si @@ -156,89 +219,9 @@ (el,ec)=srcSpanEnd sis in InFileSpan (InFileLoc sl sc) (InFileLoc el ec) +-- | all known extensions, as string knownExtensionNames :: [String] knownExtensionNames = map show knownExtensions - - --- $( derive makeJSON ''ParseResult ) --- $( derive makeJSON ''Module ) --- $( derive makeJSON ''ModuleHead ) --- $( derive makeJSON ''ExportSpecList ) ----- $( derive makeJSON ''SrcLoc ) --- ---instance JSON SrcLoc --- where showJSON src = JSArray [showJSON $ srcLine src,showJSON $ srcColumn src] --- --- $( derive makeJSON ''ModulePragma ) --- $( derive makeJSON ''WarningText ) --- $( derive makeJSON ''ExportSpec ) --- $( derive makeJSON ''ImportDecl ) --- $( derive makeJSON ''ImportSpecList ) --- $( derive makeJSON ''ImportSpec ) --- $( derive makeJSON ''Decl ) --- $( derive makeJSON ''DeclHead ) --- $( derive makeJSON ''Deriving ) --- $( derive makeJSON ''Context ) --- $( derive makeJSON ''InstHead ) --- $( derive makeJSON ''ModuleName ) --- $( derive makeJSON ''Tool ) --- $( derive makeJSON ''CName ) --- $( derive makeJSON ''Name ) --- $( derive makeJSON ''DataOrNew ) --- $( derive makeJSON ''QualConDecl ) --- $( derive makeJSON ''Kind ) --- $( derive makeJSON ''TyVarBind ) --- $( derive makeJSON ''Asst ) --- $( derive makeJSON ''ConDecl ) --- $( derive makeJSON ''FieldDecl ) --- $( derive makeJSON ''QName ) --- $( derive makeJSON ''Type ) --- $( derive makeJSON ''IPName ) --- $( derive makeJSON ''BangType ) --- $( derive makeJSON ''SpecialCon ) --- $( derive makeJSON ''Boxed ) --- $( derive makeJSON ''FunDep ) --- $( derive makeJSON ''ClassDecl ) --- $( derive makeJSON ''GadtDecl ) --- $( derive makeJSON ''InstDecl ) --- $( derive makeJSON ''Match ) --- $( derive makeJSON ''Rhs ) --- $( derive makeJSON ''Binds ) --- $( derive makeJSON ''Exp ) --- $( derive makeJSON ''GuardedRhs ) --- $( derive makeJSON ''IPBind ) --- $( derive makeJSON ''Splice ) --- $( derive makeJSON ''Literal ) --- $( derive makeJSON ''Pat ) --- $( derive makeJSON ''XName ) --- $( derive makeJSON ''Alt ) --- $( derive makeJSON ''QOp ) --- $( derive makeJSON ''XAttr ) --- $( derive makeJSON ''Bracket ) --- $( derive makeJSON ''QualStmt ) --- $( derive makeJSON ''Stmt ) --- $( derive makeJSON ''FieldUpdate ) --- $( derive makeJSON ''RPat ) --- $( derive makeJSON ''RPatOp ) --- $( derive makeJSON ''GuardedAlts ) --- $( derive makeJSON ''PXAttr ) --- $( derive makeJSON ''PatField ) --- $( derive makeJSON ''GuardedAlt ) --- $( derive makeJSON ''Activation ) --- $( derive makeJSON ''Annotation ) --- $( derive makeJSON ''Rule ) --- $( derive makeJSON ''CallConv ) --- $( derive makeJSON ''RuleVar ) --- $( derive makeJSON ''Safety ) --- $( derive makeJSON ''Op ) --- $( derive makeJSON ''Assoc ) --- $( derive makeJSON ''Comment ) --- $( derive makeJSON ''SrcSpan ) --- $( derive makeJSON ''SrcSpanInfo ) --- ---instance JSON Rational --- where showJSON=JSRational False -
test/Language/Haskell/BuildWrapper/APITest.hs view
@@ -21,29 +21,6 @@ unitTests :: [Test] unitTests=[testGetBuiltPath,testParseBuildMessages,testParseConfigureMessages] ---apiTests::Test ---apiTests=TestList $ map (\f->f DirectAPI) tests --- ---data DirectAPI=DirectAPI --- ---instance APIFacade DirectAPI where --- synchronize _ r= runAPI r API.synchronize --- synchronize1 _ r= runAPI r . API.synchronize1 --- write _ r fp s= runAPI r $ API.write fp s --- configure _ r= runAPI r . API.configure --- build _ r= runAPI r . API.build --- getOutline _ r= runAPI r . API.getOutline --- getTokenTypes _ r= runAPI r . API.getTokenTypes --- getOccurrences _ r fp s= runAPI r $ API.getOccurrences fp s --- getThingAtPoint _ r fp l c q t= runAPI r $ API.getThingAtPoint fp l c q t --- getNamesInScope _ r= runAPI r . API.getNamesInScope --- getCabalDependencies _ r= runAPI r . API.getCabalDependencies --- getCabalComponents _ r= runAPI r . API.getCabalComponents --- ---runAPI:: FilePath -> StateT BuildWrapperState IO a -> IO a ---runAPI root f= do --- evalStateT f (BuildWrapperState ".dist-buildwrapper" "cabal" (testCabalFile root) Normal "") - testGetBuiltPath :: Test testGetBuiltPath = TestLabel "testGetBuiltPath" (TestCase (do assertEqual "backslash path" (Just "src\\Language\\Haskell\\BuildWrapper\\Cabal.hs") $ Cabal.getBuiltPath "[4 of 7] Compiling Language.Haskell.BuildWrapper.Cabal ( src\\Language\\Haskell\\BuildWrapper\\Cabal.hs, dist\\build\\Language\\Haskell\\BuildWrapper\\Cabal.o )" @@ -56,7 +33,7 @@ let s="Main.hs:2:3:Warning: Top-level binding with no type signature:\n tests :: [test-framework-0.4.1.1:Test.Framework.Core.Test]\nLinking" let notes=Cabal.parseBuildMessages s assertEqual "not 1 note" 1 (length notes) - assertEqual ("not expected note") (BWNote BWWarning "Top-level binding with no type signature:\n tests :: [test-framework-0.4.1.1:Test.Framework.Core.Test]\n" (BWLocation "Main.hs" 2 3)) (head notes) + assertEqual "not expected note" (BWNote BWWarning "Top-level binding with no type signature:\n tests :: [test-framework-0.4.1.1:Test.Framework.Core.Test]\n" (BWLocation "Main.hs" 2 3)) (head notes) )) testParseConfigureMessages :: Test @@ -64,5 +41,5 @@ let s="cabal.exe: Missing dependencies on foreign libraries:\n* Missing C libraries: tinfo, tinfo\n" let notes=Cabal.parseCabalMessages "test.cabal" "cabal.exe" s assertEqual "not 1 note" 1 (length notes) - assertEqual ("not expected note") (BWNote BWError "Missing dependencies on foreign libraries:\n* Missing C libraries: tinfo, tinfo\n" (BWLocation "test.cabal" 1 1)) (head notes) + assertEqual "not expected note" (BWNote BWError "Missing dependencies on foreign libraries:\n* Missing C libraries: tinfo, tinfo\n" (BWLocation "test.cabal" 1 1)) (head notes) ))
test/Language/Haskell/BuildWrapper/CMDTests.hs view
@@ -33,17 +33,17 @@ data CMDAPI=CMDAPI instance APIFacade CMDAPI where - synchronize _ r ff= runAPI r "synchronize" ["--force="++(show ff)] - synchronize1 _ r ff fp= runAPI r "synchronize1" ["--force="++(show ff),"--file="++fp] + synchronize _ r ff= runAPI r "synchronize" ["--force="++ show ff ] + synchronize1 _ r ff fp= runAPI r "synchronize1" ["--force="++show ff,"--file="++fp] write _ r fp s= runAPI r "write" ["--file="++fp,"--contents="++s] - configure _ r t= runAPI r "configure" ["--cabaltarget="++(show t)] - build _ r b wc= runAPI r "build" ["--output="++(show b),"--cabaltarget="++(show wc)] + configure _ r t= runAPI r "configure" ["--cabaltarget="++ show t] + build _ r b wc= runAPI r "build" ["--output="++ show b,"--cabaltarget="++ show wc] build1 _ r fp= runAPI r "build1" ["--file="++fp] getBuildFlags _ r fp= runAPI r "getbuildflags" ["--file="++fp] getOutline _ r fp= runAPI r "outline" ["--file="++fp] getTokenTypes _ r fp= runAPI r "tokentypes" ["--file="++fp] getOccurrences _ r fp s= runAPI r "occurrences" ["--file="++fp,"--token="++s] - getThingAtPoint _ r fp l c q t= runAPI r "thingatpoint" ["--file="++fp,"--line="++(show l),"--column="++(show c),"--qualify="++(show q),"--typed="++(show t)] + getThingAtPoint _ r fp l c= runAPI r "thingatpoint" ["--file="++fp,"--line="++ show l,"--column="++ show c] getNamesInScope _ r fp= runAPI r "namesinscope" ["--file="++fp] getCabalDependencies _ r= runAPI r "dependencies" [] getCabalComponents _ r= runAPI r "components" [] @@ -57,7 +57,7 @@ runAPI:: (FromJSON a,Show a) => FilePath -> String -> [String] -> IO a runAPI root command args= do - let fullargs=[command,"--tempfolder=.dist-buildwrapper","--cabalpath=cabal","--cabalfile="++(testCabalFile root)] ++ args + let fullargs=[command,"--tempfolder=.dist-buildwrapper","--cabalpath=cabal","--cabalfile="++ testCabalFile root] ++ args exePath<-filterM doesFileExist [".dist-buildwrapper/dist/build/buildwrapper/buildwrapper" <.> exeExtension,"dist/build/buildwrapper/buildwrapper" <.> exeExtension] (ex,out,err)<-readProcessWithExitCode (head exePath) fullargs "" putStrLn ("out:"++out)
test/Language/Haskell/BuildWrapper/GHCTests.hs view
@@ -1,4 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Language.Haskell.BuildWrapper.GHCTests +-- Author : JP Moresmau +-- Copyright : (c) JP Moresmau 2011 +-- License : BSD3 +-- +-- Maintainer : jpmoresmau@gmail.com +-- Stability : beta +-- Portability : portable +-- +-- Test some specific GHC operations module Language.Haskell.BuildWrapper.GHCTests where import Test.HUnit @@ -26,8 +37,8 @@ let (tt,s2)=preprocessSource s False assertEqual "tt is not 2" 2 (length tt) let (t1:t2:[])=tt - assertEqual "first tt is not correct" (TokenDef "PP" (mkLocation 4 1 4 20)) (t1) - assertEqual "second tt is not correct" (TokenDef "PP" (mkLocation 6 1 6 7)) (t2) + assertEqual "first tt is not correct" (TokenDef "PP" (mkLocation 4 1 4 20)) t1 + assertEqual "second tt is not correct" (TokenDef "PP" (mkLocation 6 1 6 7)) t2 assertEqual ("content is not what expected: "++ s2) "\nmodule Main\nwhere\n\nimport Data.Map\n\nmain=undefined\n" s2 )) @@ -38,10 +49,10 @@ let (tt,s2)=preprocessSource s False assertEqual "tt is not 4" 4 (length tt) let (t1:t2:t3:t4:[])=tt - assertEqual "first tt is not correct" (TokenDef "PP" (mkLocation 4 1 4 20)) (t1) - assertEqual "second tt is not correct" (TokenDef "PP" (mkLocation 6 1 6 7)) (t2) - assertEqual "third tt is not correct" (TokenDef "PP" (mkLocation 7 1 7 20)) (t3) - assertEqual "fourth tt is not correct" (TokenDef "PP" (mkLocation 9 1 9 7)) (t4) + assertEqual "first tt is not correct" (TokenDef "PP" (mkLocation 4 1 4 20)) t1 + assertEqual "second tt is not correct" (TokenDef "PP" (mkLocation 6 1 6 7)) t2 + assertEqual "third tt is not correct" (TokenDef "PP" (mkLocation 7 1 7 20)) t3 + assertEqual "fourth tt is not correct" (TokenDef "PP" (mkLocation 9 1 9 7)) t4 assertEqual ("content is not what expected: "++ s2) "\nmodule Main\nwhere\n\nimport Data.Map\n\n\nimport Data.Maybe\n\nmain=undefined\n" s2 )) @@ -52,9 +63,9 @@ let (tt,s2)=preprocessSource s False assertEqual "tt is not 3" 3 (length tt) let (t1:t2:t3:[])=tt - assertEqual "first tt is not correct" (TokenDef "PP" (mkLocation 1 1 1 20)) (t1) - assertEqual "second tt is not correct" (TokenDef "D" (mkLocation 2 1 2 35)) (t2) - assertEqual "third tt is not correct" (TokenDef "PP" (mkLocation 3 1 3 7)) (t3) + assertEqual "first tt is not correct" (TokenDef "PP" (mkLocation 1 1 1 20)) t1 + assertEqual "second tt is not correct" (TokenDef "D" (mkLocation 2 1 2 35)) t2 + assertEqual "third tt is not correct" (TokenDef "PP" (mkLocation 3 1 3 7)) t3 assertEqual ("content is not what expected: "++ s2) "\n\n\nmodule Main\n" s2 )) @@ -66,9 +77,9 @@ assertEqual "tt is not 3" 3 (length tt) let (t1:t2:t3:[])=tt --putStrLn $ show tt - assertEqual "first tt is not correct" (TokenDef "PP" (mkLocation 4 1 4 17)) (t1) - assertEqual "second tt is not correct" (TokenDef "PP" (mkLocation 5 1 5 5)) (t2) - assertEqual "third tt is not correct" (TokenDef "PP" (mkLocation 7 1 7 7)) (t3) + assertEqual "first tt is not correct" (TokenDef "PP" (mkLocation 4 1 4 17)) t1 + assertEqual "second tt is not correct" (TokenDef "PP" (mkLocation 5 1 5 5)) t2 + assertEqual "third tt is not correct" (TokenDef "PP" (mkLocation 7 1 7 7)) t3 assertEqual ("content is not what expected: "++ s2) "\nmodule Main\nwhere\n\n\nimport Data.Map\n\nmain=undefined\n" s2 )) @@ -79,8 +90,8 @@ let (tt,s2)=preprocessSource s True assertEqual "tt is not 2" 2 (length tt) let (t1:t2:[])=tt - assertEqual "first tt is not correct" (TokenDef "DL" (mkLocation 1 1 1 28)) (t1) - assertEqual "second tt is not correct" (TokenDef "DL" (mkLocation 3 1 3 12)) (t2) + assertEqual "first tt is not correct" (TokenDef "DL" (mkLocation 1 1 1 28)) t1 + assertEqual "second tt is not correct" (TokenDef "DL" (mkLocation 3 1 3 12)) t2 assertEqual ("content is not what expected: "++ s2) "\n module Main\n\n where\n import Data.Map\n" s2 )) @@ -92,8 +103,8 @@ let (tt,s2)=preprocessSource s True assertEqual "tt is not 2" 2 (length tt) let (t1:t2:[])=tt - assertEqual "first tt is not correct" (TokenDef "DL" (mkLocation 1 1 1 13)) (t1) - assertEqual "second tt is not correct" (TokenDef "DL" (mkLocation 5 1 5 11)) (t2) + assertEqual "first tt is not correct" (TokenDef "DL" (mkLocation 1 1 1 13)) t1 + assertEqual "second tt is not correct" (TokenDef "DL" (mkLocation 5 1 5 11)) t2 assertEqual ("content is not what expected: "++ s2) "\n module Main\n where\n import Data.Map\n\n" s2 )) @@ -103,8 +114,8 @@ let (tt,s2)=preprocessSource s False assertEqual "tt is not 2" 2 (length tt) let (t1:t2:[])=tt - assertEqual "first tt is not correct" (TokenDef "PP" (mkLocation 5 1 5 20)) (t1) - assertEqual "second tt is not correct" (TokenDef "PP" (mkLocation 7 1 7 7)) (t2) + assertEqual "first tt is not correct" (TokenDef "PP" (mkLocation 5 1 5 20)) t1 + assertEqual "second tt is not correct" (TokenDef "PP" (mkLocation 7 1 7 7)) t2 assertEqual ("content is not what expected: "++ s2) "\nmodule Main\nwhere\nmain=do\n \n do1\n \n do2\n" s2 ))
test/Language/Haskell/BuildWrapper/Tests.hs view
@@ -30,10 +30,11 @@ import Control.Monad --import System.Time -tests :: (APIFacade a)=> [(a -> Test)] +tests :: (APIFacade a)=> [a -> Test] tests= [ testSynchronizeAll, - testConfigureWarnings , testConfigureErrors , + testConfigureWarnings , + testConfigureErrors , testBuildErrors, testBuildWarnings, testBuildOutput, @@ -42,6 +43,7 @@ testOutlinePreproc, testOutlineImportExport, testOutlineLiterate, + testOutlineComments, testPreviewTokenTypes, testThingAtPoint , testThingAtPointNotInCabal, @@ -50,8 +52,8 @@ testNamesInScope, testInPlaceReference, testCabalComponents, - testCabalDependencies - + testCabalDependencies, + testNoSourceDir ] class APIFacade a where @@ -65,7 +67,7 @@ getOutline :: a -> FilePath -> FilePath -> IO (OpResult OutlineResult) getTokenTypes :: a -> FilePath -> FilePath -> IO (OpResult [TokenDef]) getOccurrences :: a -> FilePath -> FilePath -> String -> IO (OpResult [TokenDef]) - getThingAtPoint :: a -> FilePath -> FilePath -> Int -> Int -> Bool -> Bool -> IO (OpResult (Maybe String)) + getThingAtPoint :: a -> FilePath -> FilePath -> Int -> Int -> IO (OpResult (Maybe ThingAtPoint)) getNamesInScope :: a -> FilePath -> FilePath-> IO (OpResult (Maybe [String])) getCabalDependencies :: a -> FilePath -> IO (OpResult [(FilePath,[CabalPackage])]) getCabalComponents :: a -> FilePath -> IO (OpResult [CabalComponent]) @@ -76,12 +78,12 @@ (fps,_)<-synchronize api root False assertBool "no file path on creation" (not $ null fps) assertEqual "no cabal file" (testProjectName <.> ".cabal") (head fps) - assertBool "no A" (elem ("src" </> "A.hs") fps) - assertBool "no C" (elem ("src" </> "B" </> "C.hs") fps) - assertBool "no Main" (elem ("src" </> "Main.hs") fps) - assertBool "no D" (elem ("src" </> "B" </> "D.hs") fps) - assertBool "no Main test" (elem ("test" </> "Main.hs") fps) - assertBool "no TestA" (elem ("test" </> "TestA.hs") fps) + assertBool "no A" (("src" </> "A.hs") `elem` fps) + assertBool "no C" (("src" </> "B" </> "C.hs") `elem` fps) + assertBool "no Main" (("src" </> "Main.hs") `elem` fps) + assertBool "no D" (("src" </> "B" </> "D.hs") `elem` fps) + assertBool "no Main test" (("test" </> "Main.hs") `elem` fps) + assertBool "no TestA" (("test" </> "TestA.hs") `elem` fps) )) testConfigureErrors :: (APIFacade a)=> a -> Test @@ -89,12 +91,13 @@ root<-createTestProject (boolNoCabal,nsNoCabal)<- configure api root Target assertBool "configure returned true on no cabal" (not boolNoCabal) - assertEqual "errors or warnings on no cabal (should be ignored)" 0 (length nsNoCabal) - -- assertEqual ("wrong error on no cabal") (BWNote BWError "No cabal file found.\nPlease create a package description file <pkgname>.cabal\n" (BWLocation "" 0 1)) (head nsNoCabal) + --assertEqual "errors or warnings on no cabal (should be ignored)" 0 (length nsNoCabal) + let bw=head nsNoCabal + assertEqual "wrong error on no cabal" BWError (bwn_status bw) synchronize api root False (boolOK,nsOK)<-configure api root Target - assertBool ("configure returned false") boolOK + assertBool "configure returned false" boolOK assertBool ("errors or warnings:"++show nsOK) (null nsOK) let cf=testCabalFile root let cfn=takeFileName cf @@ -102,7 +105,7 @@ "build-type: Simple"] synchronize api root False (bool1,nsErrors1)<-configure api root Target - assertBool ("bool1 returned true") (not bool1) + assertBool "bool1 returned true" (not bool1) assertEqual "no errors on no name" 2 (length nsErrors1) let (nsError1:nsError2:[])=nsErrors1 assertEqual "not proper error 1" (BWNote BWError "No 'name' field.\n" (BWLocation cfn 1 1)) nsError1 @@ -112,7 +115,7 @@ "build-type: Simple"] synchronize api root False (bool2,nsErrors2)<-configure api root Target - assertBool ("bool2 returned true") (not bool2) + assertBool "bool2 returned true" (not bool2) assertEqual "no errors on invalid name" 1 (length nsErrors2) let (nsError3:[])=nsErrors2 assertEqual "not proper error 3" (BWNote BWError "Parse of field 'name' failed.\n" (BWLocation cfn 1 1)) nsError3 @@ -128,7 +131,7 @@ " build-depends: base, toto"] synchronize api root False (bool3,nsErrors3)<-configure api root Target - assertBool ("bool3 returned true") (not bool3) + assertBool "bool3 returned true" (not bool3) assertEqual "no errors on unknown dependency" 1 (length nsErrors3) let (nsError4:[])=nsErrors3 assertEqual "not proper error 4" (BWNote BWError "At least the following dependencies are missing:\ntoto -any\n" (BWLocation cfn 1 1)) nsError4 @@ -145,12 +148,12 @@ " build-depends: base, toto, titi"] synchronize api root False (bool4,nsErrors4)<-configure api root Target - assertBool ("bool4 returned true") (not bool4) + assertBool "bool4 returned true" (not bool4) assertEqual "no errors on unknown dependencies" 1 (length nsErrors4) let (nsError5:[])=nsErrors4 assertEqual "not proper error 5" (BWNote BWError "At least the following dependencies are missing:\ntiti -any, toto -any\n" (BWLocation cfn 1 1)) nsError5 (BuildResult bool4b _,nsErrors4b)<-build api root False Source - assertBool ("bool4b returned true") (not bool4b) + assertBool "bool4b returned true" (not bool4b) assertEqual "no errors on unknown dependencies" 1 (length nsErrors4b) let (nsError5b:[])=nsErrors4b assertEqual "not proper error 5b" (BWNote BWError "At least the following dependencies are missing:\ntiti -any, toto -any\n" (BWLocation cfn 1 1)) nsError5b @@ -165,7 +168,7 @@ " build-depends: base"] synchronize api root False (bool5,nsErrors5)<-configure api root Target - assertBool ("bool5 returned true") (not bool5) + assertBool "bool5 returned true" (not bool5) assertEqual "no errors on no main" 1 (length nsErrors5) let (nsError6:[])=nsErrors5 assertEqual "not proper error 6" (BWNote BWError "No 'Main-Is' field found for executable BWTest\n" (BWLocation cfn 1 1)) nsError6 @@ -191,8 +194,8 @@ " build-depends: base"] synchronize api root False (bool1,ns1)<- configure api root Target - assertBool ("returned false 1 "++ (show ns1)) bool1 - assertEqual ("didn't return 1 warning: "++(show ns1)) 1 (length ns1) + assertBool ("returned false 1 " ++ show ns1) bool1 + assertEqual ("didn't return 1 warning: " ++ show ns1) 1 (length ns1) let (nsWarning1:[])=ns1 assertEqual "not proper warning 1" (BWNote BWWarning "Unknown fields: field1 (line 5)\nFields allowed in this section:\nname, version, cabal-version, build-type, license, license-file,\ncopyright, maintainer, build-depends, stability, homepage,\npackage-url, bug-reports, synopsis, description, category, author,\ntested-with, data-files, data-dir, extra-source-files,\nextra-tmp-files\n" (BWLocation cfn 5 1)) nsWarning1 writeFile cf $ unlines ["name: "++testProjectName, @@ -206,8 +209,8 @@ " build-depends: base"] synchronize api root False (bool2,ns2)<- configure api root Target - assertBool ("returned false 2 "++ (show ns2)) bool2 - assertEqual ("didn't return 1 warning: "++(show ns1)) 1 (length ns2) + assertBool ("returned false 2 " ++ show ns2) bool2 + assertEqual ("didn't return 1 warning: " ++ show ns1) 1 (length ns2) let (nsWarning2:[])=ns2 assertEqual "not proper warning 2" (BWNote BWWarning "A package using section syntax must specify at least\n'cabal-version: >= 1.2'.\n" (BWLocation cfn 1 1)) nsWarning2 writeFile cf $ unlines ["name: "++testProjectName, @@ -219,12 +222,12 @@ " exposed-modules: A", " other-modules: B.C", " build-depends: base"] - writeFile ((takeDirectory cf) </> "Setup.hs") $ unlines ["import Distribution.Simple", + writeFile (takeDirectory cf </> "Setup.hs") $ unlines ["import Distribution.Simple", "main = defaultMain"] synchronize api root False (bool3,ns3)<- configure api root Target - assertBool ("returned false 3 "++ (show ns3)) bool3 - assertEqual ("didn't return 1 warning: "++(show ns1)) 1 (length ns3) + assertBool ("returned false 3 " ++ show ns3) bool3 + assertEqual ("didn't return 1 warning: " ++ show ns1) 1 (length ns3) let (nsWarning3:[])=ns3 assertEqual "not proper warning 3" (BWNote BWWarning "No 'build-type' specified. If you do not need a custom Setup.hs or\n./configure script then use 'build-type: Simple'.\n" (BWLocation cfn 1 1)) nsWarning3 @@ -235,39 +238,33 @@ root<-createTestProject synchronize api root False (boolOKc,nsOKc)<-configure api root Target - assertBool ("returned false on configure") boolOKc + assertBool "returned false on configure" boolOKc assertBool ("errors or warnings on configure:"++show nsOKc) (null nsOKc) (BuildResult boolOK _,nsOK)<-build api root False Source - assertBool ("returned false on build") boolOK + assertBool "returned false on build" boolOK assertBool ("errors or warnings on build:"++show nsOK) (null nsOK) - --let srcF=root </> "src" let rel="src"</>"A.hs" -- write source file writeFile (root </> rel) $ unlines ["module A where","import toto","fA=undefined"] - --mf1<-runAPI root $ synchronize1 rel False - --assertBool ("mf1 not just") (isJust mf1) (BuildResult bool1 _,nsErrors1)<-build api root False Source - assertBool ("returned true on bool1") (not bool1) - assertBool ("no errors or warnings on nsErrors") (not $ null nsErrors1) - -- assertBool ("no rel in fps1: "++(show fps1)) (elem rel fps1) + assertBool "returned true on bool1" (not bool1) + assertBool "no errors or warnings on nsErrors" (not $ null nsErrors1) let (nsError1:[])=nsErrors1 assertEqualNotesWithoutSpaces "not proper error 1" (BWNote BWError "parse error on input `toto'\n" (BWLocation rel 2 8)) nsError1 -- write file and synchronize writeFile (root </> "src"</>"A.hs")$ unlines ["module A where","import Toto","fA=undefined"] mf2<-synchronize1 api root True rel - assertBool ("mf2 not just") (isJust mf2) + assertBool "mf2 not just" (isJust mf2) (BuildResult bool2 _,nsErrors2)<-build api root False Source - assertBool ("returned true on bool2") (not bool2) - assertBool ("no errors or warnings on nsErrors2") (not $ null nsErrors2) - -- assertBool ("no rel in fps2: "++(show fps2)) (elem rel fps1) + assertBool "returned true on bool2" (not bool2) + assertBool "no errors or warnings on nsErrors2" (not $ null nsErrors2) let (nsError2:[])=nsErrors2 assertEqualNotesWithoutSpaces "not proper error 2" (BWNote BWError "Could not find module `Toto':\n Use -v to see a list of the files searched for.\n" (BWLocation rel 2 8)) nsError2 - (bf3,nsErrors3f)<- getBuildFlags api root ("src"</>"A.hs") - assertBool ("errors or warnings on nsErrors3f:"++ (show nsErrors3f)) (null nsErrors3f) + (_,nsErrors3f)<- getBuildFlags api root ("src"</>"A.hs") + assertBool ("errors or warnings on nsErrors3f:" ++ show nsErrors3f) (null nsErrors3f) (bool3,nsErrors3)<-build1 api root ("src"</>"A.hs") - assertBool ("returned true on bool3") (not bool3) - assertBool ("no errors or warnings on nsErrors3") (not $ null nsErrors3) - -- assertBool ("no rel in fps2: "++(show fps2)) (elem rel fps1) + assertBool "returned true on bool3" (not bool3) + assertBool "no errors or warnings on nsErrors3" (not $ null nsErrors3) let (nsError3:[])=nsErrors3 assertEqualNotesWithoutSpaces "not proper error 3" (BWNote BWError "Could not find module `Toto':\n Use -v to see a list of the files searched for." (BWLocation rel 2 8)) nsError3 @@ -290,35 +287,35 @@ " ghc-options: -Wall"] --let srcF=root </> "src" (boolOK,nsOK)<-configure api root Source - assertBool ("returned false") boolOK + assertBool "returned false" boolOK assertBool ("errors or warnings:"++show nsOK) (null nsOK) let rel="src"</>"A.hs" writeFile (root </> rel) $ unlines ["module A where","import Data.List","fA=undefined"] mf2<-synchronize1 api root True rel - assertBool ("mf2 not just") (isJust mf2) + assertBool "mf2 not just" (isJust mf2) (BuildResult bool1 fps1,nsErrors1)<-build api root False Source - assertBool ("returned false on bool1") bool1 - assertBool ("no errors or warnings on nsErrors1") (not $ null nsErrors1) - assertBool ("no rel in fps1: "++(show fps1)) (elem rel fps1) + assertBool "returned false on bool1" bool1 + assertBool "no errors or warnings on nsErrors1" (not $ null nsErrors1) + assertBool ("no rel in fps1: " ++ show fps1) (rel `elem` fps1) let (nsError1:nsError2:[])=nsErrors1 assertEqualNotesWithoutSpaces "not proper error 1" (BWNote BWWarning "The import of `Data.List' is redundant\n except perhaps to import instances from `Data.List'\n To import instances alone, use: import Data.List()\n" (BWLocation rel 2 1)) nsError1 assertEqualNotesWithoutSpaces "not proper error 2" (BWNote BWWarning "Top-level binding with no type signature:\n fA :: forall a. a\n" (BWLocation rel 3 1)) nsError2 - (bf3,nsErrors3f)<-getBuildFlags api root rel - assertBool ("errors or warnings on nsErrors3f") (null nsErrors3f) + (_,nsErrors3f)<-getBuildFlags api root rel + assertBool "errors or warnings on nsErrors3f" (null nsErrors3f) (bool3,nsErrors3)<-build1 api root rel - assertBool ("returned false on bool3") bool3 - assertBool ("no errors or warnings on nsErrors3") (not $ null nsErrors3) + assertBool "returned false on bool3" bool3 + assertEqual "not 2 errors or warnings on nsErrors3" 2 (length nsErrors3) let (nsError3:nsError4:[])=nsErrors3 assertEqualNotesWithoutSpaces "not proper error 3" (BWNote BWWarning "The import of `Data.List' is redundant\n except perhaps to import instances from `Data.List'\n To import instances alone, use: import Data.List()" (BWLocation rel 2 1)) nsError3 assertEqualNotesWithoutSpaces "not proper error 4" (BWNote BWWarning "Top-level binding with no type signature:\n fA :: forall a. a" (BWLocation rel 3 1)) nsError4 writeFile (root </> rel) $ unlines ["module A where","pats:: String -> String","pats a=reverse a","fB:: String -> Char","fB pats=head pats"] mf3<-synchronize1 api root True rel - assertBool ("mf3 not just") (isJust mf2) + assertBool "mf3 not just" (isJust mf3) (bool4,nsErrors4)<-build1 api root rel - assertBool ("returned false on bool4") bool4 - assertBool ("no errors or warnings on nsErrors4") (not $ null nsErrors4) + assertBool "returned false on bool4" bool4 + assertBool "no errors or warnings on nsErrors4" (not $ null nsErrors4) let (nsError5:[])=nsErrors4 - assertEqualNotesWithoutSpaces "not proper error 5" (BWNote BWWarning "This binding for `pats' shadows the existing binding\n defined at src\\A.hs:3:1" (BWLocation rel 4 5)) nsError5 + assertEqualNotesWithoutSpaces "not proper error 5" (BWNote BWWarning ("This binding for `pats' shadows the existing binding\n defined at "++rel++":3:1") (BWLocation rel 4 5)) nsError5 )) testBuildOutput :: (APIFacade a)=> a -> Test @@ -326,9 +323,9 @@ root<-createTestProject synchronize api root False build api root True Source - let exeN=case os of - "mingw32"->(addExtension testProjectName "exe") - _->testProjectName + let exeN=case os of+ "mingw32" -> addExtension testProjectName "exe"+ _ -> testProjectName let exeF=root </> ".dist-buildwrapper" </> "dist" </> "build" </> testProjectName </> exeN exeE1<-doesFileExist exeF assertBool ("exe does not exist on build output: "++exeF) exeE1 @@ -348,38 +345,19 @@ writeFile (root </> rel) $ unlines ["module A where","import Auto","fA=undefined"] let rel2="src"</>"Auto.hs" writeFile (root </> rel2) $ unlines ["module Auto where","fAuto=undefined"] - (fps,ns)<-synchronize api root False + synchronize api root False (BuildResult bool1 _,nsErrors1)<-build api root True Source - assertBool ("returned false on bool1") bool1 - assertBool ("errors or warnings on nsErrors1") (null nsErrors1) - (bf2,nsErrors2f)<-getBuildFlags api root rel - assertBool ("no errors or warnings on nsErrors2f") (null nsErrors2f) + assertBool "returned false on bool1" bool1 + assertBool "errors or warnings on nsErrors1" (null nsErrors1) + (_,nsErrors2f)<-getBuildFlags api root rel + assertBool "no errors or warnings on nsErrors2f" (null nsErrors2f) (bool2, nsErrors2)<-build1 api root rel - assertBool ("returned false on bool2: "++(show nsErrors2)) bool2 - assertBool ("errors or warnings on nsErrors2: "++(show nsErrors2)) (null nsErrors2) + assertBool ("returned false on bool2: " ++ show nsErrors2) bool2 + assertBool ("errors or warnings on nsErrors2: " ++ show nsErrors2) (null nsErrors2) )) ---testAST :: Test ---testAST = TestLabel "testAST" (TestCase ( do --- root<-createTestProject --- runAPI root synchronize False --- (boolOKc,nsOKc)<-runAPI root $ configure Target --- assertBool ("returned false on configure") boolOKc --- assertBool ("errors or warnings on configure:"++show nsOKc) (null nsOKc) --- --- (boolOK,nsOK)<-runAPI root $ build False --- assertBool ("returned false on build") boolOK --- assertBool ("errors or warnings on build:"++show nsOK) (null nsOK) --- (mast,nsOK2)<-runAPI root $ getAST ("src" </> "A.hs") --- assertBool ("errors or warnings on getAST:"++show nsOK2) (null nsOK2) --- case mast of --- Just ast->do --- let json=makeObj [("parse" , (showJSON $ ast))] --- putStrLn $ show $ encode json --- Nothing -> assertFailure "no ast" --- )) - + testOutline :: (APIFacade a)=> a -> Test testOutline api= TestLabel "testOutline" (TestCase ( do root<-createTestProject @@ -428,44 +406,113 @@ " mkt2_s :: String,", " mkt2_i :: Int", " }" ] - (bf3,nsErrors3f)<-getBuildFlags api root rel - assertBool ("errors or warnings on nsErrors3f") (null nsErrors3f) + (_,nsErrors3f)<-getBuildFlags api root rel + assertBool "errors or warnings on nsErrors3f" (null nsErrors3f) (OutlineResult defs es is,nsErrors1)<-getOutline api root rel assertBool ("errors or warnings on getOutline:"++show nsErrors1) (null nsErrors1) let expected=[ - OutlineDef "XList" [Data,Family] (InFileSpan (InFileLoc 8 1)(InFileLoc 8 20)) [] - ,OutlineDef "XList Char" [Data,Instance] (InFileSpan (InFileLoc 11 1)(InFileLoc 11 60)) [ - OutlineDef "XCons" [Constructor] (InFileSpan (InFileLoc 11 28)(InFileLoc 11 53)) [] - ,OutlineDef "XNil" [Constructor] (InFileSpan (InFileLoc 11 56)(InFileLoc 11 60)) [] + mkOutlineDefWithChildren "XList" [Data,Family] (InFileSpan (InFileLoc 8 1)(InFileLoc 8 20)) [] + ,mkOutlineDefWithChildren "XList Char" [Data,Instance] (InFileSpan (InFileLoc 11 1)(InFileLoc 11 60)) [ + mkOutlineDef "XCons" [Constructor] (InFileSpan (InFileLoc 11 28)(InFileLoc 11 53)) + ,mkOutlineDef "XNil" [Constructor] (InFileSpan (InFileLoc 11 56)(InFileLoc 11 60)) ] - ,OutlineDef "Elem" [Type,Family] (InFileSpan (InFileLoc 13 1)(InFileLoc 13 19)) [] - ,OutlineDef "Elem [e]" [Type,Instance] (InFileSpan (InFileLoc 15 1)(InFileLoc 15 27)) [] - ,OutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 18 1)(InFileLoc 18 25)) [] - ,OutlineDef "testfunc1bis" [Function] (InFileSpan (InFileLoc 21 1)(InFileLoc 22 25)) [] - ,OutlineDef "testMethod" [Function] (InFileSpan (InFileLoc 25 1)(InFileLoc 27 13)) [] - ,OutlineDef "ToString" [Class] (InFileSpan (InFileLoc 29 1)(InFileLoc 32 0)) [ - OutlineDef "toString" [Function] (InFileSpan (InFileLoc 30 5)(InFileLoc 30 28)) [] + ,mkOutlineDef "Elem" [Type,Family] (InFileSpan (InFileLoc 13 1)(InFileLoc 13 19)) + ,mkOutlineDef "Elem [e]" [Type,Instance] (InFileSpan (InFileLoc 15 1)(InFileLoc 15 27)) + ,OutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 17 1)(InFileLoc 18 25)) [] (Just "[Char]") Nothing + ,OutlineDef "testfunc1bis" [Function] (InFileSpan (InFileLoc 20 1)(InFileLoc 22 25)) [] (Just "String -> [Char]") Nothing + ,OutlineDef "testMethod" [Function] (InFileSpan (InFileLoc 24 1)(InFileLoc 27 13)) [] (Just "forall a . (Num a) => a -> a -> a") Nothing + ,mkOutlineDefWithChildren "ToString" [Class] (InFileSpan (InFileLoc 29 1)(InFileLoc 32 0)) [ + mkOutlineDef "toString" [Function] (InFileSpan (InFileLoc 30 5)(InFileLoc 30 28)) ] - ,OutlineDef "ToString String" [Instance] (InFileSpan (InFileLoc 32 1)(InFileLoc 35 0)) [ - OutlineDef "toString" [Function] (InFileSpan (InFileLoc 33 5)(InFileLoc 33 18)) [] + ,mkOutlineDefWithChildren "ToString String" [Instance] (InFileSpan (InFileLoc 32 1)(InFileLoc 35 0)) [ + mkOutlineDef "toString" [Function] (InFileSpan (InFileLoc 33 5)(InFileLoc 33 18)) ] - ,OutlineDef "Str" [Type] (InFileSpan (InFileLoc 35 1)(InFileLoc 35 16)) [] - ,OutlineDef "Type1" [Data] (InFileSpan (InFileLoc 37 1)(InFileLoc 41 10)) [ - OutlineDef "MkType1_1" [Constructor] (InFileSpan (InFileLoc 37 12)(InFileLoc 37 25)) [] - ,OutlineDef "MkType1_2" [Constructor] (InFileSpan (InFileLoc 38 7)(InFileLoc 41 10)) [ - OutlineDef "mkt2_s" [Field] (InFileSpan (InFileLoc 39 9)(InFileLoc 39 25)) [] - ,OutlineDef "mkt2_i" [Field] (InFileSpan (InFileLoc 40 9)(InFileLoc 40 22)) [] + ,OutlineDef "Str" [Type] (InFileSpan (InFileLoc 35 1)(InFileLoc 35 16)) [] (Just "String") Nothing + ,mkOutlineDefWithChildren "Type1" [Data] (InFileSpan (InFileLoc 37 1)(InFileLoc 41 10)) [ + mkOutlineDef "MkType1_1" [Constructor] (InFileSpan (InFileLoc 37 12)(InFileLoc 37 25)) + ,mkOutlineDefWithChildren "MkType1_2" [Constructor] (InFileSpan (InFileLoc 38 7)(InFileLoc 41 10)) [ + mkOutlineDef "mkt2_s" [Field] (InFileSpan (InFileLoc 39 9)(InFileLoc 39 25)) + ,mkOutlineDef "mkt2_i" [Field] (InFileSpan (InFileLoc 40 9)(InFileLoc 40 22)) ] ] ] assertEqual "length" (length expected) (length defs) - mapM_ (\(e,c)->assertEqual "outline" e c) (zip expected defs) + mapM_ (uncurry (assertEqual "outline")) (zip expected defs) assertEqual "exports" [] es assertEqual "imports" [ImportDef "Data.Char" (InFileSpan (InFileLoc 5 1)(InFileLoc 5 17)) False False "" Nothing] is )) +testOutlineComments :: (APIFacade a)=> a -> Test +testOutlineComments api= TestLabel "testOutlineComments" (TestCase ( do + root<-createTestProject + synchronize api root False + let rel="src"</>"A.hs" + -- use api to write temp file + write api root rel $ unlines [ + "{-# LANGUAGE RankNTypes, TypeSynonymInstances, TypeFamilies #-}", + "", + "module Module1 where", + "", + "import Data.Char", + "", + "-- testFunc1 comment", + "testfunc1 :: [Char]", + "testfunc1=reverse \"test\"", + "", + "-- | testFunc1bis haddock", + "testfunc1bis :: String -> [Char]", + "testfunc1bis []=\"nothing\"", + "testfunc1bis s=reverse s", + "", + "-- | testMethod", + "-- haddock", + "testMethod :: forall a. (Num a) => a -> a -> a", + "testMethod a b=", + " let e=a + (fromIntegral $ length testfunc1)", + " in e * 2", + "", + "class ToString a where", + " toString :: a -> String -- ^ toString comment", + "", + "-- | Str haddock", + "type Str=String", + "", + "-- | Type1 haddock", + "data Type1=MkType1_1 Int -- ^ MkType1 comment", + " | MkType1_2 {", + " mkt2_s :: String,", + " mkt2_i :: Int", + " }" ] + (_,nsErrors3f)<-getBuildFlags api root rel + assertBool "errors or warnings on nsErrors3f" (null nsErrors3f) + (OutlineResult defs es is,nsErrors1)<-getOutline api root rel + assertBool ("errors or warnings on getOutline:"++show nsErrors1) (null nsErrors1) + let expected=[ + OutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 8 1)(InFileLoc 9 25)) [] (Just "[Char]") Nothing + ,OutlineDef "testfunc1bis" [Function] (InFileSpan (InFileLoc 12 1)(InFileLoc 14 25)) [] (Just "String -> [Char]") (Just "testFunc1bis haddock") + ,OutlineDef "testMethod" [Function] (InFileSpan (InFileLoc 18 1)(InFileLoc 21 13)) [] (Just "forall a . (Num a) => a -> a -> a") (Just "testMethod\n haddock") + ,mkOutlineDefWithChildren "ToString" [Class] (InFileSpan (InFileLoc 23 1)(InFileLoc 27 0)) [ + OutlineDef "toString" [Function] (InFileSpan (InFileLoc 24 5)(InFileLoc 24 28)) [] Nothing (Just "toString comment") + ] + ,OutlineDef "Str" [Type] (InFileSpan (InFileLoc 27 1)(InFileLoc 27 16)) [] (Just "String") (Just "Str haddock") + ,OutlineDef "Type1" [Data] (InFileSpan (InFileLoc 30 1)(InFileLoc 34 10)) [ + OutlineDef "MkType1_1" [Constructor] (InFileSpan (InFileLoc 30 12)(InFileLoc 30 25)) [] Nothing (Just "MkType1 comment") + ,mkOutlineDefWithChildren "MkType1_2" [Constructor] (InFileSpan (InFileLoc 31 7)(InFileLoc 34 10)) [ + mkOutlineDef "mkt2_s" [Field] (InFileSpan (InFileLoc 32 9)(InFileLoc 32 25)) + ,mkOutlineDef "mkt2_i" [Field] (InFileSpan (InFileLoc 33 9)(InFileLoc 33 22)) + + ] + + ] Nothing (Just "Type1 haddock") + ] + assertEqual ("length:" ++ show defs) (length expected) (length defs) + mapM_ (uncurry (assertEqual "outline")) (zip expected defs) + assertEqual "exports" [] es + assertEqual "imports" [ImportDef "Data.Char" (InFileSpan (InFileLoc 5 1)(InFileLoc 5 17)) False False "" Nothing] is + )) + testOutlinePreproc :: (APIFacade a)=> a -> Test testOutlinePreproc api= TestLabel "testOutlinePreproc" (TestCase ( do root<-createTestProject @@ -495,15 +542,15 @@ "#endif", "" ] - (bf3,nsErrors3f)<-getBuildFlags api root rel - assertBool ("errors or warnings on nsErrors3f") (null nsErrors3f) + (_,nsErrors3f)<-getBuildFlags api root rel + assertBool "errors or warnings on nsErrors3f" (null nsErrors3f) (OutlineResult defs1 _ _,nsErrors1)<-getOutline api root rel assertBool ("errors or warnings on getOutlinePreproc 1:"++show nsErrors1) (null nsErrors1) let expected1=[ - OutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 1)(InFileLoc 6 25)) [] + mkOutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 1)(InFileLoc 6 25)) ] assertEqual "length of expected1" (length expected1) (length defs1) - mapM_ (\(e,c)->assertEqual "outline" e c) (zip expected1 defs1) + mapM_ (uncurry (assertEqual "outline")) (zip expected1 defs1) write api root rel $ unlines [ "{-# LANGUAGE CPP #-}", "", @@ -522,13 +569,13 @@ (OutlineResult defs2 _ _,nsErrors2)<-getOutline api root rel assertBool ("errors or warnings on getOutlinePreproc:"++show nsErrors2) (null nsErrors2) let expected2=[ - OutlineDef "Name" [Data] (InFileSpan (InFileLoc 5 1)(InFileLoc 9 38)) [ - OutlineDef "Ident" [Constructor] (InFileSpan (InFileLoc 6 6)(InFileLoc 6 18)) [], - OutlineDef "Symbol" [Constructor] (InFileSpan (InFileLoc 7 6)(InFileLoc 7 19)) [] + mkOutlineDefWithChildren "Name" [Data] (InFileSpan (InFileLoc 5 1)(InFileLoc 9 38)) [ + OutlineDef "Ident" [Constructor] (InFileSpan (InFileLoc 6 6)(InFileLoc 6 18)) [] Nothing (Just "/varid/ or /conid/."), + OutlineDef "Symbol" [Constructor] (InFileSpan (InFileLoc 7 6)(InFileLoc 7 19)) [] Nothing (Just "/varsym/ or /consym/") ] ] assertEqual "length of expected2" (length expected2) (length defs2) - mapM_ (\(e,c)->assertEqual "outline" e c) (zip expected2 defs2) + mapM_ (uncurry (assertEqual "outline")) (zip expected2 defs2) write api root rel $ unlines [ "{-# LANGUAGE CPP #-}", "", @@ -544,10 +591,10 @@ (OutlineResult defs3 _ _,nsErrors3)<-getOutline api root rel assertBool ("errors or warnings on getOutlinePreproc 3:"++show nsErrors3) (null nsErrors3) let expected3=[ - OutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 1)(InFileLoc 6 25)) [] + mkOutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 1)(InFileLoc 6 25)) ] assertEqual "length of expected3" (length expected3) (length defs3) - mapM_ (\(e,c)->assertEqual "outline" e c) (zip expected3 defs3) + mapM_ (uncurry (assertEqual "outline")) (zip expected3 defs3) )) @@ -567,15 +614,15 @@ "", "" ] - (bf3,nsErrors3f)<-getBuildFlags api root rel - assertBool ("errors or warnings on nsErrors3f") (null nsErrors3f) + (_,nsErrors3f)<-getBuildFlags api root rel + assertBool "errors or warnings on nsErrors3f" (null nsErrors3f) (OutlineResult defs1 _ _,nsErrors1)<-getOutline api root rel assertBool ("errors or warnings on testOutlineLiterate 1:"++show nsErrors1) (null nsErrors1) let expected1=[ - OutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 3)(InFileLoc 6 27)) [] + mkOutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 3)(InFileLoc 6 27)) ] assertEqual "length of expected1" (length expected1) (length defs1) - mapM_ (\(e,c)->assertEqual "outline" e c) (zip expected1 defs1) + mapM_ (uncurry (assertEqual "outline")) (zip expected1 defs1) )) testOutlineImportExport :: (APIFacade a)=> a -> Test @@ -592,8 +639,8 @@ "import Data.List hiding (orderBy,groupBy)", "import qualified Data.Maybe (Maybe(Just))" ] - (bf3,nsErrors3f)<-getBuildFlags api root rel - assertBool ("errors or warnings on nsErrors3f") (null nsErrors3f) + (_,nsErrors3f)<-getBuildFlags api root rel + assertBool "errors or warnings on nsErrors3f" (null nsErrors3f) (OutlineResult _ es is,nsErrors1)<-getOutline api root rel assertBool ("errors or warnings on getOutline:"++show nsErrors1) (null nsErrors1) let exps=[ @@ -601,14 +648,14 @@ ExportDef "Data.Char" IEModule (InFileSpan (InFileLoc 1 23)(InFileLoc 1 39)) [], ExportDef "MkTest" IEThingAll (InFileSpan (InFileLoc 1 40)(InFileLoc 1 50)) [] ] - mapM_ (\(e,c)->assertEqual "exports" e c) (zip exps es) + mapM_ (uncurry (assertEqual "exports")) (zip exps es) let imps=[ ImportDef "Data.Char" (InFileSpan (InFileLoc 3 1)(InFileLoc 3 17)) False False "" Nothing, ImportDef "Data.Map" (InFileSpan (InFileLoc 4 1)(InFileLoc 4 30)) False False "DM" (Just [ImportSpecDef "empty" IEVar (InFileSpan (InFileLoc 4 24)(InFileLoc 4 29)) []]), ImportDef "Data.List" (InFileSpan (InFileLoc 5 1)(InFileLoc 5 42)) False True "" (Just [ImportSpecDef "orderBy" IEVar (InFileSpan (InFileLoc 5 26)(InFileLoc 5 33)) [],ImportSpecDef "groupBy" IEVar (InFileSpan (InFileLoc 5 34)(InFileLoc 5 41)) []]), ImportDef "Data.Maybe" (InFileSpan (InFileLoc 6 1)(InFileLoc 6 42)) True False "" (Just [ImportSpecDef "Maybe" IEThingWith (InFileSpan (InFileLoc 6 30)(InFileLoc 6 41)) ["Just"]]) ] - mapM_ (\(e,c)->assertEqual "imports" e c) (zip imps is) + mapM_ (uncurry (assertEqual "imports")) (zip imps is) )) @@ -649,26 +696,26 @@ "module Main where", "main=return $ map id \"toto\"" ] - (bf3,nsErrors3f)<-getBuildFlags api root rel - assertBool ("errors or warnings on nsErrors3f") (null nsErrors3f) - (tap1,nsErrors1)<-getThingAtPoint api root rel 2 16 True True + (_,nsErrors3f)<-getBuildFlags api root rel + assertBool "errors or warnings on nsErrors3f" (null nsErrors3f) + (tap1,nsErrors1)<-getThingAtPoint api root rel 2 16 assertBool ("errors or warnings on getThingAtPoint1:"++show nsErrors1) (null nsErrors1) - assertEqual "not just typed qualified" (Just "GHC.Base.map :: forall a b. (a -> b) -> [a] -> [b] GHC.Types.Char GHC.Types.Char") tap1 - (tap2,nsErrors2)<-getThingAtPoint api root rel 2 16 False True - assertBool ("errors or warnings on getThingAtPoint2:"++show nsErrors2) (null nsErrors2) - assertEqual "not just typed unqualified" (Just "map :: forall a b. (a -> b) -> [a] -> [b] Char Char") tap2 - (tap3,nsErrors3)<-getThingAtPoint api root rel 2 16 True False - assertBool ("errors or warnings on getThingAtPoint3:"++show nsErrors3) (null nsErrors3) - assertEqual "not just untyped qualified" (Just "GHC.Base.map v") tap3 - - (tap4,nsErrors4)<-getThingAtPoint api root rel 2 16 False False - assertBool ("errors or warnings on getThingAtPoint4:"++show nsErrors4) (null nsErrors4) - assertEqual "not just untyped unqualified" (Just "map v") tap4 + assertBool "not just tap1" (isJust tap1) + assertEqual "not map" "map" (tapName $ fromJust tap1) + assertEqual "not GHC.Base" (Just "GHC.Base") (tapModule $ fromJust tap1) + assertEqual "not qtype" (Just "forall a b. (a -> b) -> [a] -> [b] GHC.Types.Char GHC.Types.Char") (tapQType $ fromJust tap1) + assertEqual "not type" (Just "forall a b. (a -> b) -> [a] -> [b] Char Char") (tapType $ fromJust tap1) + assertEqual "not htype" (Just "v") (tapHType $ fromJust tap1) + assertEqual "not gtype" (Just "Var") (tapGType $ fromJust tap1) - (tap5,nsErrors5)<-getThingAtPoint api root rel 2 20 True True - assertBool ("errors or warnings on getThingAtPoint1:"++show nsErrors5) (null nsErrors5) - assertEqual "not just typed qualified" (Just "GHC.Base.id :: GHC.Types.Char -> GHC.Types.Char") tap5 + (tap5,nsErrors5)<-getThingAtPoint api root rel 2 20 + assertBool ("errors or warnings on getThingAtPoint1:"++show nsErrors5) (null nsErrors5) + assertBool "not just tap5" (isJust tap5) + assertEqual "not id" "id" (tapName $ fromJust tap5) + assertEqual "not GHC.Base" (Just "GHC.Base") (tapModule $ fromJust tap5) + assertEqual "not qtype" (Just "GHC.Types.Char -> GHC.Types.Char") (tapQType $ fromJust tap5) + )) testThingAtPointNotInCabal :: (APIFacade a)=> a -> Test @@ -678,20 +725,21 @@ configure api root Target let rel2="src"</>"Auto.hs" writeFile (root </> rel2) $ unlines ["module Auto where","fAuto=head [2,3,4]"] - (fps,ns)<-synchronize api root False - (bf3,nsErrors3f)<-getBuildFlags api root rel2 - assertBool ("errors or warnings on nsErrors3f") (null nsErrors3f) - (tap1,nsErrors1)<-getThingAtPoint api root rel2 2 8 True True + synchronize api root False + (_,nsErrors3f)<-getBuildFlags api root rel2 + assertBool "errors or warnings on nsErrors3f" (null nsErrors3f) + (tap1,nsErrors1)<-getThingAtPoint api root rel2 2 8 assertBool ("errors or warnings on getThingAtPoint1:"++show nsErrors1) (null nsErrors1) - assertEqual "not just typed qualified" (Just "GHC.List.head :: [GHC.Integer.Type.Integer] -> GHC.Integer.Type.Integer") tap1 - - )) + assertBool "not just tap1" (isJust tap1) + assertEqual "not head" "head" (tapName $ fromJust tap1) + assertEqual "not GHC.List" (Just "GHC.List") (tapModule $ fromJust tap1) + assertEqual "not qtype" (Just "[GHC.Integer.Type.Integer] -> GHC.Integer.Type.Integer") (tapQType $ fromJust tap1) + )) testThingAtPointMain :: (APIFacade a)=> a -> Test testThingAtPointMain api= TestLabel "testThingAtPointMain" (TestCase ( do root<-createTestProject let cf=testCabalFile root - let cfn=takeFileName cf writeFile cf $ unlines ["name: "++testProjectName, "version:0.1", "cabal-version: >= 1.8", @@ -711,18 +759,29 @@ synchronize api root False configure api root Target (bf3,nsErrors3f)<-getBuildFlags api root rel - assertBool ("errors or warnings on nsErrors3f") (null nsErrors3f) - assertEqual ("not main module") (Just "Main") (bf_modName bf3) - (tap1,nsErrors1)<-getThingAtPoint api root rel 3 16 True True + assertBool "errors or warnings on nsErrors3f" (null nsErrors3f) + assertEqual "not main module" (Just "Main") (bf_modName bf3) + (tap1,nsErrors1)<-getThingAtPoint api root rel 3 16 assertBool ("errors or warnings on getThingAtPoint1:"++show nsErrors1) (null nsErrors1) - assertEqual "not just typed qualified" (Just "GHC.List.head :: [GHC.Integer.Type.Integer] -> GHC.Integer.Type.Integer") tap1 - )) + assertBool "not just tap1" (isJust tap1) + assertEqual "not head" "head" (tapName $ fromJust tap1) + assertEqual "not GHC.List" (Just "GHC.List") (tapModule $ fromJust tap1) + assertEqual "not qtype" (Just "[GHC.Integer.Type.Integer] -> GHC.Integer.Type.Integer") (tapQType $ fromJust tap1) + +-- (tap2,nsErrors2)<-getThingAtPoint api root rel 2 8 +-- assertBool ("errors or warnings on getThingAtPoint2:"++show nsErrors2) (null nsErrors2) +-- assertBool "not just tap2" (isJust tap2) +-- assertEqual "not B.D" "B.D" (tapName $ fromJust tap2) +-- assertEqual "not ModuleName" (Just "ModuleName") (tapGType $ fromJust tap2) +-- assertEqual "not m" (Just "m") (tapHType $ fromJust tap2) +-- + + )) testThingAtPointMainSubFolder :: (APIFacade a)=> a -> Test testThingAtPointMainSubFolder api= TestLabel "testThingAtPointMainSubFolder" (TestCase ( do root<-createTestProject let cf=testCabalFile root - let cfn=takeFileName cf writeFile cf $ unlines ["name: "++testProjectName, "version:0.1", "cabal-version: >= 1.8", @@ -744,11 +803,15 @@ synchronize api root False configure api root Target (bf3,nsErrors3f)<-getBuildFlags api root rel - assertBool ("errors or warnings on nsErrors3f") (null nsErrors3f) - assertEqual ("not main module") (Just "Main") (bf_modName bf3) - (tap1,nsErrors1)<-getThingAtPoint api root rel 3 16 True True + assertBool "errors or warnings on nsErrors3f" (null nsErrors3f) + assertEqual "not main module" (Just "Main") (bf_modName bf3) + (tap1,nsErrors1)<-getThingAtPoint api root rel 3 16 assertBool ("errors or warnings on getThingAtPoint1:"++show nsErrors1) (null nsErrors1) - assertEqual "not just typed qualified" (Just "GHC.List.head :: [GHC.Integer.Type.Integer] -> GHC.Integer.Type.Integer") tap1 + assertBool "not just tap1" (isJust tap1) + assertEqual "not head" "head" (tapName $ fromJust tap1) + assertEqual "not GHC.List" (Just "GHC.List") (tapModule $ fromJust tap1) + assertEqual "not qtype" (Just "[GHC.Integer.Type.Integer] -> GHC.Integer.Type.Integer") (tapQType $ fromJust tap1) + )) testNamesInScope :: (APIFacade a)=> a -> Test @@ -771,9 +834,9 @@ assertBool ("errors or warnings on getNamesInScope:"++show nsErrors1) (null nsErrors1) assertBool "getNamesInScope not just" (isJust mtts) let tts=fromJust mtts - assertBool "does not contain Main.main" (elem "Main.main" tts) - assertBool "does not contain B.D.fD" (elem "B.D.fD" tts) - assertBool "does not contain GHC.Types.Char" (elem "GHC.Types.Char" tts) + assertBool "does not contain Main.main" ("Main.main" `elem` tts) + assertBool "does not contain B.D.fD" ("B.D.fD" `elem` tts) + assertBool "does not contain GHC.Types.Char" ("GHC.Types.Char" `elem` tts) )) testInPlaceReference :: (APIFacade a)=> a -> Test @@ -818,32 +881,35 @@ assertBool ("returned false on configure:"++show nsOKc) boolOKc assertBool ("errors or warnings on configure:"++show nsOKc) (null nsOKc) (BuildResult boolOK _,nsOK)<-build api root True Source - assertBool ("returned false on build") boolOK + assertBool "returned false on build" boolOK assertBool ("errors or warnings on build:"++show nsOK) (null nsOK) synchronize api root True (mtts,nsErrors1)<-getNamesInScope api root rel assertBool ("errors or warnings on getNamesInScope in place:"++show nsErrors1) (null nsErrors1) assertBool "getNamesInScope in place not just" (isJust mtts) let tts=fromJust mtts - assertBool "getNamesInScope in place 1 does not contain Main.main" (elem "Main.main" tts) - assertBool "getNamesInScope in place 1 does not contain B.C.fC" (elem "B.C.fC" tts) - (bf3,nsErrors3f)<-getBuildFlags api root rel - assertBool ("errors or warnings on nsErrors3f") (null nsErrors3f) - (tap1,nsErrorsTap1)<-getThingAtPoint api root rel 3 16 True True + assertBool "getNamesInScope in place 1 does not contain Main.main" ("Main.main" `elem` tts) + assertBool "getNamesInScope in place 1 does not contain B.C.fC" ("B.C.fC" `elem` tts) + (_,nsErrors3f)<-getBuildFlags api root rel + assertBool "errors or warnings on nsErrors3f" (null nsErrors3f) + (tap1,nsErrorsTap1)<-getThingAtPoint api root rel 3 16 assertBool ("errors or warnings on getThingAtPoint1 in place:"++show nsErrorsTap1) (null nsErrorsTap1) - assertEqual "not just typed qualified" (Just "GHC.Base.map :: forall a b. (a -> b) -> [a] -> [b] GHC.Types.Char GHC.Types.Char") tap1 + assertBool "not just tap1" (isJust tap1) + assertEqual "not map" "map" (tapName $ fromJust tap1) + assertEqual "not GHC.Base" (Just "GHC.Base") (tapModule $ fromJust tap1) + assertEqual "not qtype" (Just "forall a b. (a -> b) -> [a] -> [b] GHC.Types.Char GHC.Types.Char") (tapQType $ fromJust tap1) (mtts2,nsErrors2)<-getNamesInScope api root rel2 assertBool ("errors or warnings on getNamesInScope in place 2:"++show nsErrors2) (null nsErrors2) assertBool "getNamesInScope in place 2 not just" (isJust mtts2) let tts2=fromJust mtts2 - assertBool "getNamesInScope in place 2 does not contain A.fA" (elem "A.fA" tts2) - assertBool "getNamesInScope in place 2 does not contain B.C.fC" (elem "B.C.fC" tts2) + assertBool "getNamesInScope in place 2 does not contain A.fA" ("A.fA" `elem` tts2) + assertBool "getNamesInScope in place 2 does not contain B.C.fC" ("B.C.fC" `elem` tts2) (mtts3,nsErrors3)<-getNamesInScope api root rel3 assertBool ("errors or warnings on getNamesInScope in place 3:"++show nsErrors3) (null nsErrors3) assertBool "getNamesInScope in place 3 not just" (isJust mtts3) let tts3=fromJust mtts3 - assertBool "getNamesInScope in place 3 does not contain A.fA" (elem "A.fA" tts3) + assertBool "getNamesInScope in place 3 does not contain A.fA" ("A.fA" `elem` tts3) )) testCabalComponents :: (APIFacade a)=> a -> Test @@ -904,7 +970,7 @@ assertBool ("errors or warnings on getCabalDependencies:"++show nsOK) (null nsOK) assertEqual "not two databases" 2 (length cps) let (_:(_,pkgs):[])=cps - let base=filter (\pkg->(cp_name pkg)=="base") pkgs + let base=filter (\pkg->cp_name pkg == "base") pkgs assertEqual "not 1 base" 1 (length base) let (l:ex:ts:[])=cp_dependent $ head base assertEqual "not library true" (CCLibrary True) l @@ -912,6 +978,46 @@ assertEqual "not test suite true" (CCTestSuite "BWTest-test" True) ts )) + +testNoSourceDir :: (APIFacade a)=> a -> Test +testNoSourceDir api=TestLabel "testNoSourceDir" (TestCase (do + root<-createTestProject + let cf=testCabalFile root + writeFile cf $ unlines ["name: "++testProjectName, + "version:0.1", + "cabal-version: >= 1.8", + "build-type: Simple", + "", + "library", + " exposed-modules: A", + " other-modules: B.C", + " build-depends: base", + "", + "executable BWTest", + " main-is: src/Main.hs", + " other-modules: B.D", + " build-depends: base", + ""] + let git=root </> ".git" + createDirectoryIfMissing False git + let gitInBW=root </> ".dist-buildwrapper" </> ".git" + writeFile (git </> "testfile") "test" + d1<-doesDirectoryExist gitInBW + assertBool "git exists before synchronize" (not d1) + + let bwInBw=root </> ".dist-buildwrapper" </> ".dist-buildwrapper" + d1b<-doesDirectoryExist bwInBw + assertBool ".dist-buildwrapper exists before synchronize" (not d1b) + + synchronize api root False + d2<-doesDirectoryExist gitInBW + assertBool "git exists after synchronize" (not d2) + + d2b<-doesDirectoryExist bwInBw + assertBool ".dist-buildwrapper exists after synchronize" (not d2b) + + )) + testProjectName :: String testProjectName="BWTest" @@ -958,7 +1064,7 @@ testTestAContents :: String testTestAContents=unlines ["module TestA where","fTA=undefined"] -createTestProject :: IO(FilePath) +createTestProject :: IO FilePath createTestProject = do temp<-getTemporaryDirectory let root=temp </> testProjectName @@ -981,7 +1087,7 @@ return root removeSpaces :: String -> String -removeSpaces = (filter (/=':')) . (filter (not . isSpace)) +removeSpaces = filter (/= ':') . filter (not . isSpace) assertEqualNotesWithoutSpaces :: String -> BWNote -> BWNote -> IO() assertEqualNotesWithoutSpaces msg n1 n2=do
test/Main.hs view
@@ -9,7 +9,6 @@ -- Portability : portable -- -- Testing exe entry point --- TODO replace with test-framework module Main where import Language.Haskell.BuildWrapper.APITest @@ -28,24 +27,3 @@ ,testGroup "Command Tests" (concatMap hUnitTestToTests cmdTests) ] ---import Language.Haskell.BuildWrapper.APITest ---import Language.Haskell.BuildWrapper.CMDTests --- ---import Control.Monad ---import Data.Monoid --- ---import System.Exit (exitFailure) ---import Test.HUnit --- ---main :: IO() ---main = do --- unit<-mapM runTestTT [unitTests] --- cmd<-mapM runTestTT [cmdTests] --- --let cmd=[] --- let allCounts=mconcat (unit ++ cmd) --- when ((errors allCounts)>0 || (failures allCounts)>0) exitFailure --- --- ---instance Monoid Counts where --- mempty =Counts 0 0 0 0 --- mappend (Counts a b c d) (Counts a' b' c' d')=Counts (a+a') (b+b') (c+c') (d+d')