{-# 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


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) ["==>"]


---------------------------------------------------------------------
-- READ A SETTINGS FILE

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 (Module SrcSpanInfo, [Comment])
res <- ParseFlags
-> String
-> Maybe String
-> IO (Either ParseError (Module SrcSpanInfo, [Comment]))
parseModuleEx ParseFlags
flags String
file Maybe String
contents
    case Either ParseError (Module SrcSpanInfo, [Comment])
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 (m :: Module SrcSpanInfo
m, cs :: [Comment]
cs) -> [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 ((Comment -> [Classify]) -> [Comment] -> [Classify]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Comment -> [Classify]
readComment [Comment]
cs)


-- | Given a module containing HLint settings information return the 'Classify' rules and the 'HintRule' expressions.
--   Any fixity declarations will be discarded, but any other unrecognised elements will result in an exception.
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
        [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]
-> 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]
    | 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"


-- | Read an {-# ANN #-} pragma and determine if it is intended for HLint.
--   Return Nothing if it is not an HLint pragma, otherwise what it means.
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 :: Comment -> [Classify]
readComment :: Comment -> [Classify]
readComment o :: Comment
o@(Comment True _ x :: String
x)
    | (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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["lint","hlint"]
    = Bool -> String -> [Classify]
f Bool
hash String
x
    where
        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 (String
hint :: String) <- 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 _ = Comment -> String -> [Classify]
forall b. Comment -> String -> b
errorOnComment Comment
o (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


-- Note: Foo may be ("","Foo") or ("Foo",""), return both
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 :: Comment -> String -> b
errorOnComment :: Comment -> String -> b
errorOnComment (Comment b :: Bool
b ann :: SrcSpan
ann x :: String
x) msg :: String
msg = String -> b
forall a. String -> a
exitMessageImpure (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$
    SrcLoc -> String
showSrcLoc (SrcSpan -> SrcLoc
forall si. SrcInfo si => si -> SrcLoc
getPointLoc SrcSpan
ann) 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
b then "{-" else "--") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
b then "-}" else "")