{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}

module HSE.All(
    module X,
    CppFlags(..), ParseFlags(..), defaultParseFlags,
    parseFlagsAddFixities, parseFlagsSetLanguage,
    ParseError(..), ModuleEx(..),
    parseModuleEx, ghcComments,
    freeVars, vars, varss, pvars,
    ghcSpanToHSE, ghcSrcLocToHSE,
    parseExpGhcWithMode, parseImportDeclGhcWithMode
    ) where

import Language.Haskell.Exts.Util hiding (freeVars, Vars(..))
import qualified Language.Haskell.Exts.Util as X
import HSE.Util as X
import HSE.Type as X
import HSE.Match as X
import HSE.Scope as X
import Util
import Data.Char
import Data.List.Extra
import Data.Maybe
import Timing
import Language.Preprocessor.Cpphs
import Data.Either
import Data.Set (Set)
import qualified Data.Map as Map
import qualified Data.Set as Set
import System.IO.Extra
import Data.Functor
import Prelude

import qualified HsSyn
import qualified FastString
import qualified SrcLoc as GHC
import qualified ErrUtils
import qualified Outputable
import qualified Lexer as GHC
import qualified GHC.LanguageExtensions.Type as GHC
import qualified ApiAnnotation as GHC
import qualified BasicTypes as GHC
import qualified DynFlags as GHC

import GHC.Util
import qualified Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx

-- | Convert a GHC source loc into an HSE equivalent.
ghcSrcLocToHSE :: GHC.SrcLoc -> SrcLoc
ghcSrcLocToHSE :: SrcLoc -> SrcLoc
ghcSrcLocToHSE (GHC.RealSrcLoc l :: RealSrcLoc
l) =
  SrcLoc :: String -> Int -> Int -> SrcLoc
SrcLoc {
      srcFilename :: String
srcFilename = FastString -> String
FastString.unpackFS (RealSrcLoc -> FastString
GHC.srcLocFile RealSrcLoc
l)
    , srcLine :: Int
srcLine = RealSrcLoc -> Int
GHC.srcLocLine RealSrcLoc
l
    , srcColumn :: Int
srcColumn = RealSrcLoc -> Int
GHC.srcLocCol RealSrcLoc
l
    }
ghcSrcLocToHSE (GHC.UnhelpfulLoc _) = SrcLoc
noLoc

-- | Convert a GHC source span into an HSE equivalent.
ghcSpanToHSE :: GHC.SrcSpan -> SrcSpan
ghcSpanToHSE :: SrcSpan -> SrcSpan
ghcSpanToHSE (GHC.RealSrcSpan s :: RealSrcSpan
s) =
  SrcSpan :: String -> Int -> Int -> Int -> Int -> SrcSpan
SrcSpan {
      srcSpanFilename :: String
srcSpanFilename = FastString -> String
FastString.unpackFS (RealSrcSpan -> FastString
GHC.srcSpanFile RealSrcSpan
s)
    , srcSpanStartLine :: Int
srcSpanStartLine = RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
s
    , srcSpanStartColumn :: Int
srcSpanStartColumn = RealSrcSpan -> Int
GHC.srcSpanStartCol RealSrcSpan
s
    , srcSpanEndLine :: Int
srcSpanEndLine = RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
s
    , srcSpanEndColumn :: Int
srcSpanEndColumn = RealSrcSpan -> Int
GHC.srcSpanEndCol RealSrcSpan
s
    }
ghcSpanToHSE (GHC.UnhelpfulSpan _) = SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
noLoc SrcLoc
noLoc

vars :: FreeVars a => a -> [String]
freeVars :: FreeVars a => a -> Set String
varss, pvars :: AllVars a => a -> [String]
vars :: a -> [String]
vars  = Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String -> [String]) -> (a -> Set String) -> a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name () -> String) -> Set (Name ()) -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Name () -> String
forall a. Pretty a => a -> String
prettyPrint (Set (Name ()) -> Set String)
-> (a -> Set (Name ())) -> a -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set (Name ())
forall a. FreeVars a => a -> Set (Name ())
X.freeVars
varss :: a -> [String]
varss = Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String -> [String]) -> (a -> Set String) -> a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name () -> String) -> Set (Name ()) -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Name () -> String
forall a. Pretty a => a -> String
prettyPrint (Set (Name ()) -> Set String)
-> (a -> Set (Name ())) -> a -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vars -> Set (Name ())
X.free (Vars -> Set (Name ())) -> (a -> Vars) -> a -> Set (Name ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Vars
forall a. AllVars a => a -> Vars
X.allVars
pvars :: a -> [String]
pvars = Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String -> [String]) -> (a -> Set String) -> a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name () -> String) -> Set (Name ()) -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Name () -> String
forall a. Pretty a => a -> String
prettyPrint (Set (Name ()) -> Set String)
-> (a -> Set (Name ())) -> a -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vars -> Set (Name ())
X.bound (Vars -> Set (Name ())) -> (a -> Vars) -> a -> Set (Name ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Vars
forall a. AllVars a => a -> Vars
X.allVars
freeVars :: a -> Set String
freeVars = (Name () -> String) -> Set (Name ()) -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Name () -> String
forall a. Pretty a => a -> String
prettyPrint (Set (Name ()) -> Set String)
-> (a -> Set (Name ())) -> a -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set (Name ())
forall a. FreeVars a => a -> Set (Name ())
X.freeVars

-- | What C pre processor should be used.
data CppFlags
    = NoCpp -- ^ No pre processing is done.
    | CppSimple -- ^ Lines prefixed with @#@ are stripped.
    | Cpphs CpphsOptions -- ^ The @cpphs@ library is used.

-- | Created with 'defaultParseFlags', used by 'parseModuleEx'.
data ParseFlags = ParseFlags
    {ParseFlags -> CppFlags
cppFlags :: CppFlags -- ^ How the file is preprocessed (defaults to 'NoCpp').
    ,ParseFlags -> ParseMode
hseFlags :: ParseMode -- ^ How the file is parsed (defaults to all fixities in the @base@ package and most non-conflicting extensions).
    }

lensFixities :: [Fixity]
lensFixities :: [Fixity]
lensFixities = [[Fixity]] -> [Fixity]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    -- List as provided at https://github.com/ndmitchell/hlint/issues/416
    [Int -> [String] -> [Fixity]
infixr_ 4 ["%%@~","<%@~","%%~","<+~","<*~","<-~","<//~","<^~","<^^~","<**~"]
    ,Int -> [String] -> [Fixity]
infix_ 4 ["%%@=","<%@=","%%=","<+=","<*=","<-=","<//=","<^=","<^^=","<**="]
    ,Int -> [String] -> [Fixity]
infixr_ 2 ["<<~"]
    ,Int -> [String] -> [Fixity]
infixr_ 9 ["#."]
    ,Int -> [String] -> [Fixity]
infixl_ 8 [".#"]
    ,Int -> [String] -> [Fixity]
infixr_ 8 ["^!","^@!"]
    ,Int -> [String] -> [Fixity]
infixl_ 1 ["&","<&>","??"]
    ,Int -> [String] -> [Fixity]
infixl_ 8 ["^.","^@."]
    ,Int -> [String] -> [Fixity]
infixr_ 9 ["<.>","<.",".>"]
    ,Int -> [String] -> [Fixity]
infixr_ 4 ["%@~",".~","+~","*~","-~","//~","^~","^^~","**~","&&~","<>~","||~","%~"]
    ,Int -> [String] -> [Fixity]
infix_ 4 ["%@=",".=","+=","*=","-=","//=","^=","^^=","**=","&&=","<>=","||=","%="]
    ,Int -> [String] -> [Fixity]
infixr_ 2 ["<~"]
    ,Int -> [String] -> [Fixity]
infixr_ 2 ["`zoom`","`magnify`"]
    ,Int -> [String] -> [Fixity]
infixl_ 8 ["^..","^?","^?!","^@..","^@?","^@?!"]
    ,Int -> [String] -> [Fixity]
infixl_ 8 ["^#"]
    ,Int -> [String] -> [Fixity]
infixr_ 4 ["<#~","#~","#%~","<#%~","#%%~"]
    ,Int -> [String] -> [Fixity]
infix_ 4 ["<#=","#=","#%=","<#%=","#%%="]
    ,Int -> [String] -> [Fixity]
infixl_ 9 [":>"]
    ,Int -> [String] -> [Fixity]
infixr_ 4 ["</>~","<</>~","<.>~","<<.>~"]
    ,Int -> [String] -> [Fixity]
infix_ 4 ["</>=","<</>=","<.>=","<<.>="]
    ,Int -> [String] -> [Fixity]
infixr_ 4 [".|.~",".&.~","<.|.~","<.&.~"]
    ,Int -> [String] -> [Fixity]
infix_ 4 [".|.=",".&.=","<.|.=","<.&.="]
    ]

otherFixities :: [Fixity]
otherFixities :: [Fixity]
otherFixities = [[Fixity]] -> [Fixity]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    -- hspec
    [Int -> [String] -> [Fixity]
infix_ 1 ["`shouldBe`","`shouldSatisfy`","`shouldStartWith`","`shouldEndWith`","`shouldContain`","`shouldMatchList`"
              ,"`shouldReturn`","`shouldNotBe`","`shouldNotSatisfy`","`shouldNotContain`","`shouldNotReturn`","`shouldThrow`"]
    -- quickcheck
    ,Int -> [String] -> [Fixity]
infixr_ 0 ["==>"]
    ,Int -> [String] -> [Fixity]
infix_ 4 ["==="]
    -- esqueleto
    ,Int -> [String] -> [Fixity]
infix_ 4 ["==."]
    -- lattices
    ,Int -> [String] -> [Fixity]
infixr_ 5 ["\\/"] -- \/
    ,Int -> [String] -> [Fixity]
infixr_ 6 ["/\\"] -- /\
    ]

-- Fixites from the `base` package which are currently
-- missing from `haskell-src-exts`'s baseFixities.
-- see https://github.com/haskell-suite/haskell-src-exts/pull/400
baseNotYetInHSE :: [Fixity]
baseNotYetInHSE :: [Fixity]
baseNotYetInHSE = [[Fixity]] -> [Fixity]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [Int -> [String] -> [Fixity]
infixr_ 9 ["`Compose`"]
    ,Int -> [String] -> [Fixity]
infixr_ 6 ["<>"]
    ,Int -> [String] -> [Fixity]
infixr_ 5 ["<|"]
    ,Int -> [String] -> [Fixity]
infixl_ 4 ["<$!>","<$","$>"]
    ,Int -> [String] -> [Fixity]
infix_ 4 [":~:", ":~~:"]
    ]

customFixities :: [Fixity]
customFixities :: [Fixity]
customFixities =
    Int -> [String] -> [Fixity]
infixl_ 1 ["`on`"]
        -- see https://github.com/ndmitchell/hlint/issues/425
        -- otherwise GTK apps using `on` at a different fixity have spurious warnings

-- | Default value for 'ParseFlags'.
defaultParseFlags :: ParseFlags
defaultParseFlags :: ParseFlags
defaultParseFlags = CppFlags -> ParseMode -> ParseFlags
ParseFlags CppFlags
NoCpp ParseMode
defaultParseMode
    {fixities :: Maybe [Fixity]
fixities = [Fixity] -> Maybe [Fixity]
forall a. a -> Maybe a
Just ([Fixity] -> Maybe [Fixity]) -> [Fixity] -> Maybe [Fixity]
forall a b. (a -> b) -> a -> b
$ [Fixity]
customFixities [Fixity] -> [Fixity] -> [Fixity]
forall a. [a] -> [a] -> [a]
++ [Fixity]
baseFixities [Fixity] -> [Fixity] -> [Fixity]
forall a. [a] -> [a] -> [a]
++ [Fixity]
baseNotYetInHSE [Fixity] -> [Fixity] -> [Fixity]
forall a. [a] -> [a] -> [a]
++ [Fixity]
lensFixities [Fixity] -> [Fixity] -> [Fixity]
forall a. [a] -> [a] -> [a]
++ [Fixity]
otherFixities
    ,ignoreLinePragmas :: Bool
ignoreLinePragmas = Bool
False
    ,ignoreFunctionArity :: Bool
ignoreFunctionArity = Bool
True
    ,extensions :: [Extension]
extensions = [Extension]
parseExtensions}

parseFlagsNoLocations :: ParseFlags -> ParseFlags
parseFlagsNoLocations :: ParseFlags -> ParseFlags
parseFlagsNoLocations x :: ParseFlags
x = ParseFlags
x{cppFlags :: CppFlags
cppFlags = case ParseFlags -> CppFlags
cppFlags ParseFlags
x of Cpphs y :: CpphsOptions
y -> CpphsOptions -> CppFlags
Cpphs (CpphsOptions -> CppFlags) -> CpphsOptions -> CppFlags
forall a b. (a -> b) -> a -> b
$ CpphsOptions -> CpphsOptions
f CpphsOptions
y; y :: CppFlags
y -> CppFlags
y}
    where f :: CpphsOptions -> CpphsOptions
f x :: CpphsOptions
x = CpphsOptions
x{boolopts :: BoolOptions
boolopts = (CpphsOptions -> BoolOptions
boolopts CpphsOptions
x){locations :: Bool
locations=Bool
False}}

-- | Given some fixities, add them to the existing fixities in 'ParseFlags'.
parseFlagsAddFixities :: [Fixity] -> ParseFlags -> ParseFlags
parseFlagsAddFixities :: [Fixity] -> ParseFlags -> ParseFlags
parseFlagsAddFixities fx :: [Fixity]
fx x :: ParseFlags
x = ParseFlags
x{hseFlags :: ParseMode
hseFlags=ParseMode
hse{fixities :: Maybe [Fixity]
fixities = [Fixity] -> Maybe [Fixity]
forall a. a -> Maybe a
Just ([Fixity] -> Maybe [Fixity]) -> [Fixity] -> Maybe [Fixity]
forall a b. (a -> b) -> a -> b
$ [Fixity]
fx [Fixity] -> [Fixity] -> [Fixity]
forall a. [a] -> [a] -> [a]
++ [Fixity] -> Maybe [Fixity] -> [Fixity]
forall a. a -> Maybe a -> a
fromMaybe [] (ParseMode -> Maybe [Fixity]
fixities ParseMode
hse)}}
    where hse :: ParseMode
hse = ParseFlags -> ParseMode
hseFlags ParseFlags
x

parseFlagsSetLanguage :: (Language, [Extension]) -> ParseFlags -> ParseFlags
parseFlagsSetLanguage :: (Language, [Extension]) -> ParseFlags -> ParseFlags
parseFlagsSetLanguage (l :: Language
l, es :: [Extension]
es) x :: ParseFlags
x = ParseFlags
x{hseFlags :: ParseMode
hseFlags=(ParseFlags -> ParseMode
hseFlags ParseFlags
x){baseLanguage :: Language
baseLanguage = Language
l, extensions :: [Extension]
extensions = [Extension]
es}}


runCpp :: CppFlags -> FilePath -> String -> IO String
runCpp :: CppFlags -> String -> String -> IO String
runCpp NoCpp _ x :: String
x = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
x
runCpp CppSimple _ x :: String
x = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [if "#" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String -> String
trimStart String
x then "" else String
x | String
x <- String -> [String]
lines String
x]
runCpp (Cpphs o :: CpphsOptions
o) file :: String
file x :: String
x = String -> String
dropLine (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CpphsOptions -> String -> String -> IO String
runCpphs CpphsOptions
o String
file String
x
    where
        -- LINE pragmas always inserted when locations=True
        dropLine :: String -> String
dropLine (String -> (String, String)
line1 -> (a :: String
a,b :: String
b)) | "{-# LINE " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
a = String
b
        dropLine x :: String
x = String
x

---------------------------------------------------------------------
-- PARSING

-- | A parse error.
data ParseError = ParseError
    { ParseError -> SrcLoc
parseErrorLocation :: SrcLoc -- ^ Location of the error.
    , ParseError -> String
parseErrorMessage :: String  -- ^ Message about the cause of the error.
    , ParseError -> String
parseErrorContents :: String -- ^ Snippet of several lines (typically 5) including a @>@ character pointing at the faulty line.
    }

-- | Result of 'parseModuleEx', representing a parsed module.
data ModuleEx = ModuleEx {
    ModuleEx -> Module SrcSpanInfo
hseModule :: Module SrcSpanInfo
  , ModuleEx -> [Comment]
hseComments :: [Comment]
  , ModuleEx -> Located (HsModule GhcPs)
ghcModule :: GHC.Located (HsSyn.HsModule HsSyn.GhcPs)
  , ModuleEx -> ApiAnns
ghcAnnotations :: GHC.ApiAnns
}

-- | Extract a list of all of a parsed module's comments.
ghcComments :: ModuleEx -> [GHC.Located GHC.AnnotationComment]
ghcComments :: ModuleEx -> [Located AnnotationComment]
ghcComments m :: ModuleEx
m = [[Located AnnotationComment]] -> [Located AnnotationComment]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Map SrcSpan [Located AnnotationComment]
-> [[Located AnnotationComment]]
forall k a. Map k a -> [a]
Map.elems (Map SrcSpan [Located AnnotationComment]
 -> [[Located AnnotationComment]])
-> Map SrcSpan [Located AnnotationComment]
-> [[Located AnnotationComment]]
forall a b. (a -> b) -> a -> b
$ ApiAnns -> Map SrcSpan [Located AnnotationComment]
forall a b. (a, b) -> b
snd (ModuleEx -> ApiAnns
ghcAnnotations ModuleEx
m))

-- | Utility called from 'parseModuleEx' and 'hseFailOpParseModuleEx'.
mkMode :: ParseFlags -> String -> ParseMode
mkMode :: ParseFlags -> String -> ParseMode
mkMode flags :: ParseFlags
flags file :: String
file = (ParseFlags -> ParseMode
hseFlags ParseFlags
flags){ parseFilename :: String
parseFilename = String
file,fixities :: Maybe [Fixity]
fixities = Maybe [Fixity]
forall a. Maybe a
Nothing }

-- | Error handler dispatcher. Invoked when HSE parsing has failed.
failOpParseModuleEx :: String
                    -> ParseFlags
                    -> FilePath
                    -> String
                    -> SrcLoc
                    -> String
                    -> Maybe (GHC.SrcSpan, ErrUtils.MsgDoc)
                    -> IO (Either ParseError ModuleEx)
failOpParseModuleEx :: String
-> ParseFlags
-> String
-> String
-> SrcLoc
-> String
-> Maybe (SrcSpan, MsgDoc)
-> IO (Either ParseError ModuleEx)
failOpParseModuleEx ppstr :: String
ppstr flags :: ParseFlags
flags file :: String
file str :: String
str sl :: SrcLoc
sl msg :: String
msg ghc :: Maybe (SrcSpan, MsgDoc)
ghc =
   case Maybe (SrcSpan, MsgDoc)
ghc of
     Just err :: (SrcSpan, MsgDoc)
err ->
       -- GHC error info is available (assumed to have come from a
       -- 'PFailed'). We prefer to construct a 'ParseError' value
       -- using that.
       String
-> String
-> String
-> (SrcSpan, MsgDoc)
-> IO (Either ParseError ModuleEx)
ghcFailOpParseModuleEx String
ppstr String
file String
str (SrcSpan, MsgDoc)
err
     Nothing ->
       -- No GHC error info provided. This is the traditional approach
       -- to handling errors.
       String
-> ParseFlags
-> String
-> String
-> SrcLoc
-> String
-> IO (Either ParseError ModuleEx)
hseFailOpParseModuleEx String
ppstr ParseFlags
flags String
file String
str SrcLoc
sl String
msg

-- | An error handler of last resort. This is invoked when HSE parsing
-- has failed but apparently GHC has not!
hseFailOpParseModuleEx :: String
                       -> ParseFlags
                       -> FilePath
                       -> String
                       -> SrcLoc
                       -> String
                       -> IO (Either ParseError ModuleEx)
hseFailOpParseModuleEx :: String
-> ParseFlags
-> String
-> String
-> SrcLoc
-> String
-> IO (Either ParseError ModuleEx)
hseFailOpParseModuleEx ppstr :: String
ppstr flags :: ParseFlags
flags file :: String
file str :: String
str sl :: SrcLoc
sl msg :: String
msg = do
    ParseFlags
flags <- ParseFlags -> IO ParseFlags
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseFlags -> IO ParseFlags) -> ParseFlags -> IO ParseFlags
forall a b. (a -> b) -> a -> b
$ ParseFlags -> ParseFlags
parseFlagsNoLocations ParseFlags
flags
    String
ppstr2 <- CppFlags -> String -> String -> IO String
runCpp (ParseFlags -> CppFlags
cppFlags ParseFlags
flags) String
file String
str
    let pe :: String
pe = case ParseMode -> String -> ParseResult (Module SrcSpanInfo)
parseFileContentsWithMode (ParseFlags -> String -> ParseMode
mkMode ParseFlags
flags String
file) String
ppstr2 of
               ParseFailed sl2 :: SrcLoc
sl2 _ -> Int -> String -> String
context (SrcLoc -> Int
srcLine SrcLoc
sl2) String
ppstr2
               _ -> Int -> String -> String
context (SrcLoc -> Int
srcLine SrcLoc
sl) String
ppstr
    Either ParseError ModuleEx -> IO (Either ParseError ModuleEx)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError ModuleEx -> IO (Either ParseError ModuleEx))
-> Either ParseError ModuleEx -> IO (Either ParseError ModuleEx)
forall a b. (a -> b) -> a -> b
$ ParseError -> Either ParseError ModuleEx
forall a b. a -> Either a b
Left (ParseError -> Either ParseError ModuleEx)
-> ParseError -> Either ParseError ModuleEx
forall a b. (a -> b) -> a -> b
$ SrcLoc -> String -> String -> ParseError
ParseError SrcLoc
sl String
msg String
pe

-- | The error handler invoked when GHC parsing has failed.
ghcFailOpParseModuleEx :: String
                       -> FilePath
                       -> String
                       -> (GHC.SrcSpan, ErrUtils.MsgDoc)
                       -> IO (Either ParseError ModuleEx)
ghcFailOpParseModuleEx :: String
-> String
-> String
-> (SrcSpan, MsgDoc)
-> IO (Either ParseError ModuleEx)
ghcFailOpParseModuleEx ppstr :: String
ppstr file :: String
file str :: String
str (loc :: SrcSpan
loc, err :: MsgDoc
err) = do
   let sl :: SrcLoc
sl =
         case SrcSpan
loc of
           GHC.RealSrcSpan r :: RealSrcSpan
r ->
             SrcLoc :: String -> Int -> Int -> SrcLoc
SrcLoc { srcFilename :: String
srcFilename = FastString -> String
FastString.unpackFS (RealSrcSpan -> FastString
GHC.srcSpanFile RealSrcSpan
r)
                     , srcLine :: Int
srcLine = RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
r
                     , srcColumn :: Int
srcColumn = RealSrcSpan -> Int
GHC.srcSpanStartCol RealSrcSpan
r }
           GHC.UnhelpfulSpan _ ->
             SrcLoc :: String -> Int -> Int -> SrcLoc
SrcLoc { srcFilename :: String
srcFilename = String
file
                     , srcLine :: Int
srcLine = 1 :: Int
                     , srcColumn :: Int
srcColumn = 1 :: Int }
       pe :: String
pe = Int -> String -> String
context (SrcLoc -> Int
srcLine SrcLoc
sl) String
ppstr
       msg :: String
msg = DynFlags -> MsgDoc -> String
Outputable.showSDoc DynFlags
baseDynFlags (MsgDoc -> String) -> MsgDoc -> String
forall a b. (a -> b) -> a -> b
$
               ErrMsg -> MsgDoc
ErrUtils.pprLocErrMsg (DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
ErrUtils.mkPlainErrMsg DynFlags
baseDynFlags SrcSpan
loc MsgDoc
err)
   Either ParseError ModuleEx -> IO (Either ParseError ModuleEx)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError ModuleEx -> IO (Either ParseError ModuleEx))
-> Either ParseError ModuleEx -> IO (Either ParseError ModuleEx)
forall a b. (a -> b) -> a -> b
$ ParseError -> Either ParseError ModuleEx
forall a b. a -> Either a b
Left (ParseError -> Either ParseError ModuleEx)
-> ParseError -> Either ParseError ModuleEx
forall a b. (a -> b) -> a -> b
$ SrcLoc -> String -> String -> ParseError
ParseError SrcLoc
sl String
msg String
pe

-- A hacky function to get fixities from HSE parse flags suitable for
-- use by our own 'GHC.Util.Refact.Fixity' module.
ghcFixitiesFromParseMode :: ParseMode -> [(String, GHC.Fixity)]
ghcFixitiesFromParseMode :: ParseMode -> [(String, Fixity)]
ghcFixitiesFromParseMode ParseMode {fixities :: ParseMode -> Maybe [Fixity]
fixities=Just fixities :: [Fixity]
fixities} =
  (Fixity -> [(String, Fixity)]) -> [Fixity] -> [(String, Fixity)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Fixity -> [(String, Fixity)]
convert [Fixity]
fixities
  where
    convert :: Fixity -> [(String, Fixity)]
convert (Fixity (AssocNone _) fix :: Int
fix name :: QName ()
name) = Int -> [String] -> [(String, Fixity)]
infix_' Int
fix [QName () -> String
qNameToStr QName ()
name]
    convert (Fixity (AssocLeft _) fix :: Int
fix name :: QName ()
name) = Int -> [String] -> [(String, Fixity)]
infixl_' Int
fix [QName () -> String
qNameToStr QName ()
name]
    convert (Fixity (AssocRight _) fix :: Int
fix name :: QName ()
name) = Int -> [String] -> [(String, Fixity)]
infixr_' Int
fix [QName () -> String
qNameToStr QName ()
name]

    infixr_', infixl_', infix_' :: Int -> [String] -> [(String,GHC.Fixity)]
    infixr_' :: Int -> [String] -> [(String, Fixity)]
infixr_' = FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity' FixityDirection
GHC.InfixR
    infixl_' :: Int -> [String] -> [(String, Fixity)]
infixl_' = FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity' FixityDirection
GHC.InfixL
    infix_' :: Int -> [String] -> [(String, Fixity)]
infix_'  = FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity' FixityDirection
GHC.InfixN

    fixity' :: GHC.FixityDirection -> Int -> [String] -> [(String, GHC.Fixity)]
    fixity' :: FixityDirection -> Int -> [String] -> [(String, Fixity)]
fixity' a :: FixityDirection
a p :: Int
p = (String -> (String, Fixity)) -> [String] -> [(String, Fixity)]
forall a b. (a -> b) -> [a] -> [b]
map (,SourceText -> Int -> FixityDirection -> Fixity
GHC.Fixity (String -> SourceText
GHC.SourceText "") Int
p FixityDirection
a)

    qNameToStr :: QName () -> String
    qNameToStr :: QName () -> String
qNameToStr (Special _ Cons{}) = ":"
    qNameToStr (Special _ UnitCon{}) = "()"
    qNameToStr (UnQual _ (X.Ident _ x :: String
x)) = String
x
    qNameToStr (UnQual _ (Symbol _ x :: String
x)) = String
x
    qNameToStr _ = ""
ghcFixitiesFromParseMode _ = []

-- GHC enabled/disabled extensions given an HSE parse mode.
ghcExtensionsFromParseMode :: ParseMode
                           -> ([GHC.Extension], [GHC.Extension])
ghcExtensionsFromParseMode :: ParseMode -> ([Extension], [Extension])
ghcExtensionsFromParseMode ParseMode {extensions :: ParseMode -> [Extension]
extensions=[Extension]
exts}=
   [Either Extension Extension] -> ([Extension], [Extension])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either Extension Extension] -> ([Extension], [Extension]))
-> [Either Extension Extension] -> ([Extension], [Extension])
forall a b. (a -> b) -> a -> b
$ (Extension -> Maybe (Either Extension Extension))
-> [Extension] -> [Either Extension Extension]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Extension -> Maybe (Either Extension Extension)
toEither [Extension]
exts
   where
     toEither :: Extension -> Maybe (Either Extension Extension)
toEither ke :: Extension
ke = case Extension
ke of
       EnableExtension e :: KnownExtension
e  -> Extension -> Either Extension Extension
forall a b. a -> Either a b
Left  (Extension -> Either Extension Extension)
-> Maybe Extension -> Maybe (Either Extension Extension)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe Extension
readExtension (KnownExtension -> String
forall a. Show a => a -> String
show KnownExtension
e)
       DisableExtension e :: KnownExtension
e -> Extension -> Either Extension Extension
forall a b. b -> Either a b
Right (Extension -> Either Extension Extension)
-> Maybe Extension -> Maybe (Either Extension Extension)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe Extension
readExtension (KnownExtension -> String
forall a. Show a => a -> String
show KnownExtension
e)
       UnknownExtension ('N':'o':e :: String
e) -> Extension -> Either Extension Extension
forall a b. b -> Either a b
Right (Extension -> Either Extension Extension)
-> Maybe Extension -> Maybe (Either Extension Extension)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe Extension
readExtension String
e
       UnknownExtension e :: String
e -> Extension -> Either Extension Extension
forall a b. a -> Either a b
Left (Extension -> Either Extension Extension)
-> Maybe Extension -> Maybe (Either Extension Extension)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe Extension
readExtension String
e

-- GHC extensions to enable/disable given HSE parse flags.
ghcExtensionsFromParseFlags :: ParseFlags
                             -> ([GHC.Extension], [GHC.Extension])
ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension])
ghcExtensionsFromParseFlags ParseFlags {hseFlags :: ParseFlags -> ParseMode
hseFlags=ParseMode
mode} = ParseMode -> ([Extension], [Extension])
ghcExtensionsFromParseMode ParseMode
mode

-- GHC fixities given HSE parse flags.
ghcFixitiesFromParseFlags :: ParseFlags -> [(String, GHC.Fixity)]
ghcFixitiesFromParseFlags :: ParseFlags -> [(String, Fixity)]
ghcFixitiesFromParseFlags ParseFlags {hseFlags :: ParseFlags -> ParseMode
hseFlags=ParseMode
mode} = ParseMode -> [(String, Fixity)]
ghcFixitiesFromParseMode ParseMode
mode

-- These next two functions get called frorm 'Config/Yaml.hs' for user
-- defined hint rules.

parseExpGhcWithMode :: ParseMode -> String -> GHC.ParseResult (HsSyn.LHsExpr HsSyn.GhcPs)
parseExpGhcWithMode :: ParseMode -> String -> ParseResult (LHsExpr GhcPs)
parseExpGhcWithMode parseMode :: ParseMode
parseMode s :: String
s =
  let (enable :: [Extension]
enable, disable :: [Extension]
disable) = ParseMode -> ([Extension], [Extension])
ghcExtensionsFromParseMode ParseMode
parseMode
      flags :: DynFlags
flags = (DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
GHC.xopt_unset ((DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
GHC.xopt_set DynFlags
baseDynFlags [Extension]
enable) [Extension]
disable
      fixities :: [(String, Fixity)]
fixities = ParseMode -> [(String, Fixity)]
ghcFixitiesFromParseMode ParseMode
parseMode
  in case String -> DynFlags -> ParseResult (LHsExpr GhcPs)
parseExpGhcLib String
s DynFlags
flags of
    GHC.POk pst :: PState
pst a :: LHsExpr GhcPs
a -> PState -> LHsExpr GhcPs -> ParseResult (LHsExpr GhcPs)
forall a. PState -> a -> ParseResult a
GHC.POk PState
pst ([(String, Fixity)] -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Data a => [(String, Fixity)] -> a -> a
GhclibParserEx.applyFixities [(String, Fixity)]
fixities LHsExpr GhcPs
a)
    f :: ParseResult (LHsExpr GhcPs)
f@GHC.PFailed{} -> ParseResult (LHsExpr GhcPs)
f

parseImportDeclGhcWithMode :: ParseMode -> String -> GHC.ParseResult (HsSyn.LImportDecl HsSyn.GhcPs)
parseImportDeclGhcWithMode :: ParseMode -> String -> ParseResult (LImportDecl GhcPs)
parseImportDeclGhcWithMode parseMode :: ParseMode
parseMode s :: String
s =
  let (enable :: [Extension]
enable, disable :: [Extension]
disable) = ParseMode -> ([Extension], [Extension])
ghcExtensionsFromParseMode ParseMode
parseMode
      flags :: DynFlags
flags = (DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
GHC.xopt_unset ((DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
GHC.xopt_set DynFlags
baseDynFlags [Extension]
enable) [Extension]
disable
  in String -> DynFlags -> ParseResult (LImportDecl GhcPs)
parseImportGhcLib String
s DynFlags
flags

-- | Parse a Haskell module. Applies the C pre processor, and uses
-- best-guess fixity resolution if there are ambiguities.  The
-- filename @-@ is treated as @stdin@. Requires some flags (often
-- 'defaultParseFlags'), the filename, and optionally the contents of
-- that file. This version uses both hs-src-exts AND ghc-lib.
parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError ModuleEx)
parseModuleEx :: ParseFlags
-> String -> Maybe String -> IO (Either ParseError ModuleEx)
parseModuleEx flags :: ParseFlags
flags file :: String
file str :: Maybe String
str = String
-> String
-> IO (Either ParseError ModuleEx)
-> IO (Either ParseError ModuleEx)
forall a. String -> String -> IO a -> IO a
timedIO "Parse" String
file (IO (Either ParseError ModuleEx)
 -> IO (Either ParseError ModuleEx))
-> IO (Either ParseError ModuleEx)
-> IO (Either ParseError ModuleEx)
forall a b. (a -> b) -> a -> b
$ do
        String
str <- case Maybe String
str of
            Just x :: String
x -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
x
            Nothing | String
file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "-" -> IO String
getContentsUTF8
                    | Bool
otherwise -> String -> IO String
readFileUTF8' String
file
        String
str <- String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
str (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix "\65279" String
str -- remove the BOM if it exists, see #130
        String
ppstr <- CppFlags -> String -> String -> IO String
runCpp (ParseFlags -> CppFlags
cppFlags ParseFlags
flags) String
file String
str
        let enableDisableExts :: ([Extension], [Extension])
enableDisableExts = ParseFlags -> ([Extension], [Extension])
ghcExtensionsFromParseFlags ParseFlags
flags
            fixities :: [(String, Fixity)]
fixities = ParseFlags -> [(String, Fixity)]
ghcFixitiesFromParseFlags ParseFlags
flags -- Note : Fixities are coming from HSE parse flags.
        Either String DynFlags
dynFlags <- DynFlags
-> ([Extension], [Extension])
-> String
-> String
-> IO (Either String DynFlags)
parsePragmasIntoDynFlags DynFlags
baseDynFlags ([Extension], [Extension])
enableDisableExts String
file String
ppstr
        case Either String DynFlags
dynFlags of
          Right ghcFlags :: DynFlags
ghcFlags ->
            case (ParseMode -> String -> ParseResult (Module SrcSpanInfo, [Comment])
parseFileContentsWithComments (ParseFlags -> String -> ParseMode
mkMode ParseFlags
flags String
file) String
ppstr, String
-> String -> DynFlags -> ParseResult (Located (HsModule GhcPs))
parseFileGhcLib String
file String
ppstr DynFlags
ghcFlags) of
                (ParseOk (x :: Module SrcSpanInfo
x, cs :: [Comment]
cs), GHC.POk pst :: PState
pst a :: Located (HsModule GhcPs)
a) ->
                    let anns :: ApiAnns
anns =
                          ( ([SrcSpan] -> [SrcSpan] -> [SrcSpan])
-> [(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
(++) ([(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan])
-> [(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan]
forall a b. (a -> b) -> a -> b
$ PState -> [(ApiAnnKey, [SrcSpan])]
GHC.annotations PState
pst
                          , [(SrcSpan, [Located AnnotationComment])]
-> Map SrcSpan [Located AnnotationComment]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((SrcSpan
GHC.noSrcSpan, PState -> [Located AnnotationComment]
GHC.comment_q PState
pst) (SrcSpan, [Located AnnotationComment])
-> [(SrcSpan, [Located AnnotationComment])]
-> [(SrcSpan, [Located AnnotationComment])]
forall a. a -> [a] -> [a]
: PState -> [(SrcSpan, [Located AnnotationComment])]
GHC.annotations_comments PState
pst)
                          ) in
                    let a' :: Located (HsModule GhcPs)
a' = [(String, Fixity)]
-> Located (HsModule GhcPs) -> Located (HsModule GhcPs)
forall a. Data a => [(String, Fixity)] -> a -> a
GhclibParserEx.applyFixities [(String, Fixity)]
fixities Located (HsModule GhcPs)
a in
                    Either ParseError ModuleEx -> IO (Either ParseError ModuleEx)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError ModuleEx -> IO (Either ParseError ModuleEx))
-> Either ParseError ModuleEx -> IO (Either ParseError ModuleEx)
forall a b. (a -> b) -> a -> b
$ ModuleEx -> Either ParseError ModuleEx
forall a b. b -> Either a b
Right (Module SrcSpanInfo
-> [Comment] -> Located (HsModule GhcPs) -> ApiAnns -> ModuleEx
ModuleEx ([Fixity] -> Module SrcSpanInfo -> Module SrcSpanInfo
applyFixity [Fixity]
fixity Module SrcSpanInfo
x) [Comment]
cs Located (HsModule GhcPs)
a' ApiAnns
anns)
                -- Parse error if GHC parsing fails (see
                -- https://github.com/ndmitchell/hlint/issues/645).
                (ParseOk _,  GHC.PFailed _ loc :: SrcSpan
loc err :: MsgDoc
err) ->
                    String
-> String
-> String
-> (SrcSpan, MsgDoc)
-> IO (Either ParseError ModuleEx)
ghcFailOpParseModuleEx String
ppstr String
file String
str (SrcSpan
loc, MsgDoc
err)
                (ParseFailed sl :: SrcLoc
sl msg :: String
msg, pfailed :: ParseResult (Located (HsModule GhcPs))
pfailed) ->
                    String
-> ParseFlags
-> String
-> String
-> SrcLoc
-> String
-> Maybe (SrcSpan, MsgDoc)
-> IO (Either ParseError ModuleEx)
failOpParseModuleEx String
ppstr ParseFlags
flags String
file String
str SrcLoc
sl String
msg (Maybe (SrcSpan, MsgDoc) -> IO (Either ParseError ModuleEx))
-> Maybe (SrcSpan, MsgDoc) -> IO (Either ParseError ModuleEx)
forall a b. (a -> b) -> a -> b
$ ParseResult (Located (HsModule GhcPs)) -> Maybe (SrcSpan, MsgDoc)
forall a. ParseResult a -> Maybe (SrcSpan, MsgDoc)
fromPFailed ParseResult (Located (HsModule GhcPs))
pfailed
          Left msg :: String
msg -> do
            -- Parsing GHC flags from dynamic pragmas in the source
            -- has failed. When this happens, it's reported by
            -- exception. It's impossible or at least fiddly getting a
            -- location so we skip that for now. Synthesize a parse
            -- error.
            let loc :: SrcLoc
loc = String -> Int -> Int -> SrcLoc
SrcLoc String
file (1 :: Int) (1 :: Int)
            Either ParseError ModuleEx -> IO (Either ParseError ModuleEx)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError ModuleEx -> IO (Either ParseError ModuleEx))
-> Either ParseError ModuleEx -> IO (Either ParseError ModuleEx)
forall a b. (a -> b) -> a -> b
$ ParseError -> Either ParseError ModuleEx
forall a b. a -> Either a b
Left (SrcLoc -> String -> String -> ParseError
ParseError SrcLoc
loc String
msg (Int -> String -> String
context (SrcLoc -> Int
srcLine SrcLoc
loc) String
ppstr))

    where
        fromPFailed :: ParseResult a -> Maybe (SrcSpan, MsgDoc)
fromPFailed (GHC.PFailed _ loc :: SrcSpan
loc err :: MsgDoc
err) = (SrcSpan, MsgDoc) -> Maybe (SrcSpan, MsgDoc)
forall a. a -> Maybe a
Just (SrcSpan
loc, MsgDoc
err)
        fromPFailed _ = Maybe (SrcSpan, MsgDoc)
forall a. Maybe a
Nothing

        fixity :: [Fixity]
fixity = [Fixity] -> Maybe [Fixity] -> [Fixity]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Fixity] -> [Fixity]) -> Maybe [Fixity] -> [Fixity]
forall a b. (a -> b) -> a -> b
$ ParseMode -> Maybe [Fixity]
fixities (ParseMode -> Maybe [Fixity]) -> ParseMode -> Maybe [Fixity]
forall a b. (a -> b) -> a -> b
$ ParseFlags -> ParseMode
hseFlags ParseFlags
flags

-- | Given a line number, and some source code, put bird ticks around the appropriate bit.
context :: Int -> String -> String
context :: Int -> String -> String
context lineNo :: Int
lineNo src :: String
src =
    [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
    (String -> String -> String) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> String -> String
forall a. [a] -> [a] -> [a]
(++) [String]
ticks ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take 5 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop (Int
lineNo Int -> Int -> Int
forall a. Num a => a -> a -> a
- 3) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
src [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["","","","",""]
    where ticks :: [String]
ticks = ["  ","  ","> ","  ","  "]


---------------------------------------------------------------------
-- FIXITIES

-- resolve fixities later, so we don't ever get uncatchable ambiguity errors
-- if there are fixity errors, try the cheapFixities (which never fails)
applyFixity :: [Fixity] -> Module_ -> Module_
applyFixity :: [Fixity] -> Module SrcSpanInfo -> Module SrcSpanInfo
applyFixity base :: [Fixity]
base modu :: Module SrcSpanInfo
modu = (Decl_ -> Decl_) -> Module SrcSpanInfo -> Module SrcSpanInfo
forall from to. Biplate from to => (to -> to) -> from -> from
descendBi Decl_ -> Decl_
f Module SrcSpanInfo
modu
    where
        f :: Decl_ -> Decl_
f x :: Decl_
x = Decl_ -> Maybe Decl_ -> Decl_
forall a. a -> Maybe a -> a
fromMaybe ([Fixity] -> Decl_ -> Decl_
cheapFixities [Fixity]
fixs Decl_
x) (Maybe Decl_ -> Decl_) -> Maybe Decl_ -> Decl_
forall a b. (a -> b) -> a -> b
$ [Fixity] -> Decl_ -> Maybe Decl_
forall (ast :: * -> *) (m :: * -> *).
(AppFixity ast, MonadFail m) =>
[Fixity] -> ast SrcSpanInfo -> m (ast SrcSpanInfo)
applyFixities [Fixity]
fixs Decl_
x :: Decl_
        fixs :: [Fixity]
fixs = (Decl_ -> [Fixity]) -> [Decl_] -> [Fixity]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl_ -> [Fixity]
forall a. Decl a -> [Fixity]
getFixity (Module SrcSpanInfo -> [Decl_]
moduleDecls Module SrcSpanInfo
modu) [Fixity] -> [Fixity] -> [Fixity]
forall a. [a] -> [a] -> [a]
++ [Fixity]
base


-- Apply fixities, but ignoring any ambiguous fixity errors and skipping qualified names,
-- local infix declarations etc. Only use as a backup, if HSE gives an error.
--
-- Inspired by the code at:
-- http://hackage.haskell.org/trac/haskell-prime/attachment/wiki/FixityResolution/resolve.hs
cheapFixities :: [Fixity] -> Decl_ -> Decl_
cheapFixities :: [Fixity] -> Decl_ -> Decl_
cheapFixities fixs :: [Fixity]
fixs = (Exp SrcSpanInfo -> Exp SrcSpanInfo) -> Decl_ -> Decl_
forall from to. Biplate from to => (to -> to) -> from -> from
descendBi ((Exp SrcSpanInfo -> Exp SrcSpanInfo)
-> Exp SrcSpanInfo -> Exp SrcSpanInfo
forall on. Uniplate on => (on -> on) -> on -> on
transform Exp SrcSpanInfo -> Exp SrcSpanInfo
f)
    where
        ask :: QOp SrcSpanInfo -> (Assoc (), Int)
ask = [Fixity] -> QOp SrcSpanInfo -> (Assoc (), Int)
askFixity [Fixity]
fixs

        f :: Exp SrcSpanInfo -> Exp SrcSpanInfo
f o :: Exp SrcSpanInfo
o@(InfixApp s1 :: SrcSpanInfo
s1 (InfixApp s2 :: SrcSpanInfo
s2 x :: Exp SrcSpanInfo
x op1 :: QOp SrcSpanInfo
op1 y :: Exp SrcSpanInfo
y) op2 :: QOp SrcSpanInfo
op2 z :: Exp SrcSpanInfo
z)
                | Int
p1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p2 Bool -> Bool -> Bool
&& (Assoc ()
a1 Assoc () -> Assoc () -> Bool
forall a. Eq a => a -> a -> Bool
/= Assoc ()
a2 Bool -> Bool -> Bool
|| Assoc () -> Bool
forall l. Assoc l -> Bool
isAssocNone Assoc ()
a1) = Exp SrcSpanInfo
o -- Ambiguous infix expression!
                | Int
p1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
p2 Bool -> Bool -> Bool
|| Int
p1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p2 Bool -> Bool -> Bool
&& (Assoc () -> Bool
forall l. Assoc l -> Bool
isAssocLeft Assoc ()
a1 Bool -> Bool -> Bool
|| Assoc () -> Bool
forall l. Assoc l -> Bool
isAssocNone Assoc ()
a2) = Exp SrcSpanInfo
o
                | Bool
otherwise = SrcSpanInfo
-> Exp SrcSpanInfo
-> QOp SrcSpanInfo
-> Exp SrcSpanInfo
-> Exp SrcSpanInfo
forall l. l -> Exp l -> QOp l -> Exp l -> Exp l
InfixApp SrcSpanInfo
s1 Exp SrcSpanInfo
x QOp SrcSpanInfo
op1 (Exp SrcSpanInfo -> Exp SrcSpanInfo
f (Exp SrcSpanInfo -> Exp SrcSpanInfo)
-> Exp SrcSpanInfo -> Exp SrcSpanInfo
forall a b. (a -> b) -> a -> b
$ SrcSpanInfo
-> Exp SrcSpanInfo
-> QOp SrcSpanInfo
-> Exp SrcSpanInfo
-> Exp SrcSpanInfo
forall l. l -> Exp l -> QOp l -> Exp l -> Exp l
InfixApp SrcSpanInfo
s1 Exp SrcSpanInfo
y QOp SrcSpanInfo
op2 Exp SrcSpanInfo
z)
            where
                (a1 :: Assoc ()
a1,p1 :: Int
p1) = QOp SrcSpanInfo -> (Assoc (), Int)
ask QOp SrcSpanInfo
op1
                (a2 :: Assoc ()
a2,p2 :: Int
p2) = QOp SrcSpanInfo -> (Assoc (), Int)
ask QOp SrcSpanInfo
op2
        f x :: Exp SrcSpanInfo
x = Exp SrcSpanInfo
x


askFixity :: [Fixity] -> QOp S -> (Assoc (), Int)
askFixity :: [Fixity] -> QOp SrcSpanInfo -> (Assoc (), Int)
askFixity xs :: [Fixity]
xs = \k :: QOp SrcSpanInfo
k -> (Assoc (), Int)
-> String -> Map String (Assoc (), Int) -> (Assoc (), Int)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (() -> Assoc ()
forall l. l -> Assoc l
AssocLeft (), 9) (QOp SrcSpanInfo -> String
forall a. Named a => a -> String
fromNamed QOp SrcSpanInfo
k) Map String (Assoc (), Int)
mp
    where
        mp :: Map String (Assoc (), Int)
mp = [(String, (Assoc (), Int))] -> Map String (Assoc (), Int)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
s,(Assoc ()
a,Int
p)) | Fixity a :: Assoc ()
a p :: Int
p x :: QName ()
x <- [Fixity]
xs, let s :: String
s = QName SrcSpanInfo -> String
forall a. Named a => a -> String
fromNamed (QName SrcSpanInfo -> String) -> QName SrcSpanInfo -> String
forall a b. (a -> b) -> a -> b
$ (() -> SrcSpanInfo) -> QName () -> QName SrcSpanInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SrcSpanInfo -> () -> SrcSpanInfo
forall a b. a -> b -> a
const SrcSpanInfo
an) QName ()
x, String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= ""]