Permalink
Browse files

cannot add all extensions or operator syntax break

  • Loading branch information...
1 parent a03d49c commit c33a9b116dd284d75ef61f39cb46073866e0cdf2 @JPMoresmau committed Apr 3, 2012
@@ -125,7 +125,7 @@ getAST fp=do
(bf,ns)<-getBuildFlags fp
tgt<-getTargetPath fp
input<-liftIO $ preproc bf tgt
- pr<- liftIO $ getHSEAST input -- (bf_ast bf)
+ pr<- liftIO $ getHSEAST input (bf_ast bf)
return (Just pr,ns)
-- | get GHC typechecked AST for source file
@@ -24,15 +24,15 @@ import Data.List (foldl')
-- | get the AST
getHSEAST :: String -- ^ input text
+ -> [String] -- ^ options
-> IO (ParseResult (Module SrcSpanInfo, [Comment]))
-getHSEAST input =do
- -- -> [String] -- ^ options
- -- options
- --let exts=MultiParamTypeClasses : map classifyExtension options
- --let extsFull=if "-fglasgow-exts" `elem` options
- -- then exts ++ glasgowExts
- -- else exts
- let extsFull=knownExtensions
+getHSEAST input options=do
+ -- 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 cannot add all the extensions because some conflict (NewQualifiedOperators breaks code with old operator syntax I think)
+ let exts=MultiParamTypeClasses : map classifyExtension options
+ let extsFull=if "-fglasgow-exts" `elem` options
+ 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}
return $ parseFileContentsWithComments parseMode input
@@ -45,6 +45,7 @@ tests= [
testOutlineLiterate,
testOutlineComments,
testOutlineMultiParam,
+ testOutlineOperator,
testPreviewTokenTypes,
testThingAtPoint ,
testThingAtPointNotInCabal,
@@ -692,6 +693,28 @@ testOutlineMultiParam api= TestLabel "testOutlineMultiParam" (TestCase ( do
assertBool ("errors or warnings on getOutline:"++show nsErrors1) (null nsErrors1)
assertBool "no outline" (not $ null or)
))
+
+testOutlineOperator :: (APIFacade a)=> a -> Test
+testOutlineOperator api= TestLabel "testOutlineMultiParam" (TestCase ( do
+ root<-createTestProject
+ synchronize api root False
+ let rel="src"</>"A.hs"
+ write api root rel $ unlines [
+ "{-# LANGUAGE MultiParamTypeClasses #-}",
+ "module A ( Collection (",
+ " (>-)",
+ " )",
+ " )where",
+ " infixl 5 >-",
+ " class Collection a where",
+ " (>-) :: Eq b => a b -> a b -> a b"
+ ]
+ (_,nsErrors3f)<-getBuildFlags api root rel
+ assertBool "errors or warnings on nsErrors3f" (null nsErrors3f)
+ (OutlineResult or _ _,nsErrors1)<-getOutline api root rel
+ assertBool ("errors or warnings on getOutline:"++show nsErrors1) (null nsErrors1)
+ assertBool "no outline" (not $ null or)
+ ))
testPreviewTokenTypes :: (APIFacade a)=> a -> Test
testPreviewTokenTypes api= TestLabel "testPreviewTokenTypes" (TestCase ( do

0 comments on commit c33a9b1

Please sign in to comment.