Scanner.hs

{- |
Module      :  $Header$
Description :  scan tokens of Haskell sources
Copyright   :  (c) C. Maeder 2010
License     :  BSD

Maintainer  :  chr.maeder@web.de
Stability   :  provisional
Portability :  portable

using parsec as scanner to tokenize haskell sources
and check the spacing

-}

module Language.Haskell.Scanner
  ( splitLines
  , splitBy
  , showScan
  , processScan
  , scan
  , PosTok
  , Diag (..)
  , showDiag
  , showSourcePos
  ) where

import Control.Monad

import Data.Char
import Data.List

import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Pos

-- * monad shortcuts

infixl 1 <<

(<<) :: Monad m => m a -> m b -> m a
(<<) = liftM2 const

infixr 5 <:>

(<:>) :: Monad m => m a -> m [a] -> m [a]
(<:>) = liftM2 (:)

infixr 5 <++>

(<++>) :: Monad m => m [a] -> m [a] -> m [a]
(<++>) = liftM2 (++)

single :: Monad m => m a -> m [a]
single = liftM return

flat :: Monad m => m [[a]] -> m [a]
flat = liftM concat

enclosedBy :: Monad m => m [a] -> m a -> m [a]
enclosedBy p q = q <:> p <++> single q

-- * parsec shortcuts

-- | parse an optional list
optionL :: GenParser tok st [a] -> GenParser tok st [a]
optionL = option []

-- | shortcut for @try . string@
tryString :: String -> CharParser st String
tryString = try . string

-- | nested comments, open and closing strings must have at least two chars
nestedComment :: String -> String -> CharParser st String
nestedComment op cl = case (op, cl) of
  (oh : ot : _, ch : ct : _) ->
    tryString op <++>
    flat (many $ single
          (noneOf [oh, ch]
           <|> try (char ch << notFollowedBy (char ct))
           <|> try (char oh << notFollowedBy (char ot)) <?> "")
          <|> nestedComment op cl)
    <++> string cl
  _ -> error "nestedComment"

-- * haskell tokens

-- | the haskell nested comments
nestComment :: CharParser st String
nestComment = nestedComment "{-" "-}"

-- | line comment without final newline
lineComment :: CharParser st String
lineComment =
  try ((char '-' <:> many1 (char '-'))
       << notFollowedBy (oneOf "!#$%&*+./<=>?@\\^|~"))
  <++> many (noneOf "\n")

-- | text in double quotes
stringLit :: CharParser st String
stringLit = enclosedBy (flat $ many $ single (noneOf "\\\"")
                        <|> char '\\' <:> single anyChar) $ char '\"'

-- | text in single quotes
charLit :: CharParser st String
charLit = tryString "'''" <|>
          enclosedBy (flat $ many $ single (noneOf "\\\'")
                      <|> char '\\' <:> single anyChar)
          (char '\'')

-- | a precise number scanner
number :: Parser String
number =
    try (char '0' <:> single (oneOf "oO")) <++> many octDigit
  <|>
    try (char '0' <:> single (oneOf "xX")) <++> many hexDigit
  <|> many1 digit
          <++> optionL (try (char '.' <:> single digit) <++> many digit)
          <++> optionL (try (oneOf "eE" <:> optionL (single $ oneOf "+-")
                             <++> single digit) <++> many digit)

-- | any character within identifiers
hChar :: Parser Char
hChar = alphaNum <|> oneOf "_'"

-- | lower case identifiers (aka variables)
lId :: Parser String
lId = (char '_' <|> lower) <:> many hChar

-- | upper case identifiers (aka constructors)
uId :: Parser String
uId = upper <:> many hChar

-- | any character within operators
opSym :: Char -> Bool
opSym c = elem c "!#$%&*+-./:<=>?@\\^|~"
  || not (isAscii c) && (isSymbol c || isPunctuation c)

-- | any operator (mainly infixes)
operator :: Parser String
operator = many1 $ satisfy opSym

-- | possible qualified entities: lower or upper case words or symbols
data QualElem = Var | Cons | Sym

-- | a name qualified or not with its representation
data QualName = Name Bool QualElem String

-- | the original string
showQualName :: QualName -> String
showQualName (Name _ _ s) = s

-- | the possible characters starting a name
qIdStart :: Parser Char
qIdStart = satisfy $ \ c -> c == '_' || isLetter c || opSym c

-- | any quoted, qualified, or unqualified name or operator
qId :: Parser QualName
qId = fmap (Name False Var) lId
  <|> fmap (Name False Sym) operator
  <|> do
    n <- uId
    option (Name False Cons n) $ do
      d <- try (char '.' << lookAhead qIdStart)
      Name _ k r <- qId
      return $ Name True k $ n ++ d : r
  <|> do
    let noCh = notFollowedBy (char '\'')
    s <- try (string "'" << lookAhead (letter << noCh)) -- limited recognition
      <|> try (string "''" << noCh)
    Name b k r <- qId
    return $ Name b k $ s ++ r

-- | parse any 'qId' within back ticks. This is more liberal than haskell!
infixOp :: Parser String
infixOp = enclosedBy (fmap showQualName qId) $ char '`'

-- | the separators are newline, comma, semicolon and three kinds of parens
seps :: String
seps = "[({,;})]\n"

-- | beside names and separators we have a couple of more token kinds
data TokenKind = LineComment | BlockComment | Literal | Infix

-- | the data type for tokens
data Token
  = QualName QualName
  | Sep Char
  | Token TokenKind String
  | Start -- ^ the void token at the very beginning

-- | renders the original string without kind information
showToken :: Token -> String
showToken t = case t of
    QualName q -> showQualName q
    Sep c -> [c]
    Token _ s -> s
    Start -> ""

-- | all white spaces except newline
isWhite :: Char -> Bool
isWhite c = isSpace c && c /= '\n'

-- | parsing as many 'isWhite' characters as possible (or none)
white :: Parser String
white = many $ satisfy isWhite

-- | a literal followed by up to two (one for 'charLit') optional magic hashes
literal :: Parser String
literal = let optH = optionL (string "#") in
  charLit <++> optH
  <|> (stringLit <|> number) <++> optionL (char '#' <:> optH)

-- | parse any non-white token
tok :: Parser Token
tok = fmap (Token BlockComment) nestComment
  <|> fmap (Token LineComment) lineComment
  <|> fmap QualName qId
  <|> fmap Sep (oneOf seps)
  <|> fmap (Token Literal) literal
  <|> fmap (Token Infix) infixOp

-- | tokens enriched by positions and following white space
data PosTok = PosTok SourcePos Token String

showPosTok :: PosTok -> String
showPosTok (PosTok _ t s) = showToken t ++ s

-- | attach positions and subsequent 'white' spaces to tokens
posTok :: Parser PosTok
posTok = do
  p <- getPosition
  t <- tok
  w <- white
  return $ PosTok p t w

-- | the start position (without file name)
startPos :: SourcePos
startPos = initialPos ""

-- | the initial 'white' stuff
startTok :: Parser PosTok
startTok = fmap (PosTok startPos Start) white

-- | the final scanner
scan :: Parser [PosTok]
scan = startTok <:> many posTok << eof

-- * splitting and removing

{- | a generic splitting function that keeps the separator as first element
except in the first list. -}
splitBy :: (a -> Bool) -> [a] -> [[a]]
splitBy p l = let (fr, rt) = break p l in fr : case rt of
  [] -> []
  d : tl -> let hd : tll = splitBy p tl in (d : hd) : tll

-- | removing more than two consecutive lists fulfilling the predicate
removeBlankLines :: Int -> ([a] -> Bool) -> [[a]] -> [[a]]
removeBlankLines c p l = case l of
  [] -> []
  x : r ->
    if p x
    then if c > 1
         then removeBlankLines c p r
         else x : removeBlankLines (c + 1) p r
    else x : removeBlankLines 0 p r

-- * message data type

-- | messages with positions
data Diag = Diag SourcePos String

showSourcePos :: SourcePos -> String
showSourcePos p = sourceName p ++ ":" ++ shows (sourceLine p) ":"
 ++ shows (sourceColumn p) ":"

showDiag :: Diag -> String
showDiag (Diag p s) = showSourcePos p ++ ' ' : s

-- * checking tokens

isInfixOp :: Token -> Bool
isInfixOp t = case t of
  QualName (Name _ Sym s) -> notElem s $ map (: []) "!#@\\~"
  Token Infix _ -> True
  _ -> False

isComment :: Token -> Bool
isComment t = case t of
  Token k _ -> case k of
    LineComment -> True
    BlockComment -> True
    _ -> False
  _ -> False

noLineComment :: Token -> Bool
noLineComment t = case t of
  Token LineComment _ -> False
  _ -> True

isSepIn :: String -> Token -> Bool
isSepIn cs t = case t of
  Sep c -> elem c cs
  _ -> False

isIndent :: Token -> Bool
isIndent = isSepIn "\n"

isLineBreak :: PosTok -> Bool
isLineBreak (PosTok _ t _) = isIndent t

isOpPar :: Token -> Bool
isOpPar = isSepIn "[({"

isClPar :: Token -> Bool
isClPar = isSepIn "})]"

isOpParOrInfix :: Token -> Bool
isOpParOrInfix t = isOpPar t || isInfixOp t

isClParOrInfix :: Token -> Bool
isClParOrInfix t = isClPar t || isInfixOp t

isNonPar :: Token -> Bool
isNonPar = isSepIn ",;"

isFstInfixMinusArg :: Token -> Bool
isFstInfixMinusArg t = case t of
  QualName (Name _ k _) -> case k of
    Sym -> False
    _ -> True
  Sep _ -> isClPar t
  Token k _ -> case k of
    Literal -> True
    Infix -> True
    _ -> False
  Start -> False

noSpaceNeededBefore :: Token -> Bool
noSpaceNeededBefore t =
  isSepIn ",;})]" t || showToken t == "@"

noSpaceNeededAfter :: Token -> Bool
noSpaceNeededAfter t =
  isOpPar t || elem (showToken t) (map (: []) "!#-@~")

-- * adjusting tokens

-- | replace all white spaces by blanks
untabify :: SourcePos -> String -> String
untabify p s =
  let p2 = updatePosString p s
      bs = sourceColumn p2 - sourceColumn p
  in replicate bs ' '

untab :: PosTok -> PosTok
untab (PosTok p t w) =
  PosTok p t $ untabify (updatePosString p $ showToken t) w

-- | remove trailing spaces
rmSp :: PosTok -> PosTok
rmSp (PosTok p t _) = PosTok p t ""

-- | append exactly one blank
blank :: PosTok -> PosTok
blank (PosTok p t _) = PosTok p t " "

multipleBlanks :: PosTok -> [Diag]
multipleBlanks (PosTok p t w) = let n = length w in
  [ Diag (updatePosString p $ showToken t)
    $ "multiple (" ++ show n ++ ") blanks"
  | n > 1 ]

-- | tidy up line comments
adjustLineComment :: String -> String
adjustLineComment = ("--" ++)
  . reverse . dropWhile isSpace . reverse
  . (' ' :) . dropWhile isSpace . drop 2 -- cut of initial line comment marker

-- | check if prefix extended by one char from next string is still a prefix
hasLongerPrefix :: String -> String -> String -> Bool
hasLongerPrefix p n s = let ps = map (\ c -> p ++ [c]) n in
  any (`isPrefixOf` s) ps

-- | insert a single blank after prefix
adjustPrefix :: String -> String -> String -> String
adjustPrefix p n s =
   if hasLongerPrefix p n s then s else case stripPrefix p s of
     Nothing -> s
     Just r -> p ++ case dropWhile isWhite r of
         rt@('\n' : _) -> case s of
           '}' : _ -> r
           _ -> rt
         rt -> ' ' : rt

-- | adjust comment at both ends. Input is prefix, suffix and extension chars.
adjustBothEnds :: String -> String -> String -> String -> String
adjustBothEnds p q n s =
    if hasLongerPrefix p n s then s else
    concatMap (reverse . dropWhile isWhite . reverse)
    $ removeBlankLines 0 (all isSpace)
    $ splitBy (== '\n')
    $ reverse $ adjustPrefix (reverse q) n $ reverse $ adjustPrefix p n s

-- | adjust a block comment
adjustComment :: String -> String
adjustComment = adjustBothEnds "{-" "-}" "!#"
    . adjustBothEnds "{-!" "!-}" ""
    . adjustBothEnds "{-#" "#-}" ""

-- * analyse and adjust lines

-- | utility to combine results
(<+>) :: (PosTok, [Diag]) -> ([PosTok], [Diag]) -> ([PosTok], [Diag])
(t, ds) <+> (ts, es) = (t : ts, ds ++ es)

infixr 4 <+>

anaPosTok :: PosTok -> (PosTok, [Diag])
anaPosTok t@(PosTok p u w) = case u of
  Token BlockComment s -> let
    n = adjustComment s
    s5 = take 5 s
    nr = take 5 $ reverse n
    sr = take 5 $ reverse s
    in (PosTok p (Token BlockComment n) w,
       [ Diag p $ "non-conventional comment start: " ++ s5 | s5 /= take 5 n ]
       ++ [ Diag (updatePosString p s) $ "non-conventional comment end: "
            ++ reverse sr | sr /= nr ])
  _ | showToken u == ";" -> (t, [Diag p "use layout instead of ;"])
  _ -> (t, [])

anaLine :: [PosTok] -> ([PosTok], [Diag])
anaLine l = case l of
  [] -> ([], [])
  t0 : r1 -> let (t1@(PosTok p1 u1 w1), cs) = anaPosTok t0 in case r1 of
    [] -> case u1 of
      Token LineComment s -> let
        n = adjustLineComment s
        s4 = take 4 s
        in ([PosTok p1 (Token LineComment n) ""], cs ++
           [Diag p1 $ "leave a single blank after line comment sign: " ++ s4
           | s4 /= take 4 n])
      _ -> ([rmSp t1], cs ++ [Diag p1 "trailing white space" | not (null w1)])
    t2@(PosTok p2 u2 w2) : r2 -> case u1 of
      Start -> (rmSp t1, cs ++ [Diag p1 "leading white space" | not (null w1)])
        <+> anaLine r1
      _ | isIndent u1 -> let (ft, rt) = span (== ' ') w1 in
           (untab t1, cs ++
           [ Diag (updatePosString p1 ft) "use only blanks for indentation"
           | not (null rt) ]) <+> anaLine r1
      _ -> let
        s1 = showToken u1
        s2 = showToken u2
        n1 = length s1
        n2 = length s2
        lt = n1 <= n2
        both = s1 ++ s2
        after = case () of
          _ | isNonPar u1 -> True
            | isOpPar u2 -> False
            | s1 == "\\" -> True
            | isInfixOp u1 -> if isInfixOp u2 then lt else True
            | isInfixOp u2 || s2 == ".." -> False
          _ -> lt
        parsOfBoth = filter (`elem` "[({})]") both
        pos = case both of
             _ : _ : _ -> "between"
             _ | isOpPar u1 -> "after"
               | isClPar u2 -> "before"
             _ -> "here"
        omitSpace = isOpParOrInfix u1 && isClParOrInfix u2
          && not (isInfixOp u1 && isInfixOp u2)
          && (s1 /= ".." || s2 /= "]")
        addSpace = not (noSpaceNeededAfter u1)
          && not (noSpaceNeededBefore u2)
        (newT1, ds) =
          if null w1
          then if addSpace
            then (blank t1, Diag p2
                  ("leave space " ++
                   if after then "after " ++ s1 else "before " ++ s2)
               : [ Diag p1 $ "may be template haskell " ++ both
                 | s1 == "$" ])
            else (t1, [])
          else if omitSpace
            then (rmSp t1,
               [Diag p2 $ "no space needed " ++ pos ++ " " ++ parsOfBoth])
            else if isComment u2
              then (untab t1, [])
              else (blank t1, multipleBlanks t1)
        pt0 = (newT1, cs ++ ds)
        in case r2 of
          [] -> pt0 <+> anaLine r1
          PosTok _ u3 _ : _ -> let
            s3 = showToken u3
            ms = [Diag p2 "put spaces around infix -" | null w1 || null w2 ]
                 ++ multipleBlanks t1 ++ multipleBlanks t2
            in if s2 == "-" && not (noSpaceNeededBefore u3)
                  && isFstInfixMinusArg u1
               then (blank t1, cs ++ ms) <+> anaLine (blank t2 : r2)
               else (if elem s2 ["do", "of"] && s3 /= "{" && noLineComment u3
                 then (newT1,
                   cs ++ Diag p2 ("break line after " ++ show s2) : ds)
                 else pt0) <+> anaLine r1

-- * ensure final newline

isBlankLine :: [PosTok] -> Bool
isBlankLine x = case x of
  [PosTok _ Start _] -> True
  [t] -> isLineBreak t
  _ -> False

removeFinalBlankLines :: [[PosTok]] -> [[PosTok]]
removeFinalBlankLines ll = reverse $ [PosTok startPos (Sep '\n') ""]
  : dropWhile isBlankLine (reverse ll)

-- * main functions

-- | split lines at newline tokens
splitLines :: [PosTok] -> [[PosTok]]
splitLines = splitBy isLineBreak

-- | create adjusted source file
processScan :: [[PosTok]] -> String
processScan = concatMap (concatMap showPosTok . fst . anaLine)
  . removeBlankLines 1 isBlankLine . removeFinalBlankLines

-- | list all diagnostics
showScan :: [[PosTok]] -> [Diag]
showScan = concatMap (snd . anaLine)