hlint-1.4: src/Type.hs

{-# LANGUAGE RecordWildCards #-}

module Type where

import HSE.All
import Data.Char
import Data.List
import Data.Maybe
import Data.Ord
import Language.Haskell.HsColour.TTY
import Language.Haskell.HsColour.Colourise


---------------------------------------------------------------------
-- GENERAL DATA TYPES

data Rank = Ignore | Warning | Error
            deriving (Eq,Ord,Show)

-- (modulename,functionname)
-- either being blank implies universal matching
type FuncName = (String,String)


---------------------------------------------------------------------
-- IDEAS/SETTINGS

-- Classify and MatchExp are read from the Settings file
-- Idea are generated by the program
data Idea
    = Classify {func :: FuncName, rank :: Rank, hint :: String}
    | MatchExp {rank :: Rank, hint :: String, lhs :: Exp, rhs :: Exp, side :: Maybe Exp}
    | Idea {func :: FuncName, rank :: Rank, hint :: String, loc :: SrcLoc, from :: String, to :: String}
      deriving Eq

type Setting = Idea


isClassify Classify{} = True; isClassify _ = False
isMatchExp MatchExp{} = True; isMatchExp _ = False


instance Show Idea where
    show MatchExp{..} = unlines $ ("MatchExp " ++ show rank) :
        map (\x -> "  " ++ prettyPrint x) ([lhs,rhs] ++ maybeToList side)
    show Classify{..} = unwords ["Classify",show func,show rank,show hint]

    show Idea{..} = unlines $
        [showSrcLoc loc ++ " " ++ show rank ++ ": " ++ hint] ++ f "Found" from ++ f "Why not" to
        where f msg x = (msg ++ ":") : map ("  "++) (lines x)

    showList = showString . concatMap show


showANSI :: IO (Idea -> String)
showANSI = do
    prefs <- readColourPrefs
    return $ showPrefsANSI prefs

showPrefsANSI :: ColourPrefs -> Idea -> String
showPrefsANSI prefs Idea{..} = unlines $
    [showSrcLoc loc ++ " " ++ show rank ++ ": " ++ hint] ++ f "Found" from ++ f "Why not" to
    where f msg x = (msg ++ ":") : map ("  "++) (lines $ hscolour prefs x)
showPrefsANSI prefs x = show x


-- The real key will be filled in by applyHint
idea rank hint loc from to = Idea ("","") rank hint loc (f from) (f to)
    where f = dropWhile isSpace . prettyPrint
warn mr = idea Warning mr


-- Any 1-letter variable names are assumed to be unification variables
isUnifyVar :: String -> Bool
isUnifyVar [x] = x == '?' || isAlpha x
isUnifyVar _ = False

---------------------------------------------------------------------
-- HINTS

type Hint = Decl -> [Idea]


concatHints :: [Hint] -> Hint
concatHints hs x = concatMap ($x) hs


applyHint :: Hint -> Module -> [Idea]
applyHint h m = [i{func = (name,fromNamed d)}
                | d <- moduleDecls m, i <- sortBy (comparing loc) $ h d]
    where name = moduleName m