{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}

-- TODO:
-- ! User configuration.
-- ! Checking for side-effect-less code, e.g. "1;".

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)


-- * Types

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


-- * Instances

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


-- * Main code

-- | The main verifier which calls the sub-verifiers.
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

-- | Given a list of function declarations, checks for multiple function
--   declarations, including the functions' subfunctions.
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))))


-- * Helper functions

-- | Given two @Tok t@, compares the @t@s.
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

-- | Returns a list of the functions in the given block.
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 ]

-- | Given a 'FunDecl', returns the token representing the name.
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

-- | Given a 'FunDecl', returns its inner body as a list.
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

-- | Given a @ValidName@ returns the string representing the name.
nameOf :: Token -> String
nameOf :: Token -> String
nameOf (ValidName String
n) = String
n
nameOf Token
_             = String
forall a. HasCallStack => a
undefined


-- * Misc

-- | Like 'dropWhile' but drops the first element in the result.
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