Revert "rts: Drop redundant flags for libffi"
[ghc.git] / testsuite / tests / ghc-api / T6145.hs
1 {-# LANGUAGE PatternGuards #-}
2 {-# LANGUAGE ViewPatterns #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE TypeFamilies #-}
5 module Main where
6
7 import System.IO
8 import GHC
9 import MonadUtils
10 import Outputable
11 import Bag (filterBag,isEmptyBag)
12 import System.Directory (removeFile)
13 import System.Environment( getArgs )
14
15 main::IO()
16 main = do
17 let c="module Test where\ndata DataT=MkData {name :: String}\n"
18 writeFile "Test.hs" c
19 [libdir] <- getArgs
20 ok<- runGhc (Just libdir) $ do
21 dflags <- getSessionDynFlags
22 setSessionDynFlags dflags
23 let mn =mkModuleName "Test"
24 addTarget Target { targetId = TargetModule mn, targetAllowObjCode = True, targetContents = Nothing }
25 load LoadAllTargets
26 modSum <- getModSummary mn
27 p <- parseModule modSum
28 t <- typecheckModule p
29 d <- desugarModule t
30 l <- loadModule d
31 let ts=typecheckedSource l
32 -- liftIO (putStr (showSDocDebug (ppr ts)))
33 let fs=filterBag isDataCon ts
34 return $ not $ isEmptyBag fs
35 removeFile "Test.hs"
36 print ok
37 where
38 isDataCon (L _ (AbsBinds { abs_binds = bs }))
39 = not (isEmptyBag (filterBag isDataCon bs))
40 isDataCon (L l (f@FunBind {}))
41 | (MG _ (L _ (m:_)) _) <- fun_matches f,
42 ((L _ (c@ConPatOut{})):_)<-hsLMatchPats m,
43 (L l _)<-pat_con c
44 = isGoodSrcSpan l -- Check that the source location is a good one
45 isDataCon _
46 = False