{-# 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
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
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
= 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
data CppFlags
= NoCpp
| CppSimple
| Cpphs CpphsOptions
data ParseFlags = ParseFlags
{ParseFlags -> CppFlags
cppFlags :: CppFlags
,ParseFlags -> ParseMode
hseFlags :: ParseMode
}
lensFixities :: [Fixity]
lensFixities :: [Fixity]
lensFixities = [[Fixity]] -> [Fixity]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[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
[Int -> [String] -> [Fixity]
infix_ 1 ["`shouldBe`","`shouldSatisfy`","`shouldStartWith`","`shouldEndWith`","`shouldContain`","`shouldMatchList`"
,"`shouldReturn`","`shouldNotBe`","`shouldNotSatisfy`","`shouldNotContain`","`shouldNotReturn`","`shouldThrow`"]
,Int -> [String] -> [Fixity]
infixr_ 0 ["==>"]
,Int -> [String] -> [Fixity]
infix_ 4 ["==="]
,Int -> [String] -> [Fixity]
infix_ 4 ["==."]
,Int -> [String] -> [Fixity]
infixr_ 5 ["\\/"]
,Int -> [String] -> [Fixity]
infixr_ 6 ["/\\"]
]
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`"]
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}}
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
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
data ParseError = ParseError
{ ParseError -> SrcLoc
parseErrorLocation :: SrcLoc
, ParseError -> String
parseErrorMessage :: String
, ParseError -> String
parseErrorContents :: String
}
data ModuleEx = ModuleEx {
ModuleEx -> Module SrcSpanInfo
hseModule :: Module SrcSpanInfo
, :: [Comment]
, ModuleEx -> Located (HsModule GhcPs)
ghcModule :: GHC.Located (HsSyn.HsModule HsSyn.GhcPs)
, ModuleEx -> ApiAnns
ghcAnnotations :: GHC.ApiAnns
}
ghcComments :: ModuleEx -> [GHC.Located GHC.AnnotationComment]
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))
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 }
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 ->
String
-> String
-> String
-> (SrcSpan, MsgDoc)
-> IO (Either ParseError ModuleEx)
ghcFailOpParseModuleEx String
ppstr String
file String
str (SrcSpan, MsgDoc)
err
Nothing ->
String
-> ParseFlags
-> String
-> String
-> SrcLoc
-> String
-> IO (Either ParseError ModuleEx)
hseFailOpParseModuleEx String
ppstr ParseFlags
flags String
file String
str SrcLoc
sl String
msg
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
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
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 _ = []
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
ghcExtensionsFromParseFlags :: ParseFlags
-> ([GHC.Extension], [GHC.Extension])
ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension])
ghcExtensionsFromParseFlags ParseFlags {hseFlags :: ParseFlags -> ParseMode
hseFlags=ParseMode
mode} = ParseMode -> ([Extension], [Extension])
ghcExtensionsFromParseMode ParseMode
mode
ghcFixitiesFromParseFlags :: ParseFlags -> [(String, GHC.Fixity)]
ghcFixitiesFromParseFlags :: ParseFlags -> [(String, Fixity)]
ghcFixitiesFromParseFlags ParseFlags {hseFlags :: ParseFlags -> ParseMode
hseFlags=ParseMode
mode} = ParseMode -> [(String, Fixity)]
ghcFixitiesFromParseMode ParseMode
mode
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
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
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
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)
(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
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
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 = [" "," ","> "," "," "]
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
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
| 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
/= ""]