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


---------------------------------------------------------------------
-- 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 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))


-- | 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
        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
        -- Todo : Replace these with "proper" GHC expressions.
         (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"


-- | 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 :: GHC.Located AnnotationComment -> [Classify]
readComment :: Located AnnotationComment -> [Classify]
readComment 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


-- 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 :: GHC.Located AnnotationComment -> String -> b
errorOnComment :: Located AnnotationComment -> String -> b
errorOnComment 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 "")