{-# LANGUAGE PatternGuards, ViewPatterns, ScopedTypeVariables, TupleSections #-}
module Config.Haskell(
readPragma,
readComment,
readSetting,
readFileConfigHaskell
) where
import HSE.All
import Data.Char
import Data.List.Extra
import Text.Read.Extra(readMaybe)
import Data.Tuple.Extra
import Data.Maybe
import Config.Type
import Util
import Prelude
import qualified HsSyn as GHC
import qualified BasicTypes as GHC
import GHC.Util
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
import SrcLoc as GHC
import ApiAnnotation
addInfix :: ParseFlags -> ParseFlags
addInfix :: ParseFlags -> ParseFlags
addInfix = [Fixity] -> ParseFlags -> ParseFlags
parseFlagsAddFixities ([Fixity] -> ParseFlags -> ParseFlags)
-> [Fixity] -> ParseFlags -> ParseFlags
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [Fixity]
infix_ (-1) ["==>"]
readFileConfigHaskell :: FilePath -> Maybe String -> IO [Setting]
readFileConfigHaskell :: String -> Maybe String -> IO [Setting]
readFileConfigHaskell file :: String
file contents :: Maybe String
contents = do
let flags :: ParseFlags
flags = ParseFlags -> ParseFlags
addInfix ParseFlags
defaultParseFlags
Either ParseError ModuleEx
res <- ParseFlags
-> String -> Maybe String -> IO (Either ParseError ModuleEx)
parseModuleEx ParseFlags
flags String
file Maybe String
contents
case Either ParseError ModuleEx
res of
Left (ParseError sl :: SrcLoc
sl msg :: String
msg err :: String
err) ->
String -> IO [Setting]
forall a. HasCallStack => String -> a
error (String -> IO [Setting]) -> String -> IO [Setting]
forall a b. (a -> b) -> a -> b
$ "Config parse failure at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SrcLoc -> String
showSrcLoc SrcLoc
sl String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
Right modEx :: ModuleEx
modEx@(ModuleEx m :: Module SrcSpanInfo
m _ _ _) -> [Setting] -> IO [Setting]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Setting] -> IO [Setting]) -> [Setting] -> IO [Setting]
forall a b. (a -> b) -> a -> b
$ Module SrcSpanInfo -> [Setting]
readSettings Module SrcSpanInfo
m [Setting] -> [Setting] -> [Setting]
forall a. [a] -> [a] -> [a]
++ (Classify -> Setting) -> [Classify] -> [Setting]
forall a b. (a -> b) -> [a] -> [b]
map Classify -> Setting
SettingClassify ((Located AnnotationComment -> [Classify])
-> [Located AnnotationComment] -> [Classify]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Located AnnotationComment -> [Classify]
readComment (ModuleEx -> [Located AnnotationComment]
ghcComments ModuleEx
modEx))
readSettings :: Module_ -> [Setting]
readSettings :: Module SrcSpanInfo -> [Setting]
readSettings m :: Module SrcSpanInfo
m = (Decl_ -> [Setting]) -> [Decl_] -> [Setting]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Scope -> Decl_ -> [Setting]
readSetting (Scope -> Decl_ -> [Setting]) -> Scope -> Decl_ -> [Setting]
forall a b. (a -> b) -> a -> b
$ Module SrcSpanInfo -> Scope
scopeCreate Module SrcSpanInfo
m) ([Decl_] -> [Setting]) -> [Decl_] -> [Setting]
forall a b. (a -> b) -> a -> b
$ (Decl_ -> [Decl_]) -> [Decl_] -> [Decl_]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl_ -> [Decl_]
forall s. Decl s -> [Decl s]
getEquations ([Decl_] -> [Decl_]) -> [Decl_] -> [Decl_]
forall a b. (a -> b) -> a -> b
$
[SrcSpanInfo -> Annotation SrcSpanInfo -> Decl_
forall l. l -> Annotation l -> Decl l
AnnPragma SrcSpanInfo
l Annotation SrcSpanInfo
x | AnnModulePragma l :: SrcSpanInfo
l x :: Annotation SrcSpanInfo
x <- Module SrcSpanInfo -> [ModulePragma SrcSpanInfo]
modulePragmas Module SrcSpanInfo
m] [Decl_] -> [Decl_] -> [Decl_]
forall a. [a] -> [a] -> [a]
++ Module SrcSpanInfo -> [Decl_]
moduleDecls Module SrcSpanInfo
m
readSetting :: Scope -> Decl_ -> [Setting]
readSetting :: Scope -> Decl_ -> [Setting]
readSetting s :: Scope
s (FunBind _ [Match _ (Ident _ (String -> Maybe Severity
getSeverity -> Just severity :: Severity
severity)) pats :: [Pat SrcSpanInfo]
pats (UnGuardedRhs _ bod :: Exp SrcSpanInfo
bod) bind :: Maybe (Binds SrcSpanInfo)
bind])
| InfixApp _ lhs :: Exp SrcSpanInfo
lhs op :: QOp SrcSpanInfo
op rhs :: Exp SrcSpanInfo
rhs <- Exp SrcSpanInfo
bod, QOp SrcSpanInfo -> Exp SrcSpanInfo
opExp QOp SrcSpanInfo
op Exp SrcSpanInfo -> String -> Bool
forall a. Named a => a -> String -> Bool
~= "==>" =
let (a :: Maybe (Exp SrcSpanInfo)
a,b :: [Note]
b) = [Decl_] -> (Maybe (Exp SrcSpanInfo), [Note])
readSide ([Decl_] -> (Maybe (Exp SrcSpanInfo), [Note]))
-> [Decl_] -> (Maybe (Exp SrcSpanInfo), [Note])
forall a b. (a -> b) -> a -> b
$ Maybe (Binds SrcSpanInfo) -> [Decl_]
forall from to. Biplate from to => from -> [to]
childrenBi Maybe (Binds SrcSpanInfo)
bind in
let unit :: LHsExpr GhcPs
unit = SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
GHC.noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XExplicitTuple GhcPs -> [LHsTupArg GhcPs] -> Boxity -> HsExpr GhcPs
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
GHC.ExplicitTuple NoExt
XExplicitTuple GhcPs
GHC.noExt [] Boxity
GHC.Boxed in
[HintRule -> Setting
SettingMatchExp (HintRule -> Setting) -> HintRule -> Setting
forall a b. (a -> b) -> a -> b
$
Severity
-> String
-> Scope
-> Exp SrcSpanInfo
-> Exp SrcSpanInfo
-> Maybe (Exp SrcSpanInfo)
-> [Note]
-> HsExtendInstances Scope'
-> HsExtendInstances (LHsExpr GhcPs)
-> HsExtendInstances (LHsExpr GhcPs)
-> Maybe (HsExtendInstances (LHsExpr GhcPs))
-> HintRule
HintRule Severity
severity ([String] -> String
forall a. [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String -> [String]
forall a. [a] -> a -> [a]
snoc [String]
names String
defaultHintName) Scope
s (Exp SrcSpanInfo -> Exp SrcSpanInfo
fromParen Exp SrcSpanInfo
lhs) (Exp SrcSpanInfo -> Exp SrcSpanInfo
fromParen Exp SrcSpanInfo
rhs) Maybe (Exp SrcSpanInfo)
a [Note]
b
(Scope' -> HsExtendInstances Scope'
forall a. a -> HsExtendInstances a
extendInstances Scope'
forall a. Monoid a => a
mempty) (LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances LHsExpr GhcPs
unit) (LHsExpr GhcPs -> HsExtendInstances (LHsExpr GhcPs)
forall a. a -> HsExtendInstances a
extendInstances LHsExpr GhcPs
unit) Maybe (HsExtendInstances (LHsExpr GhcPs))
forall a. Maybe a
Nothing]
| Bool
otherwise = [Classify -> Setting
SettingClassify (Classify -> Setting) -> Classify -> Setting
forall a b. (a -> b) -> a -> b
$ Severity -> String -> String -> String -> Classify
Classify Severity
severity String
n String
a String
b | String
n <- [String]
names2, (a :: String
a,b :: String
b) <- Exp SrcSpanInfo -> [(String, String)]
readFuncs Exp SrcSpanInfo
bod]
where
names :: [String]
names = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [Pat SrcSpanInfo] -> Exp SrcSpanInfo -> [String]
getNames [Pat SrcSpanInfo]
pats Exp SrcSpanInfo
bod
names2 :: [String]
names2 = ["" | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
names] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
names
readSetting s :: Scope
s x :: Decl_
x | "test" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (Decl_ -> String
forall a. Named a => a -> String
fromNamed Decl_
x) = []
readSetting s :: Scope
s (AnnPragma _ x :: Annotation SrcSpanInfo
x) | Just y :: Classify
y <- Annotation SrcSpanInfo -> Maybe Classify
readPragma Annotation SrcSpanInfo
x = [Classify -> Setting
SettingClassify Classify
y]
readSetting s :: Scope
s (PatBind an :: SrcSpanInfo
an (PVar _ name :: Name SrcSpanInfo
name) bod :: Rhs SrcSpanInfo
bod bind :: Maybe (Binds SrcSpanInfo)
bind) = Scope -> Decl_ -> [Setting]
readSetting Scope
s (Decl_ -> [Setting]) -> Decl_ -> [Setting]
forall a b. (a -> b) -> a -> b
$ SrcSpanInfo -> [Match SrcSpanInfo] -> Decl_
forall l. l -> [Match l] -> Decl l
FunBind SrcSpanInfo
an [SrcSpanInfo
-> Name SrcSpanInfo
-> [Pat SrcSpanInfo]
-> Rhs SrcSpanInfo
-> Maybe (Binds SrcSpanInfo)
-> Match SrcSpanInfo
forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Match SrcSpanInfo
an Name SrcSpanInfo
name [] Rhs SrcSpanInfo
bod Maybe (Binds SrcSpanInfo)
bind]
readSetting s :: Scope
s (FunBind an :: SrcSpanInfo
an xs :: [Match SrcSpanInfo]
xs) | [Match SrcSpanInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Match SrcSpanInfo]
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 1 = (Match SrcSpanInfo -> [Setting])
-> [Match SrcSpanInfo] -> [Setting]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Scope -> Decl_ -> [Setting]
readSetting Scope
s (Decl_ -> [Setting])
-> (Match SrcSpanInfo -> Decl_) -> Match SrcSpanInfo -> [Setting]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpanInfo -> [Match SrcSpanInfo] -> Decl_
forall l. l -> [Match l] -> Decl l
FunBind SrcSpanInfo
an ([Match SrcSpanInfo] -> Decl_)
-> (Match SrcSpanInfo -> [Match SrcSpanInfo])
-> Match SrcSpanInfo
-> Decl_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Match SrcSpanInfo -> [Match SrcSpanInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return) [Match SrcSpanInfo]
xs
readSetting s :: Scope
s (SpliceDecl an :: SrcSpanInfo
an (App _ (Var _ x :: QName SrcSpanInfo
x) (Lit _ y :: Literal SrcSpanInfo
y))) = Scope -> Decl_ -> [Setting]
readSetting Scope
s (Decl_ -> [Setting]) -> Decl_ -> [Setting]
forall a b. (a -> b) -> a -> b
$ SrcSpanInfo -> [Match SrcSpanInfo] -> Decl_
forall l. l -> [Match l] -> Decl l
FunBind SrcSpanInfo
an [SrcSpanInfo
-> Name SrcSpanInfo
-> [Pat SrcSpanInfo]
-> Rhs SrcSpanInfo
-> Maybe (Binds SrcSpanInfo)
-> Match SrcSpanInfo
forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Match SrcSpanInfo
an (String -> Name SrcSpanInfo
forall a. Named a => String -> a
toNamed (String -> Name SrcSpanInfo) -> String -> Name SrcSpanInfo
forall a b. (a -> b) -> a -> b
$ QName SrcSpanInfo -> String
forall a. Named a => a -> String
fromNamed QName SrcSpanInfo
x) [SrcSpanInfo
-> Sign SrcSpanInfo -> Literal SrcSpanInfo -> Pat SrcSpanInfo
forall l. l -> Sign l -> Literal l -> Pat l
PLit SrcSpanInfo
an (SrcSpanInfo -> Sign SrcSpanInfo
forall l. l -> Sign l
Signless SrcSpanInfo
an) Literal SrcSpanInfo
y] (SrcSpanInfo -> Exp SrcSpanInfo -> Rhs SrcSpanInfo
forall l. l -> Exp l -> Rhs l
UnGuardedRhs SrcSpanInfo
an (Exp SrcSpanInfo -> Rhs SrcSpanInfo)
-> Exp SrcSpanInfo -> Rhs SrcSpanInfo
forall a b. (a -> b) -> a -> b
$ SrcSpanInfo -> Literal SrcSpanInfo -> Exp SrcSpanInfo
forall l. l -> Literal l -> Exp l
Lit SrcSpanInfo
an (Literal SrcSpanInfo -> Exp SrcSpanInfo)
-> Literal SrcSpanInfo -> Exp SrcSpanInfo
forall a b. (a -> b) -> a -> b
$ SrcSpanInfo -> String -> String -> Literal SrcSpanInfo
forall l. l -> String -> String -> Literal l
String SrcSpanInfo
an "" "") Maybe (Binds SrcSpanInfo)
forall a. Maybe a
Nothing]
readSetting s :: Scope
s x :: Decl_
x@InfixDecl{} = (Fixity -> Setting) -> [Fixity] -> [Setting]
forall a b. (a -> b) -> [a] -> [b]
map Fixity -> Setting
Infix ([Fixity] -> [Setting]) -> [Fixity] -> [Setting]
forall a b. (a -> b) -> a -> b
$ Decl_ -> [Fixity]
forall a. Decl a -> [Fixity]
getFixity Decl_
x
readSetting s :: Scope
s x :: Decl_
x = Decl_ -> String -> [Setting]
forall (ast :: * -> *) b.
(Annotated ast, Pretty (ast SrcSpanInfo)) =>
ast SrcSpanInfo -> String -> b
errorOn Decl_
x "bad hint"
readPragma :: Annotation S -> Maybe Classify
readPragma :: Annotation SrcSpanInfo -> Maybe Classify
readPragma o :: Annotation SrcSpanInfo
o = case Annotation SrcSpanInfo
o of
Ann _ name :: Name SrcSpanInfo
name x :: Exp SrcSpanInfo
x -> String -> Exp SrcSpanInfo -> Maybe Classify
forall l. String -> Exp l -> Maybe Classify
f (Name SrcSpanInfo -> String
forall a. Named a => a -> String
fromNamed Name SrcSpanInfo
name) Exp SrcSpanInfo
x
TypeAnn _ name :: Name SrcSpanInfo
name x :: Exp SrcSpanInfo
x -> String -> Exp SrcSpanInfo -> Maybe Classify
forall l. String -> Exp l -> Maybe Classify
f (Name SrcSpanInfo -> String
forall a. Named a => a -> String
fromNamed Name SrcSpanInfo
name) Exp SrcSpanInfo
x
ModuleAnn _ x :: Exp SrcSpanInfo
x -> String -> Exp SrcSpanInfo -> Maybe Classify
forall l. String -> Exp l -> Maybe Classify
f "" Exp SrcSpanInfo
x
where
f :: String -> Exp l -> Maybe Classify
f name :: String
name (Lit _ (String _ s :: String
s _)) | "hlint:" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s =
case String -> Maybe Severity
getSeverity String
a of
Nothing -> Annotation SrcSpanInfo -> String -> Maybe Classify
forall (ast :: * -> *) b.
(Annotated ast, Pretty (ast SrcSpanInfo)) =>
ast SrcSpanInfo -> String -> b
errorOn Annotation SrcSpanInfo
o "bad classify pragma"
Just severity :: Severity
severity -> Classify -> Maybe Classify
forall a. a -> Maybe a
Just (Classify -> Maybe Classify) -> Classify -> Maybe Classify
forall a b. (a -> b) -> a -> b
$ Severity -> String -> String -> String -> Classify
Classify Severity
severity (String -> String
trimStart String
b) "" String
name
where (a :: String
a,b :: String
b) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ String -> String
trimStart (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop 6 String
s
f name :: String
name (Paren _ x :: Exp l
x) = String -> Exp l -> Maybe Classify
f String
name Exp l
x
f name :: String
name (ExpTypeSig _ x :: Exp l
x _) = String -> Exp l -> Maybe Classify
f String
name Exp l
x
f _ _ = Maybe Classify
forall a. Maybe a
Nothing
readComment :: GHC.Located AnnotationComment -> [Classify]
c :: Located AnnotationComment
c@(L pos :: SrcSpan
pos AnnBlockComment{})
| (hash :: Bool
hash, x :: String
x) <- (Bool, String)
-> (String -> (Bool, String)) -> Maybe String -> (Bool, String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool
False, String
x) (Bool
True,) (Maybe String -> (Bool, String)) -> Maybe String -> (Bool, String)
forall a b. (a -> b) -> a -> b
$ String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix "#" String
x
, String
x <- String -> String
trim String
x
, (hlint :: String
hlint, x :: String
x) <- String -> (String, String)
word1 String
x
, String -> String
lower String
hlint String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "hlint"
= Bool -> String -> [Classify]
f Bool
hash String
x
where
x :: String
x = Located AnnotationComment -> String
commentText Located AnnotationComment
c
f :: Bool -> String -> [Classify]
f hash :: Bool
hash x :: String
x
| Just x :: String
x <- if Bool
hash then String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix "#" String
x else String -> Maybe String
forall a. a -> Maybe a
Just String
x
, (sev :: String
sev, x :: String
x) <- String -> (String, String)
word1 String
x
, Just sev :: Severity
sev <- String -> Maybe Severity
getSeverity String
sev
, (things :: [String]
things, x :: String
x) <- String -> ([String], String)
g String
x
, Just hint :: String
hint <- if String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "" then String -> Maybe String
forall a. a -> Maybe a
Just "" else String -> Maybe String
forall a. Read a => String -> Maybe a
readMaybe String
x
= (String -> Classify) -> [String] -> [Classify]
forall a b. (a -> b) -> [a] -> [b]
map (Severity -> String -> String -> String -> Classify
Classify Severity
sev String
hint "") ([String] -> [Classify]) -> [String] -> [Classify]
forall a b. (a -> b) -> a -> b
$ ["" | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
things] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
things
f hash :: Bool
hash _ = Located AnnotationComment -> String -> [Classify]
forall b. Located AnnotationComment -> String -> b
errorOnComment Located AnnotationComment
c (String -> [Classify]) -> String -> [Classify]
forall a b. (a -> b) -> a -> b
$ "bad HLINT pragma, expected:\n {-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ " HLINT <severity> <identifier> \"Hint name\" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-}"
where h :: String
h = ['#' | Bool
hash]
g :: String -> ([String], String)
g x :: String
x | (s :: String
s, x :: String
x) <- String -> (String, String)
word1 String
x
, String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= ""
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ "\"" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s
= ([String] -> [String]) -> ([String], String) -> ([String], String)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first ((if String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "module" then "" else String
s)String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) (([String], String) -> ([String], String))
-> ([String], String) -> ([String], String)
forall a b. (a -> b) -> a -> b
$ String -> ([String], String)
g String
x
g x :: String
x = ([], String
x)
readComment _ = []
readSide :: [Decl_] -> (Maybe Exp_, [Note])
readSide :: [Decl_] -> (Maybe (Exp SrcSpanInfo), [Note])
readSide = ((Maybe (Exp SrcSpanInfo), [Note])
-> Decl_ -> (Maybe (Exp SrcSpanInfo), [Note]))
-> (Maybe (Exp SrcSpanInfo), [Note])
-> [Decl_]
-> (Maybe (Exp SrcSpanInfo), [Note])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Maybe (Exp SrcSpanInfo), [Note])
-> Decl_ -> (Maybe (Exp SrcSpanInfo), [Note])
f (Maybe (Exp SrcSpanInfo)
forall a. Maybe a
Nothing,[])
where f :: (Maybe (Exp SrcSpanInfo), [Note])
-> Decl_ -> (Maybe (Exp SrcSpanInfo), [Note])
f (Nothing,notes :: [Note]
notes) (PatBind _ PWildCard{} (UnGuardedRhs _ side :: Exp SrcSpanInfo
side) Nothing) = (Exp SrcSpanInfo -> Maybe (Exp SrcSpanInfo)
forall a. a -> Maybe a
Just Exp SrcSpanInfo
side, [Note]
notes)
f (Nothing,notes :: [Note]
notes) (PatBind _ (Pat SrcSpanInfo -> String
forall a. Named a => a -> String
fromNamed -> String
"side") (UnGuardedRhs _ side :: Exp SrcSpanInfo
side) Nothing) = (Exp SrcSpanInfo -> Maybe (Exp SrcSpanInfo)
forall a. a -> Maybe a
Just Exp SrcSpanInfo
side, [Note]
notes)
f (side :: Maybe (Exp SrcSpanInfo)
side,[]) (PatBind _ (Pat SrcSpanInfo -> String
forall a. Named a => a -> String
fromNamed -> String
"note") (UnGuardedRhs _ note :: Exp SrcSpanInfo
note) Nothing) = (Maybe (Exp SrcSpanInfo)
side,Exp SrcSpanInfo -> [Note]
g Exp SrcSpanInfo
note)
f _ x :: Decl_
x = Decl_ -> String -> (Maybe (Exp SrcSpanInfo), [Note])
forall (ast :: * -> *) b.
(Annotated ast, Pretty (ast SrcSpanInfo)) =>
ast SrcSpanInfo -> String -> b
errorOn Decl_
x "bad side condition"
g :: Exp SrcSpanInfo -> [Note]
g (Lit _ (String _ x :: String
x _)) = [String -> Note
Note String
x]
g (List _ xs :: [Exp SrcSpanInfo]
xs) = (Exp SrcSpanInfo -> [Note]) -> [Exp SrcSpanInfo] -> [Note]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Exp SrcSpanInfo -> [Note]
g [Exp SrcSpanInfo]
xs
g x :: Exp SrcSpanInfo
x = case Exp SrcSpanInfo -> [Exp SrcSpanInfo]
fromApps Exp SrcSpanInfo
x of
[Exp SrcSpanInfo -> Maybe String
con -> Just "IncreasesLaziness"] -> [Note
IncreasesLaziness]
[Exp SrcSpanInfo -> Maybe String
con -> Just "DecreasesLaziness"] -> [Note
DecreasesLaziness]
[Exp SrcSpanInfo -> Maybe String
con -> Just "RemovesError",Exp SrcSpanInfo -> Maybe String
fromString -> Just a :: String
a] -> [String -> Note
RemovesError String
a]
[Exp SrcSpanInfo -> Maybe String
con -> Just "ValidInstance",Exp SrcSpanInfo -> Maybe String
fromString -> Just a :: String
a,Exp SrcSpanInfo -> Maybe String
forall l. Exp l -> Maybe String
var -> Just b :: String
b] -> [String -> String -> Note
ValidInstance String
a String
b]
[Exp SrcSpanInfo -> Maybe String
con -> Just "RequiresExtension",Exp SrcSpanInfo -> Maybe String
con -> Just a :: String
a] -> [String -> Note
RequiresExtension String
a]
_ -> Exp SrcSpanInfo -> String -> [Note]
forall (ast :: * -> *) b.
(Annotated ast, Pretty (ast SrcSpanInfo)) =>
ast SrcSpanInfo -> String -> b
errorOn Exp SrcSpanInfo
x "bad note"
con :: Exp_ -> Maybe String
con :: Exp SrcSpanInfo -> Maybe String
con c :: Exp SrcSpanInfo
c@Con{} = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Exp SrcSpanInfo -> String
forall a. Pretty a => a -> String
prettyPrint Exp SrcSpanInfo
c; con _ = Maybe String
forall a. Maybe a
Nothing
var :: Exp l -> Maybe String
var c :: Exp l
c@Var{} = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Exp l -> String
forall a. Pretty a => a -> String
prettyPrint Exp l
c; var _ = Maybe String
forall a. Maybe a
Nothing
readFuncs :: Exp_ -> [(String, String)]
readFuncs :: Exp SrcSpanInfo -> [(String, String)]
readFuncs (App _ x :: Exp SrcSpanInfo
x y :: Exp SrcSpanInfo
y) = Exp SrcSpanInfo -> [(String, String)]
readFuncs Exp SrcSpanInfo
x [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ Exp SrcSpanInfo -> [(String, String)]
readFuncs Exp SrcSpanInfo
y
readFuncs (Lit _ (String _ "" _)) = [("","")]
readFuncs (Var _ (UnQual _ name :: Name SrcSpanInfo
name)) = [("",Name SrcSpanInfo -> String
forall a. Named a => a -> String
fromNamed Name SrcSpanInfo
name)]
readFuncs (Var _ (Qual _ (ModuleName _ mod :: String
mod) name :: Name SrcSpanInfo
name)) = [(String
mod, Name SrcSpanInfo -> String
forall a. Named a => a -> String
fromNamed Name SrcSpanInfo
name)]
readFuncs (Con _ (UnQual _ name :: Name SrcSpanInfo
name)) = [(Name SrcSpanInfo -> String
forall a. Named a => a -> String
fromNamed Name SrcSpanInfo
name,""),("",Name SrcSpanInfo -> String
forall a. Named a => a -> String
fromNamed Name SrcSpanInfo
name)]
readFuncs (Con _ (Qual _ (ModuleName _ mod :: String
mod) name :: Name SrcSpanInfo
name)) = [(String
mod String -> String -> String
forall a. [a] -> [a] -> [a]
++ "." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name SrcSpanInfo -> String
forall a. Named a => a -> String
fromNamed Name SrcSpanInfo
name,""),(String
mod,Name SrcSpanInfo -> String
forall a. Named a => a -> String
fromNamed Name SrcSpanInfo
name)]
readFuncs x :: Exp SrcSpanInfo
x = Exp SrcSpanInfo -> String -> [(String, String)]
forall (ast :: * -> *) b.
(Annotated ast, Pretty (ast SrcSpanInfo)) =>
ast SrcSpanInfo -> String -> b
errorOn Exp SrcSpanInfo
x "bad classification rule"
getNames :: [Pat_] -> Exp_ -> [String]
getNames :: [Pat SrcSpanInfo] -> Exp SrcSpanInfo -> [String]
getNames ps :: [Pat SrcSpanInfo]
ps _ | [Pat SrcSpanInfo]
ps [Pat SrcSpanInfo] -> [Pat SrcSpanInfo] -> Bool
forall a. Eq a => a -> a -> Bool
/= [], Just ps :: [String]
ps <- (Pat SrcSpanInfo -> Maybe String)
-> [Pat SrcSpanInfo] -> Maybe [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat SrcSpanInfo -> Maybe String
fromPString [Pat SrcSpanInfo]
ps = [String]
ps
getNames [] (InfixApp _ lhs :: Exp SrcSpanInfo
lhs op :: QOp SrcSpanInfo
op rhs :: Exp SrcSpanInfo
rhs) | QOp SrcSpanInfo -> Exp SrcSpanInfo
opExp QOp SrcSpanInfo
op Exp SrcSpanInfo -> String -> Bool
forall a. Named a => a -> String -> Bool
~= "==>" = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ("Use "String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
names
where
lnames :: [String]
lnames = (Name SrcSpanInfo -> String) -> [Name SrcSpanInfo] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Name SrcSpanInfo -> String
forall l. Name l -> String
f ([Name SrcSpanInfo] -> [String]) -> [Name SrcSpanInfo] -> [String]
forall a b. (a -> b) -> a -> b
$ Exp SrcSpanInfo -> [Name SrcSpanInfo]
forall x (f :: * -> *).
(Data x, Data (f SrcSpanInfo)) =>
x -> [f SrcSpanInfo]
childrenS Exp SrcSpanInfo
lhs
rnames :: [String]
rnames = (Name SrcSpanInfo -> String) -> [Name SrcSpanInfo] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Name SrcSpanInfo -> String
forall l. Name l -> String
f ([Name SrcSpanInfo] -> [String]) -> [Name SrcSpanInfo] -> [String]
forall a b. (a -> b) -> a -> b
$ Exp SrcSpanInfo -> [Name SrcSpanInfo]
forall x (f :: * -> *).
(Data x, Data (f SrcSpanInfo)) =>
x -> [f SrcSpanInfo]
childrenS Exp SrcSpanInfo
rhs
names :: [String]
names = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isUnifyVar) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ([String]
rnames [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
\\ [String]
lnames) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
rnames
f :: Name l -> String
f (Ident _ x :: String
x) = String
x
f (Symbol _ x :: String
x) = String
x
getNames _ _ = []
errorOn :: (Annotated ast, Pretty (ast S)) => ast S -> String -> b
errorOn :: ast SrcSpanInfo -> String -> b
errorOn val :: ast SrcSpanInfo
val msg :: String
msg = String -> b
forall a. String -> a
exitMessageImpure (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$
SrcLoc -> String
showSrcLoc (SrcSpanInfo -> SrcLoc
forall si. SrcInfo si => si -> SrcLoc
getPointLoc (SrcSpanInfo -> SrcLoc) -> SrcSpanInfo -> SrcLoc
forall a b. (a -> b) -> a -> b
$ ast SrcSpanInfo -> SrcSpanInfo
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann ast SrcSpanInfo
val) String -> String -> String
forall a. [a] -> [a] -> [a]
++
": Error while reading hint file, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
ast SrcSpanInfo -> String
forall a. Pretty a => a -> String
prettyPrint ast SrcSpanInfo
val
errorOnComment :: GHC.Located AnnotationComment -> String -> b
c :: Located AnnotationComment
c@(L s :: SrcSpan
s _) msg :: String
msg = String -> b
forall a. String -> a
exitMessageImpure (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$
let isMultiline :: Bool
isMultiline = Located AnnotationComment -> Bool
isCommentMultiline Located AnnotationComment
c in
SrcLoc -> String
showSrcLoc (SrcLoc -> SrcLoc
ghcSrcLocToHSE (SrcLoc -> SrcLoc) -> SrcLoc -> SrcLoc
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcLoc
GHC.srcSpanStart SrcSpan
s) String -> String -> String
forall a. [a] -> [a] -> [a]
++
": Error while reading hint file, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
(if Bool
isMultiline then "{-" else "--") String -> String -> String
forall a. [a] -> [a] -> [a]
++ Located AnnotationComment -> String
commentText Located AnnotationComment
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
isMultiline then "-}" else "")