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