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

module HSE.All(
    module X,
    CppFlags(..), ParseFlags(..), defaultParseFlags,
    parseFlagsAddFixities, parseFlagsSetLanguage,
    parseModuleEx, ParseError(..),
    freeVars, vars, varss, pvars
    ) where

import Language.Haskell.Exts.Util hiding (freeVars, Vars(..))
import qualified Language.Haskell.Exts.Util as X
import HSE.Util as X
import HSE.Reduce 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.Set (Set)
import qualified Data.Map as Map
import qualified Data.Set as Set
import System.IO.Extra
import Data.Functor
import Prelude

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]
defaultExtensions}

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 from 'parseModuleEx'.
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.
    }

-- | 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.
parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError (Module SrcSpanInfo, [Comment]))
parseModuleEx :: ParseFlags
-> String
-> Maybe String
-> IO (Either ParseError (Module SrcSpanInfo, [Comment]))
parseModuleEx flags :: ParseFlags
flags file :: String
file str :: Maybe String
str = String
-> String
-> IO (Either ParseError (Module SrcSpanInfo, [Comment]))
-> IO (Either ParseError (Module SrcSpanInfo, [Comment]))
forall a. String -> String -> IO a -> IO a
timedIO "Parse" String
file (IO (Either ParseError (Module SrcSpanInfo, [Comment]))
 -> IO (Either ParseError (Module SrcSpanInfo, [Comment])))
-> IO (Either ParseError (Module SrcSpanInfo, [Comment]))
-> IO (Either ParseError (Module SrcSpanInfo, [Comment]))
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
        case ParseMode -> String -> ParseResult (Module SrcSpanInfo, [Comment])
parseFileContentsWithComments (ParseFlags -> ParseMode
mode ParseFlags
flags) String
ppstr of
            ParseOk (x :: Module SrcSpanInfo
x, cs :: [Comment]
cs) -> Either ParseError (Module SrcSpanInfo, [Comment])
-> IO (Either ParseError (Module SrcSpanInfo, [Comment]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError (Module SrcSpanInfo, [Comment])
 -> IO (Either ParseError (Module SrcSpanInfo, [Comment])))
-> Either ParseError (Module SrcSpanInfo, [Comment])
-> IO (Either ParseError (Module SrcSpanInfo, [Comment]))
forall a b. (a -> b) -> a -> b
$ (Module SrcSpanInfo, [Comment])
-> Either ParseError (Module SrcSpanInfo, [Comment])
forall a b. b -> Either a b
Right ([Fixity] -> Module SrcSpanInfo -> Module SrcSpanInfo
applyFixity [Fixity]
fixity Module SrcSpanInfo
x, [Comment]
cs)
            ParseFailed sl :: SrcLoc
sl msg :: String
msg -> do
                -- figure out the best line number to grab context from, by reparsing
                -- but not generating {-# LINE #-} pragmas
                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 -> ParseMode
mode ParseFlags
flags) 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 (Module SrcSpanInfo, [Comment])
-> IO (Either ParseError (Module SrcSpanInfo, [Comment]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError (Module SrcSpanInfo, [Comment])
 -> IO (Either ParseError (Module SrcSpanInfo, [Comment])))
-> Either ParseError (Module SrcSpanInfo, [Comment])
-> IO (Either ParseError (Module SrcSpanInfo, [Comment]))
forall a b. (a -> b) -> a -> b
$ ParseError -> Either ParseError (Module SrcSpanInfo, [Comment])
forall a b. a -> Either a b
Left (ParseError -> Either ParseError (Module SrcSpanInfo, [Comment]))
-> ParseError -> Either ParseError (Module SrcSpanInfo, [Comment])
forall a b. (a -> b) -> a -> b
$ SrcLoc -> String -> String -> ParseError
ParseError SrcLoc
sl String
msg String
pe
    where
        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
        mode :: ParseFlags -> ParseMode
mode flags :: ParseFlags
flags = (ParseFlags -> ParseMode
hseFlags ParseFlags
flags)
            {parseFilename :: String
parseFilename = String
file
            ,fixities :: Maybe [Fixity]
fixities = Maybe [Fixity]
forall a. Maybe a
Nothing
            }


-- | 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
/= ""]