module Yi.Verifier.JavaScript where
import Control.Monad.Writer.Lazy (Writer, mapM_, MonadWriter, tell)
import Data.List (map, dropWhile, drop, filter, length, intersperse)
import qualified Data.DList as D
import Prelude ()
import Yi.Lexer.Alex (Posn, Tok, tokT, tokPosn)
import Yi.Lexer.JavaScript (Token(..), TT)
import Yi.Prelude hiding (mapM_)
import Yi.Syntax.JavaScript hiding (res)
data Error = MultipleFunctionDeclaration String [Posn]
deriving Eq
data Warning = UnreachableCode Posn
deriving Eq
data Report = Err Error
| Warn Warning
deriving Eq
instance Show Error where
show (MultipleFunctionDeclaration n ps) =
"Function `" ++ n ++ "' declared more than once: " ++
concat (intersperse ", " $ map show ps)
instance Show Warning where
show (UnreachableCode pos) =
"Unreachable code at " ++ show pos
instance Show Report where
show (Err e) = "EE " ++ show e
show (Warn w) = "WW " ++ show w
verify :: Tree TT -> Writer (D.DList Report) ()
verify t = do
let topfuns = findFunctions (toList t)
checkMultipleFuns topfuns
mapM_ (checkUnreachable . funBody) topfuns
checkMultipleFuns :: [Statement TT] -> Writer (D.DList Report) ()
checkMultipleFuns stmts = do
let dupFuns = dupsBy ((ttEq) `on` funName) stmts
when (not $ null dupFuns)
(say (Err (MultipleFunctionDeclaration
(nameOf $ tokT $ funName $ head dupFuns)
(map (tokPosn . funName) dupFuns))))
let subFuns = map (findFunctions . funBody) (findFunctions stmts)
mapM_ checkMultipleFuns subFuns
checkUnreachable :: [Statement TT] -> Writer (D.DList Report) ()
checkUnreachable stmts = do
let afterReturn = dropWhile' (not . isReturn) stmts
when (not (null afterReturn))
(say (Warn (UnreachableCode (tokPosn $ firstTok $ head afterReturn))))
ttEq :: Eq t => Tok t -> Tok t -> Bool
ttEq x y = tokT x == tokT y
say :: MonadWriter (D.DList a) m => a -> m ()
say = tell . D.singleton
isReturn :: Statement t -> Bool
isReturn (Return {}) = True
isReturn _ = False
findFunctions :: [Statement t] -> [Statement t]
findFunctions stmts = [ f | f@(FunDecl {}) <- stmts ]
funName :: Statement t -> t
funName (FunDecl _ n _ _) = n
funName _ = undefined
funBody :: Statement t -> [Statement t]
funBody (FunDecl _ _ _ blk) =
case blk of
Block _ stmts _ -> toList stmts
BlockOne stmt -> [stmt]
_ -> []
funBody _ = undefined
nameOf :: Token -> String
nameOf (ValidName n) = n
nameOf _ = undefined
dropWhile' :: (a -> Bool) -> [a] -> [a]
dropWhile' p xs =
let res = dropWhile p xs in
if null res then [] else drop 1 res
dupsBy :: (a -> a -> Bool) -> [a] -> [a]
dupsBy p xs = filter (\x -> length (filter (p x) xs) > 1) xs