buildwrapper 0.6.0 → 0.6.1
raw patch · 11 files changed
+263/−121 lines, 11 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Language.Haskell.BuildWrapper.Base: bwlEndCol :: BWLocation -> Int
+ Language.Haskell.BuildWrapper.Base: bwlEndLine :: BWLocation -> Int
+ Language.Haskell.BuildWrapper.Base: mkEmptySpan :: FilePath -> Int -> Int -> BWLocation
- Language.Haskell.BuildWrapper.Base: BWLocation :: FilePath -> Int -> Int -> BWLocation
+ Language.Haskell.BuildWrapper.Base: BWLocation :: FilePath -> Int -> Int -> Int -> Int -> BWLocation
Files
- buildwrapper.cabal +1/−1
- src-exe/Language/Haskell/BuildWrapper/CMD.hs +7/−6
- src/Language/Haskell/BuildWrapper/API.hs +11/−7
- src/Language/Haskell/BuildWrapper/Base.hs +11/−3
- src/Language/Haskell/BuildWrapper/Cabal.hs +8/−8
- src/Language/Haskell/BuildWrapper/GHC.hs +13/−6
- src/Language/Haskell/BuildWrapper/GHCStorage.hs +57/−34
- src/Language/Haskell/BuildWrapper/Src.hs +15/−6
- test/Language/Haskell/BuildWrapper/APITest.hs +4/−4
- test/Language/Haskell/BuildWrapper/CMDTests.hs +14/−10
- test/Language/Haskell/BuildWrapper/Tests.hs +122/−36
buildwrapper.cabal view
@@ -1,5 +1,5 @@ name: buildwrapper -version: 0.6.0 +version: 0.6.1 cabal-version: >= 1.8 build-type: Simple license: BSD3
src-exe/Language/Haskell/BuildWrapper/CMD.hs view
@@ -16,7 +16,7 @@ import Language.Haskell.BuildWrapper.Base hiding (tempFolder,cabalPath, cabalFile, cabalFlags,verbosity) import Control.Monad.State import System.Console.CmdArgs hiding (Verbosity(..),verbosity) - +import System.Directory (canonicalizePath) import Paths_buildwrapper import Data.Aeson @@ -121,8 +121,7 @@ summary ("buildwrapper executable, version " ++ showVersion version)) >>= handle - where - handle ::BWCmd -> IO () + where handle ::BWCmd -> IO () 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) @@ -141,6 +140,8 @@ 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) (cabalOption cmd)) - >>= BSC.putStrLn . BS.append "build-wrapper-json:" . encode - + runCmdV vb cmd f= + do { cabalFile' <- canonicalizePath $ cabalFile cmd -- canonicalize cabal-file path because Eclipse does not correctly keep track of case changes on the project path + ; resultJson <- evalStateT f (BuildWrapperState (tempFolder cmd) (cabalPath cmd) cabalFile' vb (cabalFlags cmd) (cabalOption cmd)) + ; BSC.putStrLn . BS.append "build-wrapper-json:" . encode $ resultJson + }
src/Language/Haskell/BuildWrapper/API.hs view
@@ -43,7 +43,7 @@ import Outputable (showSDoc,ppr) import Data.Foldable (foldrM) - +--import qualified MonadUtils as GMU -- | 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 @@ -98,6 +98,7 @@ cbis<-getAllFiles lbi cf<-gets cabalFile temp<-getFullTempDir + let dir=takeDirectory cf let pkg=T.pack $ display $ packageId $ localPkgDescr lbi allMps<-mapM (\cbi->do @@ -108,13 +109,10 @@ fullTgt<-getTargetPath f let fullUsage=getUsageFile fullTgt liftIO $ isSourceMoreRecent fullSrc fullUsage - -- liftIO $ Prelude.putStrLn (fullSrc ++ "->" ++ fullUsage ++":"++(show recent)) - --return recent - ) $ filter (\(f,_)->let ext=takeExtension f - in ext `elem` [".hs",".lhs"] + ) $ filter (\(f,_)->fitForUsage f ) mps1 - opts<-fileGhcOptions (lbi,cbi) + opts<-fileGhcOptions (lbi,cbi) modules<-liftIO $ do cd<-getCurrentDirectory setCurrentDirectory dir @@ -127,6 +125,12 @@ return $ map fst $ concat allMps ) where + -- | fitForUsage + fitForUsage :: FilePath -> Bool + fitForUsage f + | takeDirectory f == "." && takeBaseName f == "Setup"=False -- exclude Setup + | otherwise=let ext=takeExtension f + in ext `elem` [".hs",".lhs"] -- only keep haskell files -- | get module name and import/export usage information getModule :: T.Text -- ^ the current package name -> FilePath -- ^ the file to process @@ -401,7 +405,7 @@ let ods=getHSEOutline ast let (es,is)=getHSEImportExport ast return (OutlineResult ods es is,bwns) - Just (ParseFailed failLoc err)->return (OutlineResult [] [] [],BWNote BWError err (BWLocation fp (srcLine failLoc) (srcColumn failLoc)) :bwns) + Just (ParseFailed failLoc err)->return (OutlineResult [] [] [],BWNote BWError err (mkEmptySpan fp (srcLine failLoc) (srcColumn failLoc)) :bwns) _ -> return (OutlineResult [] [] [],bwns) -- | get lexer token types for source file
src/Language/Haskell/BuildWrapper/Base.hs view
@@ -54,22 +54,29 @@ parseJSON (String t) =return $ read $ T.unpack $ T.append "BW" t parseJSON _= mzero --- | location of a note/error +-- | location of a note/error (lines and columns start at 1) data BWLocation=BWLocation { bwlSrc::FilePath -- ^ source file ,bwlLine::Int -- ^ line ,bwlCol::Int -- ^ column + ,bwlEndLine::Int -- ^ end line + ,bwlEndCol::Int -- ^ end line } deriving (Show,Read,Eq) +mkEmptySpan :: FilePath -> Int -> Int -> BWLocation +mkEmptySpan src line col = BWLocation src line col line col + instance ToJSON BWLocation where - toJSON (BWLocation s l c)=object ["f" .= s, "l" .= l , "c" .= c] + toJSON (BWLocation s l c el ec)=object ["f" .= s, "l" .= l , "c" .= c, "el" .= el , "ec" .= ec] instance FromJSON BWLocation where parseJSON (Object v) =BWLocation <$> v .: "f" <*> v .: "l" <*> - v .: "c" + v .: "c" <*> + v .: "el" <*> + v .: "ec" parseJSON _= mzero -- | a note on a source file @@ -643,6 +650,7 @@ formatJSON :: String -> String formatJSON s1=snd $ foldl f (0,"") s1 where + f :: (Int,String) -> Char -> (Int,String) f (i,s) '['=(i + 4, s ++ "\n" ++ map (const ' ') [0 .. i] ++ "[") f (i,s) ']' =(i - 4, s ++ "\n" ++ map (const ' ') [0 .. i] ++ "]") f (i,s) c =(i,s++[c])
src/Language/Haskell/BuildWrapper/Cabal.hs view
@@ -158,14 +158,14 @@ lbi<-DSC.getPersistBuildConfig dist_dir return (Just lbi,msgs) ExitFailure ec -> if null msgs - then return (Nothing,[BWNote BWError ("Cabal configure returned error code " ++ show ec) (BWLocation cf 0 1)]) + then return (Nothing,[BWNote BWError ("Cabal configure returned error code " ++ show ec) (mkEmptySpan cf 0 1)]) else return (Nothing, msgs) setCurrentDirectory cd return ret else do let err="Cabal file"++ cf ++" does not exist" liftIO $ putStrLn err - return (Nothing,[BWNote BWError err (BWLocation cf 0 1)]) + return (Nothing,[BWNote BWError err (mkEmptySpan cf 0 1)]) -- | get the full path to the cabal file getCabalFile :: WhichCabal -- ^ use original cabal or temp cabal file @@ -226,13 +226,13 @@ where parseCabalLine :: (Maybe (BWNote,[String]),[BWNote]) -> String ->(Maybe (BWNote,[String]),[BWNote]) parseCabalLine (currentNote,ls) l - | "Error:" `isPrefixOf` l=(Just (BWNote BWError "" (BWLocation cf 1 1),[dropWhile isSpace $ drop 6 l]),addCurrent currentNote ls) + | "Error:" `isPrefixOf` l=(Just (BWNote BWError "" (mkEmptySpan cf 1 1),[dropWhile isSpace $ drop 6 l]),addCurrent currentNote ls) | "Warning:" `isPrefixOf` l=let msg=(dropWhile isSpace $ drop 8 l) 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) + in (Just (BWNote BWWarning "" (mkEmptySpan cf (extractLine msg2) 1),[msg2]),addCurrent currentNote ls) | Just (bw,n)<- cabalErrorLine cf cabalExe l=(Just (bw,n),addCurrent currentNote ls) | Just (jcn,msgs)<-currentNote= if not $ null l @@ -269,7 +269,7 @@ let 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]) + then Just (BWNote BWError "" (mkEmptySpan cf 1 1), [s2]) else let (loc,rest)=span (/= ':') s2 @@ -283,7 +283,7 @@ else if readInt line' (-1)==(-1) then (cf,"1",s2) else (loc,line',tail msg') - in Just (BWNote BWError "" (BWLocation realloc (readInt line 1) 1),[msg]) + in Just (BWNote BWError "" (mkEmptySpan realloc (readInt line 1) 1),[msg]) | otherwise=Nothing -- | parse messages from build @@ -312,11 +312,11 @@ 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 (readInt line 1) (read col)) + (loc:line:col:[])-> Just $ BWNote BWError (dropWhile isSpace aft) (mkEmptySpan loc (readInt line 1) (read col)) _ -> let (_,_,_,ls2)=el =~ "(.+)(\\(.+\\)):(.+):(.+):" :: (String,String,String,[String]) in case ls2 of - (loc2:ext1:_:_:[])-> Just $ BWNote BWError (drop (length loc2 + length ext1 + 1) el) (BWLocation (validLoc cf distDir loc2) 1 1) + (loc2:ext1:_:_:[])-> Just $ BWNote BWError (drop (length loc2 + length ext1 + 1) el) (mkEmptySpan (validLoc cf distDir loc2) 1 1) _ -> Nothing validLoc :: FilePath -- ^ the cabal file
src/Language/Haskell/BuildWrapper/GHC.hs view
@@ -113,7 +113,8 @@ -- so we can't use hscTarget = HscNothing -- and it takes a while to actually generate the o and hi files for big modules -- if we use CompManager, it's slower for modules with lots of dependencies but we can keep hscTarget= HscNothing which makes it better for bigger modules - setSessionDynFlags flg' {hscTarget = HscNothing, ghcLink = NoLink , ghcMode = CompManager, log_action = logAction ref } + -- we use target interpreted so that it works with TemplateHaskell + setSessionDynFlags flg' {hscTarget = HscInterpreted, ghcLink = NoLink , ghcMode = CompManager, log_action = logAction ref } -- $ dopt_set (flg' { ghcLink = NoLink , ghcMode = CompManager }) Opt_ForceRecomp let fps=getLoadFiles contents mapM_ (\(fp,_)-> addTarget Target { targetId = TargetFile fp Nothing, targetAllowObjCode = True, targetContents = Nothing }) fps @@ -132,11 +133,14 @@ --GMU.liftIO $ putStrLn ("load all targets: " ++ (timeDiffToString $ diffClockTimes c2 c1)) -- GMU.liftIO $ print fps a<-fmap catMaybes $ mapM (\(fp,m)->(do - --mg<-getModuleGraph modSum <- getModSummary $ mkModuleName m fmap Just $ workOnResult f fp modSum) - `gcatch` (\(_ :: SourceError) -> return Nothing) - `gcatch` (\(_ :: GhcApiError) -> return Nothing) + `gcatch` (\(se :: SourceError) -> do + GMU.liftIO $ print se + return Nothing) + `gcatch` (\(ae :: GhcApiError) -> do + GMU.liftIO $ print ae + return Nothing) ) fps #if __GLASGOW_HASKELL__ < 702 warns <- getWarnings @@ -301,10 +305,13 @@ ghcSpanToBWLocation baseDir sp | GHC.isGoodSrcSpan sp = let (stl,stc)=start sp + (enl,enc)=end sp in BWLocation (makeRelative baseDir $ foldr f [] $ normalise $ unpackFS (sfile sp)) stl - (ghcColToScionCol $stc) - | otherwise = BWLocation "" 1 1 + (ghcColToScionCol stc) + enl + (ghcColToScionCol enc) + | otherwise = mkEmptySpan "" 1 1 where f c (x:xs) | c=='\\' && x=='\\'=x:xs -- WHY do we get two slashed after the drive sometimes?
src/Language/Haskell/BuildWrapper/GHCStorage.hs view
@@ -33,11 +33,14 @@ #endif #if __GLASGOW_HASKELL__ < 702 -import TypeRep ( Type(..), PredType(..) ) +import TypeRep (Type(..), PredType(..)) +import VarSet #elif __GLASGOW_HASKELL__ < 704 -import TypeRep ( Type(..), Pred(..) ) +import TypeRep (Type(..), Pred(..), tyVarsOfType) +import VarSet (isEmptyVarSet) #else -import TypeRep ( Type(..) ) +import TypeRep (Type(..), tyVarsOfType) +import VarSet (isEmptyVarSet) #endif #if __GLASGOW_HASKELL__ >= 704 @@ -524,37 +527,57 @@ -- All other search results produce no type information typeOfExpr _ = 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-level applications by pushing 'AppTy' arguments on a stack and binding them in an environment at the +-- appropriate 'ForAllTy'. Class constraints that have no free variables after reduction are removed. reduceType :: Type -> Type -reduceType (AppTy (ForAllTy tv b) t) = - reduceType (substType tv t b) -reduceType t = t - -substType :: TyVar -> Type -> Type -> Type -substType v t' = go - 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) +reduceType = reduce [] [] + where reduce :: [Type] -> [(Var,Type)] -> Type -> Type + -- The stack is only passed into AppTy and ForallTy cases, since otherwise it will be empty anyway. + -- We probably don't even need to reduce in the other cases, but it won't cause any problems and keeps this + -- function simpler (we do need to substitute). + -- NOTE: when working on this code, make sure to temporarily disable caching in GHC.withJSONAST. + reduce _ env t@(TyVarTy var) | Just arg <- lookup var env = arg -- note: var's are unique + | otherwise = t + reduce _ env (TyConApp tycon kts) = TyConApp tycon $ map (reduce [] env) kts + reduce stck env (AppTy typ1 typ2) = reduce (reduce [] env typ2 : stck) env typ1 -- push argument onto stack + reduce [] env (ForAllTy var typ) = ForAllTy var $ reduce [] env typ + reduce (arg:stck) env (ForAllTy var typ) = reduce stck ((var,arg) : env) typ -- bind argument from stack to var + reduce _ env (FunTy typ1 typ2) = + let rtyp1 = reduce [] env typ1 + rtyp2 = reduce [] env typ2 + in case typ1 of + -- remove class constraints without free variables to prevent things like (Ord Char => Char) #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) + PredTy _ | isEmptyVarSet (tyVarsOfType rtyp1) -> rtyp2 +#else + TyConApp tycon _ | isClassTyCon tycon && isEmptyVarSet (tyVarsOfType rtyp1) -> rtyp2 +#endif + _ -> FunTy rtyp1 rtyp2 +#if __GLASGOW_HASKELL__ < 704 + -- before ghc 7.4, constraints were encoded with a PredTy constructor + reduce _ env (PredTy pt) = PredTy $ reducePredType pt + where reducePredType (ClassP c ts) = ClassP c $ map (reduce [] env) ts + reducePredType (IParam i t) = IParam i (reduce [] env t) + reducePredType (EqPred t1 t2) = EqPred (reduce [] env t1) (reduce [] env t2) + +#if __GLASGOW_HASKELL__ < 702 + +-- before ghc 7.2, tyVarsOfType was not defined. The code below comes from the ghc-7.2.2 version of TypeRep.hs. +tyVarsOfType :: Type -> VarSet +-- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym +tyVarsOfType (TyVarTy v) = unitVarSet v +tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys +tyVarsOfType (PredTy sty) = varsOfPred tyVarsOfType sty +tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res +tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg +tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar + +tyVarsOfTypes :: [Type] -> TyVarSet +tyVarsOfTypes tys = foldr (unionVarSet . tyVarsOfType) emptyVarSet tys + +varsOfPred :: (Type -> VarSet) -> PredType -> VarSet +varsOfPred f (IParam _ ty) = f ty +varsOfPred f (ClassP _ tys) = foldr (unionVarSet . f) emptyVarSet tys +varsOfPred f (EqPred ty1 ty2) = f ty1 `unionVarSet` f ty2 #endif - +#endif
src/Language/Haskell/BuildWrapper/Src.hs view
@@ -15,7 +15,8 @@ import Language.Haskell.BuildWrapper.Base import Language.Haskell.Exts.Annotated - +import Language.Haskell.Exts.Parser +import qualified Language.Haskell.Exts.Syntax as S import qualified Data.Map as DM import qualified Data.Text as T @@ -30,12 +31,20 @@ -- we add MultiParamTypeClasses because we may need it if the module we're parsing uses a type class with multiple parameters, which doesn't require the PRAGMA (only in the module DEFINING the type class) -- we add PatternGuards since GHC only gives a warning if not explicit -- we cannot add all the extensions because some conflict (NewQualifiedOperators breaks code with old operator syntax I think) - let exts=MultiParamTypeClasses : PatternGuards : map (\x->classifyExtension $ if isPrefixOf "-X" x then tail $ tail x else x) options - let extsFull=if "-fglasgow-exts" `elem` options + let + -- Parse options from options pragmas in source, since haskell-src-exts does not do it for us + input' = dropWhile (=='\n') . dropWhile (/='\n') $ input -- remove the first line, added by runCpphs (file: #line 1 "...") + topPragmas = case getTopPragmas input' of + ParseOk pragmas -> pragmas + _ -> [] + optionsPragmas = [ optionsPragma | S.OptionsPragma _ _ optionsPragma <- topPragmas ] + optionsFromPragmas = concatMap words optionsPragmas + exts=MultiParamTypeClasses : PatternGuards : (map (\x->classifyExtension $ if "-X" `isPrefixOf` x then tail $ tail x else x) $ options ++ optionsFromPragmas) + extsFull=if "-fglasgow-exts" `elem` options ++ optionsFromPragmas then exts ++ glasgowExts - else 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 parseMode=defaultParseMode {extensions=extsFull,ignoreLinePragmas=False,ignoreLanguagePragmas=False,fixities = Just baseFixities} + else exts + -- fixities necessary (see http://trac.haskell.org/haskell-src-exts/ticket/189 and https://sourceforge.net/projects/eclipsefp/forums/forum/371922/topic/4808590) + parseMode=defaultParseMode {extensions=extsFull,ignoreLinePragmas=False,ignoreLanguagePragmas=False,fixities = Just baseFixities} return $ parseFileContentsWithComments parseMode input -- | get the ouline from the AST
test/Language/Haskell/BuildWrapper/APITest.hs view
@@ -63,7 +63,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 "test.cabal" "cabal.exe" "" 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" (mkEmptySpan "Main.hs" 2 3)) (head notes) )) @@ -72,7 +72,7 @@ let s="Linking D:\\Documents\\Perso\\workspace\\HJVM\\.dist-buildwrapper\\dist\\build\\hjvm-test\\hjvm-test.exe ...\nD:\\Documents\\Perso\\workspace\\HJVM\\.dist-buildwrapper\\dist\\build/libHSHJVM-0.1.a(hjvm.o):hjvm.c:(.text+0x1d): undefined reference to `_imp__JNI_GetCreatedJavaVMs@12'\ncollect2: ld returned 1 exit status\n" let notes=Cabal.parseBuildMessages "test.cabal" "cabal.exe" "D:\\Documents\\Perso\\workspace\\HJVM\\.dist-buildwrapper\\dist" s assertEqual "not 1 note" 1 (length notes) - assertEqual "not expected note" (BWNote BWError "hjvm.c:(.text+0x1d): undefined reference to `_imp__JNI_GetCreatedJavaVMs@12'\n" (BWLocation "test.cabal" 1 1)) (head notes) + assertEqual "not expected note" (BWNote BWError "hjvm.c:(.text+0x1d): undefined reference to `_imp__JNI_GetCreatedJavaVMs@12'\n" (mkEmptySpan "test.cabal" 1 1)) (head notes) )) testParseBuildMessagesCabal :: Test @@ -80,7 +80,7 @@ let s="cabal.exe: HJVM-0.1: library-dirs: src is a relative path (use --force\nto override)\n" let notes=Cabal.parseBuildMessages "test.cabal" "cabal.exe" "" s assertEqual "not 1 note" 1 (length notes) - assertEqual "not expected note" (BWNote BWError "HJVM-0.1: library-dirs: src is a relative path (use --force\nto override)\n" (BWLocation "test.cabal" 1 1)) (head notes) + assertEqual "not expected note" (BWNote BWError "HJVM-0.1: library-dirs: src is a relative path (use --force\nto override)\n" (mkEmptySpan "test.cabal" 1 1)) (head notes) )) testParseConfigureMessages :: Test @@ -88,5 +88,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" (mkEmptySpan "test.cabal" 1 1)) (head notes) ))
test/Language/Haskell/BuildWrapper/CMDTests.hs view
@@ -45,24 +45,28 @@ 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= runAPI r "thingatpoint" ["--file="++fp,"--line="++ show l,"--column="++ show c] + getThingAtPoint _ r fp l c= fmap removeLayoutTAP $ 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" [] generateUsage _ r retAll cc=runAPI r "generateusage" ["--returnall="++ show retAll,"--cabalcomponent="++ cabalComponentName cc] - -exeExtension :: String -#ifdef mingw32_HOST_OS -exeExtension = "exe" -#else -exeExtension = "" -#endif - + +removeLayoutTAP :: OpResult (Maybe ThingAtPoint) -> OpResult (Maybe ThingAtPoint) +removeLayoutTAP res = case res of + (Just tap@ThingAtPoint{tapType=tp,tapQType=qtp},xs) -> + (Just tap{tapType=removeLayout tp, tapQType=removeLayout qtp},xs) + _ -> res + where removeLayout (Just tp) = Just $ unwords . concatMap words . lines $ tp -- replace sequences of spaces and newlines by single space + removeLayout Nothing = Nothing + runAPI:: (FromJSON a,Show a) => FilePath -> String -> [String] -> IO a runAPI root command args= do + cd<-getCurrentDirectory 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 "" + setCurrentDirectory root + (ex,out,err)<-readProcessWithExitCode (cd </> head exePath) fullargs "" + setCurrentDirectory cd putStrLn ("out:"++out) putStrLn ("err:"++err) assertEqual ("returned error: "++show fullargs++"\n:"++show err) ExitSuccess ex
test/Language/Haskell/BuildWrapper/Tests.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings #-} -- | -- Module : Language.Haskell.BuildWrapper.Tests -- Author : JP Moresmau @@ -50,8 +50,10 @@ testOutlineOperator, testOutlinePatternGuards, testOutlineExtension, + testOutlineOptions, testPreviewTokenTypes, testThingAtPoint, + testThingAtPointTypeReduction, testThingAtPointNotInCabal, testThingAtPointMain, testThingAtPointMainSubFolder, @@ -82,7 +84,14 @@ getCabalDependencies :: a -> FilePath -> IO (OpResult [(FilePath,[CabalPackage])]) getCabalComponents :: a -> FilePath -> IO (OpResult [CabalComponent]) generateUsage :: a -> FilePath -> Bool -> CabalComponent -> IO (OpResult (Maybe [FilePath])) - + +exeExtension :: String +#ifdef mingw32_HOST_OS +exeExtension = "exe" +#else +exeExtension = "" +#endif + testSynchronizeAll :: (APIFacade a)=> a -> Test testSynchronizeAll api= TestLabel "testSynchronizeAll" (TestCase ( do root<-createTestProject @@ -151,8 +160,8 @@ 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 - assertEqual "not proper error 2" (BWNote BWError "No executables and no library found. Nothing to do.\n" (BWLocation cfn 1 1)) nsError2 + assertEqual "not proper error 1" (BWNote BWError "No 'name' field.\n" (mkEmptySpan cfn 1 1)) nsError1 + assertEqual "not proper error 2" (BWNote BWError "No executables and no library found. Nothing to do.\n" (mkEmptySpan cfn 1 1)) nsError2 writeFile cf $ unlines ["name: 4 P1", "version:0.1", "build-type: Simple"] @@ -161,7 +170,7 @@ 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 + assertEqual "not proper error 3" (BWNote BWError "Parse of field 'name' failed.\n" (mkEmptySpan cfn 1 1)) nsError3 writeFile cf $ unlines ["name: "++testProjectName, "version:0.1", "cabal-version: >= 1.8", @@ -177,7 +186,7 @@ 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 + assertEqual "not proper error 4" (BWNote BWError "At least the following dependencies are missing:\ntoto -any\n" (mkEmptySpan cfn 1 1)) nsError4 writeFile cf $ unlines ["name: "++testProjectName, "version:0.1", @@ -194,12 +203,12 @@ 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 + assertEqual "not proper error 5" (BWNote BWError "At least the following dependencies are missing:\ntiti -any, toto -any\n" (mkEmptySpan cfn 1 1)) nsError5 (BuildResult bool4b _,nsErrors4b)<-build api root False Source 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 + assertEqual "not proper error 5b" (BWNote BWError "At least the following dependencies are missing:\ntiti -any, toto -any\n" (mkEmptySpan cfn 1 1)) nsError5b writeFile cf $ unlines ["name: "++testProjectName, "version:0.1", "cabal-version: >= 1.8", @@ -214,7 +223,7 @@ 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 + assertEqual "not proper error 6" (BWNote BWError "No 'Main-Is' field found for executable BWTest\n" (mkEmptySpan cfn 1 1)) nsError6 )) @@ -240,7 +249,7 @@ 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 + 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" (mkEmptySpan cfn 5 1)) nsWarning1 writeFile cf $ unlines ["name: "++testProjectName, "version:0.1", "build-type: Simple", @@ -255,7 +264,7 @@ 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 + assertEqual "not proper warning 2" (BWNote BWWarning "A package using section syntax must specify at least\n'cabal-version: >= 1.2'.\n" (mkEmptySpan cfn 1 1)) nsWarning2 writeFile cf $ unlines ["name: "++testProjectName, "version:0.1", "cabal-version: >= 1.2", @@ -272,7 +281,7 @@ 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 + 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" (mkEmptySpan cfn 1 1)) nsWarning3 )) @@ -295,12 +304,12 @@ assertBool "returned true on bool1_1" (isNothing bool11) assertBool "no errors or warnings on nsErrors11" (not $ null nsErrors11) let (nsError11:[])=nsErrors11 - assertEqualNotesWithoutSpaces "not proper error 1_1" (BWNote BWError "parse error on input `toto'\n" (BWLocation rel 2 8)) nsError11 + assertEqualNotesWithoutSpaces "not proper error 1_1" (BWNote BWError "parse error on input `toto'\n" (mkEmptySpan rel 2 8)) nsError11 (BuildResult bool1 _,nsErrors1)<-build api root False Source assertBool "returned true on bool1" (not bool1) assertBool "no errors or warnings on nsErrors1" (not $ null nsErrors1) let (nsError1:[])=nsErrors1 - assertEqualNotesWithoutSpaces "not proper error 1" (BWNote BWError "parse error on input `toto'\n" (BWLocation rel 2 8)) nsError1 + assertEqualNotesWithoutSpaces "not proper error 1" (BWNote BWError "parse error on input `toto'\n" (mkEmptySpan rel 2 8)) nsError1 -- write file and synchronize writeFile (root </> "src"</>"A.hs")$ unlines ["module A where","import Toto","fA=undefined"] @@ -310,20 +319,20 @@ 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 + 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" (mkEmptySpan rel 2 8)) nsError2 synchronize1 api root True rel (bool21,nsErrors21)<-build1 api root rel assertBool "returned true on bool21" (isNothing bool21) assertBool "no errors or warnings on nsErrors2_1" (not $ null nsErrors21) let (nsError21:[])=nsErrors21 - assertEqualNotesWithoutSpaces "not proper error 2_1" (BWNote BWError "Could not find module `Toto':\n Use -v to see a list of the files searched for.\n" (BWLocation rel 2 8)) nsError21 + assertEqualNotesWithoutSpaces "not proper error 2_1" (BWNote BWError "Could not find module `Toto':\n Use -v to see a list of the files searched for.\n" (mkEmptySpan rel 2 8)) nsError21 (_,nsErrors3f)<- getBuildFlags api root ("src"</>"A.hs") assertBool ("errors or warnings on nsErrors3f:" ++ show nsErrors3f) (null nsErrors3f) (bool3,nsErrors3)<-build1 api root rel assertBool "returned true on bool3" (isNothing 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 + assertEqualNotesWithoutSpaces "not proper error 3" (BWNote BWError "Could not find module `Toto':\n Use -v to see a list of the files searched for." (mkEmptySpan rel 2 8)) nsError3 )) @@ -355,16 +364,16 @@ 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 + 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" (mkEmptySpan rel 2 1)) nsError1 + assertEqualNotesWithoutSpaces "not proper error 2" (BWNote BWWarning "Top-level binding with no type signature:\n fA :: forall a. a\n" (mkEmptySpan rel 3 1)) nsError2 (_,nsErrors3f)<-getBuildFlags api root rel assertBool "errors or warnings on nsErrors3f" (null nsErrors3f) (bool3,nsErrors3)<-build1 api root rel assertBool "returned false on bool3" (isJust 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 + 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()" (mkEmptySpan rel 2 1)) nsError3 + assertEqualNotesWithoutSpaces "not proper error 4" (BWNote BWWarning "Top-level binding with no type signature:\n fA :: forall a. a" (mkEmptySpan 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 mf3) @@ -372,7 +381,7 @@ assertBool "returned false on bool4" (isJust 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 "++rel++":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") (mkEmptySpan rel 4 5)) nsError5 )) testBuildOutput :: (APIFacade a)=> a -> Test @@ -823,6 +832,37 @@ assertBool ("errors or warnings on getOutline:"++show nsErrors1) (null nsErrors1) assertBool "no outline" (not $ null ors) )) + +testOutlineOptions :: (APIFacade a)=> a -> Test +testOutlineOptions api= TestLabel "testOutlineOptions" (TestCase ( do + root<-createTestProject + synchronize api root False + let rel="src"</>"A.hs" + write api root rel $ unlines [ + "{-# OPTIONS -XMultiParamTypeClasses -XTupleSections -XRank2Types -XScopedTypeVariables -XTypeOperators #-}", + "module A where", + "-- MultiParamTypeClasses", + "class C a b", + "-- TupleSections", + "test1 = ((),)", + "-- Rank2Types", + "test2 :: (forall a . a) -> b", + "test2 a = undefined", + "-- TypeOperators", + "type a :-: b = (a,b)", + "-- ScopedTypeVariables", + "test3 :: forall a . a -> a", + "test3 x = x :: a" + ] + (_,nsErrors3f)<-getBuildFlags api root rel + assertBool "errors or warnings on nsErrors3f" (null nsErrors3f) + (bool3,nsErrors3)<-build1 api root rel + assertBool "returned false on bool3" (isJust bool3) + assertBool ("errors on nsErrors3"++ show nsErrors3) (not (any (\ x -> BWError == bwnStatus x) nsErrors3)) + (OutlineResult ors _ _,nsErrors1)<-getOutline api root rel + assertBool ("errors or warnings on getOutline:"++show nsErrors1) (null nsErrors1) + assertBool "no outline" (not $ null ors) + )) testPreviewTokenTypes :: (APIFacade a)=> a -> Test testPreviewTokenTypes api= TestLabel "testPreviewTokenTypes" (TestCase ( do @@ -876,8 +916,8 @@ 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 qtype" (Just "(GHC.Types.Char -> GHC.Types.Char) -> [GHC.Types.Char] -> [GHC.Types.Char]") (tapQType $ fromJust tap1) + assertEqual "not type" (Just "(Char -> Char) -> [Char] -> [Char]") (tapType $ fromJust tap1) assertEqual "not htype" (Just "v") (tapHType $ fromJust tap1) assertEqual "not gtype" (Just "Var") (tapGType $ fromJust tap1) @@ -898,6 +938,8 @@ assertEqual "not htype3" (Just "t") (tapHType $ fromJust tap3) assertEqual "qtype DataT" Nothing (tapQType $ fromJust tap3) +#if __GLASGOW_HASKELL__ < 704 + -- type information for constructors at the declaration is not supported by ghc 7.4 (tap4,nsErrors4)<-getThingAtPoint api root rel 4 14 assertBool ("errors or warnings on getThingAtPoint4:"++show nsErrors4) (null nsErrors4) assertBool "not just tap4" (isJust tap4) @@ -907,7 +949,8 @@ assertEqual "gtype MkData" (Just "DataCon") (tapGType $ fromJust tap4) assertEqual "type MkData" (Just "String -> DataT") (tapType $ fromJust tap4) assertEqual "qtype MkData" (Just "GHC.Base.String -> Main.DataT") (tapQType $ fromJust tap4) - +#endif + (tap5,nsErrors5)<-getThingAtPoint api root rel 4 22 assertBool ("errors or warnings on getThingAtPoint5:"++show nsErrors5) (null nsErrors5) assertBool "not just tap5" (isJust tap5) @@ -923,7 +966,9 @@ assertEqual "not Main" (Just "Main") (tapModule $ fromJust tap6) assertEqual "not htype6" (Just "t") (tapHType $ fromJust tap6) assertEqual "qtype Toot" Nothing (tapQType $ fromJust tap6) - + +#if __GLASGOW_HASKELL__ < 704 + -- type information for constructors at the declaration is not supported by ghc 7.4 (tap7,nsErrors7)<-getThingAtPoint api root rel 6 14 assertBool ("errors or warnings on getThingAtPoint7:"++show nsErrors7) (null nsErrors7) assertBool "not just tap7" (isJust tap7) @@ -932,6 +977,7 @@ assertEqual "not htype7" (Just "v") (tapHType $ fromJust tap7) assertEqual "qtype Toot" (Just "GHC.Base.String -> Main.Toot") (tapQType $ fromJust tap7) + -- type information for field names at the declaration is not supported by ghc 7.4 (tap8,nsErrors8)<-getThingAtPoint api root rel 6 19 assertBool ("errors or warnings on getThingAtPoint8:"++show nsErrors8) (null nsErrors8) assertBool "not just tap8" (isJust tap8) @@ -939,8 +985,8 @@ assertEqual "not Main" (Just "Main") (tapModule $ fromJust tap8) assertEqual "not htype8" (Just "v") (tapHType $ fromJust tap8) assertEqual "qtype toot" (Just "Main.Toot -> GHC.Base.String") (tapQType $ fromJust tap8) - - +#endif + (tap9,nsErrors9)<-getThingAtPoint api root rel 9 5 assertBool ("errors or warnings on getThingAtPoint9:"++show nsErrors9) (null nsErrors9) assertBool "not just tap9" (isJust tap9) @@ -948,9 +994,41 @@ assertEqual "not empty module" (Just "") (tapModule $ fromJust tap9) assertEqual "not htype9" (Just "v") (tapHType $ fromJust tap9) assertEqual "qtype l2" (Just "[GHC.Types.Char]") (tapQType $ fromJust tap9) - - - + )) + +testThingAtPointTypeReduction :: (APIFacade a)=> a -> Test +testThingAtPointTypeReduction api= TestLabel "testThingAtPointTypeReduction" (TestCase ( do + root<-createTestProject + let cf=testCabalFile root + writeFile cf $ unlines ["name: "++testProjectName, + "version:0.1", + "cabal-version: >= 1.8", + "build-type: Simple", + "", + "executable BWTest", + " hs-source-dirs: src", + " main-is: Main.hs", + " build-depends: base, containers"] + let rel="src"</>"Main.hs" + synchronize api root False + configure api root Source + write api root rel $ unlines [ + "module Main where", + "import qualified Data.Map as M", + "main=putStrLn \"M\"", + "", + "fun1 :: M.Map String Int", + "fun1 = M.insert \"key\" 1 M.empty" + ] + (_,nsErrorsMf)<-getBuildFlags api root rel + assertBool "errors or warnings on nsErrorsMf" (null nsErrorsMf) + (tapM,nsErrorsM)<-getThingAtPoint api root rel 6 13 + assertBool ("errors or warnings on getThingAtPointM:"++show nsErrorsM) (null nsErrorsM) + assertBool "not just tapM" (isJust tapM) + assertEqual "not insert" "insert" (tapName $ fromJust tapM) + assertEqual "not Data.Map module" (Just "Data.Map") (tapModule $ fromJust tapM) + assertEqual "not htypeM" (Just "v") (tapHType $ fromJust tapM) + assertEqual "qtype insert" (Just "GHC.Base.String -> GHC.Types.Int -> Data.Map.Map GHC.Base.String GHC.Types.Int -> Data.Map.Map GHC.Base.String GHC.Types.Int") (tapQType $ fromJust tapM) )) testThingAtPointNotInCabal :: (APIFacade a)=> a -> Test @@ -992,7 +1070,7 @@ "main=return $ head [2,3,4]" ] synchronize api root False - configure api root Target + configure api root Target (bf3,nsErrors3f)<-getBuildFlags api root rel assertBool "errors or warnings on nsErrors3f" (null nsErrors3f) assertEqual "not main module" (Just "Main") (bfModName bf3) @@ -1157,7 +1235,7 @@ 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 qtype" (Just "(GHC.Types.Char -> GHC.Types.Char) -> [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) @@ -1229,7 +1307,8 @@ (cps,nsOK)<-getCabalDependencies api root assertBool ("errors or warnings on getCabalDependencies:"++show nsOK) (null nsOK) assertEqual "not two databases" 2 (length cps) - let (_:(_,pkgs):[])=cps + let [(_,pkgs1),(_,pkgs2)] = cps -- One is global and one is local, but the order depends on the paths, + pkgs = pkgs1 ++ pkgs2 -- so we concatenate the two. let base=filter (\pkg->cpName pkg == "base") pkgs assertEqual "not 1 base" 1 (length base) let (l:ex:ts:[])=cpDependent $ head base @@ -1308,14 +1387,14 @@ ] configure api root Source build api root True Source - let exePath=root </> ".dist-buildwrapper" </> "dist" </> "build" </> testProjectName </> "BWTest.exe" + let exePath=root </> ".dist-buildwrapper" </> "dist" </> "build" </> testProjectName </> "BWTest" <.> exeExtension ex1<-doesFileExist exePath assertBool "exe exists!" (not ex1) configureWithFlags api root Source "server" build api root True Source ex2<-doesFileExist exePath - assertBool "exe doesn't exists!" ex2 + assertBool "exe doesn't exist!" ex2 )) @@ -1394,6 +1473,12 @@ testTestAContents :: String testTestAContents=unlines ["module TestA where","fTA=undefined"] +testSetupContents ::String +testSetupContents = unlines ["#!/usr/bin/env runhaskell", + "import Distribution.Simple", + "main :: IO ()", + "main = defaultMain"] + createTestProject :: IO FilePath createTestProject = do temp<-getTemporaryDirectory @@ -1402,6 +1487,7 @@ when ex (removeDirectoryRecursive root) createDirectory root writeFile (testCabalFile root) testCabalContents + writeFile (root </> "Setup.hs") testSetupContents let srcF=root </> "src" createDirectory srcF writeFile (srcF </> "A.hs") testAContents