{-# LANGUAGE ScopedTypeVariables #-}
module TestHarness (
  allowFailures,
  callTo,
  contains,
  declName,
  doNotation,
  rhsContains,
  findDecls,
  findDeclsCalling,
  findTopLevelDeclsOf,
  globallySelfRecursive,
  ident,
  listComprehension,
  locallySelfRecursive,
  randomChoice,
  run,
  syntaxCheck,
  syntaxCheckWithExts,
  typeSignatureOf,
  ) where

import Prelude
  (Bool (..), Int, IO, Maybe (..), ShowS, String,
   ($), (>), (-), (+), (.), (++), (!!), (==), (||),
   concat, const, either, error, fmap, filter, foldr, id, length,
   map, mapM, maybe, otherwise, return, show)

import qualified System.IO              as IO (readFile) {- needed to avoid encoding problems -}
import qualified Test.HUnit             as HU
  (Assertion, Counts, Test (..), Testable, assertFailure, test)

import Control.Applicative              ((<$>))
import Control.Exception
  (ArithException, ArrayException, ErrorCall, Handler (Handler),
   PatternMatchFail, SomeException, catches, displayException, try)
import Control.Monad                    (foldM, when)
import Data.Generics                    (Data, Typeable, everything, listify, mkQ)
import Data.List                        (elem, intercalate, notElem, null)
import Language.Haskell.Exts
  (Decl (..), Exp (..), Match (..) , Module (..), Name (..), ParseResult (..), Pat (..),
   Rhs (..), SrcSpanInfo, classifyExtension, parseFileContentsWithExts)
import System.Random                    (randomRIO)
import Test.HUnit.Base
  (Node (Label), Test, Counts (Counts), errors, failures, path, performTest)
import Test.HUnit.Text                  (showPath)

{-| Function called by the interpreter, getting the tests to run as the argument. -}
run :: HU.Testable t => [t] -> IO (HU.Counts, ShowS)
run :: forall t. Testable t => [t] -> IO (Counts, ShowS)
run [t]
testables =
  IO (Counts, ShowS)
-> [Handler (Counts, ShowS)] -> IO (Counts, ShowS)
forall a. IO a -> [Handler a] -> IO a
catches
    (((Counts, ShowS) -> t -> IO (Counts, ShowS))
-> (Counts, ShowS) -> [t] -> IO (Counts, ShowS)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Counts, ShowS) -> t -> IO (Counts, ShowS)
forall {t} {a}.
Testable t =>
(Counts, a -> String) -> t -> IO (Counts, a -> String)
performTestUnlessError (Int -> Int -> Int -> Int -> Counts
Counts Int
0 Int
0 Int
0 Int
0, ShowS
forall a. a -> a
id) [t]
testables)
    [(ErrorCall -> IO (Counts, ShowS)) -> Handler (Counts, ShowS)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ErrorCall -> IO (Counts, ShowS)) -> Handler (Counts, ShowS))
-> (ErrorCall -> IO (Counts, ShowS)) -> Handler (Counts, ShowS)
forall a b. (a -> b) -> a -> b
$ \(ErrorCall
e :: ErrorCall)        -> ErrorCall -> IO (Counts, ShowS)
forall {m :: * -> *} {e}.
(Monad m, Exception e) =>
e -> m (Counts, ShowS)
pairWith ErrorCall
e,
     (PatternMatchFail -> IO (Counts, ShowS)) -> Handler (Counts, ShowS)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((PatternMatchFail -> IO (Counts, ShowS))
 -> Handler (Counts, ShowS))
-> (PatternMatchFail -> IO (Counts, ShowS))
-> Handler (Counts, ShowS)
forall a b. (a -> b) -> a -> b
$ \(PatternMatchFail
e :: PatternMatchFail) -> PatternMatchFail -> IO (Counts, ShowS)
forall {m :: * -> *} {e}.
(Monad m, Exception e) =>
e -> m (Counts, ShowS)
pairWith PatternMatchFail
e,
     (ArithException -> IO (Counts, ShowS)) -> Handler (Counts, ShowS)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ArithException -> IO (Counts, ShowS)) -> Handler (Counts, ShowS))
-> (ArithException -> IO (Counts, ShowS))
-> Handler (Counts, ShowS)
forall a b. (a -> b) -> a -> b
$ \(ArithException
e :: ArithException)   -> ArithException -> IO (Counts, ShowS)
forall {m :: * -> *} {e}.
(Monad m, Exception e) =>
e -> m (Counts, ShowS)
pairWith ArithException
e,
     (ArrayException -> IO (Counts, ShowS)) -> Handler (Counts, ShowS)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ArrayException -> IO (Counts, ShowS)) -> Handler (Counts, ShowS))
-> (ArrayException -> IO (Counts, ShowS))
-> Handler (Counts, ShowS)
forall a b. (a -> b) -> a -> b
$ \(ArrayException
e :: ArrayException)   -> ArrayException -> IO (Counts, ShowS)
forall {m :: * -> *} {e}.
(Monad m, Exception e) =>
e -> m (Counts, ShowS)
pairWith ArrayException
e]
  where
    pairWith :: e -> m (Counts, ShowS)
pairWith e
e  =
      (Counts, ShowS) -> m (Counts, ShowS)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> Int -> Int -> Counts
Counts Int
1 Int
1 Int
1 Int
0,
              \String
a -> String
"Encountered runtime error during testing:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ e -> String
forall e. Exception e => e -> String
displayException e
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
a)
    performTestUnlessError :: (Counts, a -> String) -> t -> IO (Counts, a -> String)
performTestUnlessError (Counts
cs, a -> String
s) t
t
      | Counts -> Int
errors Counts
cs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
|| Counts -> Int
failures Counts
cs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      = (Counts, a -> String) -> IO (Counts, a -> String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Counts
cs, a -> String
s)
      | Bool
otherwise
      = do (Counts
cs', ShowS
s') <- ShowS -> Test -> IO (Counts, ShowS)
runTestText ShowS
forall a. a -> a
id (t -> Test
forall t. (Testable t, HasCallStack) => t -> Test
HU.test t
t)
           (Counts, a -> String) -> IO (Counts, a -> String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Counts -> Counts -> Counts
sumCounts Counts
cs Counts
cs', ShowS
s' ShowS -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
s)
    sumCounts :: Counts -> Counts -> Counts
sumCounts (Counts Int
c1 Int
t1 Int
e1 Int
f1) (Counts Int
c2 Int
t2 Int
e2 Int
f2) =
      Int -> Int -> Int -> Int -> Counts
Counts (Int
c1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c2) (Int
t1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
t2) (Int
e1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
e2) (Int
f1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
f2)

{-|
Perform test runs but change the format of output (based on
https://hackage.haskell.org/package/HUnit-1.6.0.0/docs/src/Test-HUnit-Text.html#runTestText
but specified to ShowS)
-}
runTestText :: ShowS -> Test -> IO (Counts, ShowS)
runTestText :: ShowS -> Test -> IO (Counts, ShowS)
runTestText = ReportStart ShowS
-> ReportProblem ShowS
-> ReportProblem ShowS
-> ShowS
-> Test
-> IO (Counts, ShowS)
forall us.
ReportStart us
-> ReportProblem us
-> ReportProblem us
-> us
-> Test
-> IO (Counts, us)
performTest ReportStart ShowS
forall {m :: * -> *} {p} {a}. Monad m => p -> a -> m a
reportStart ReportProblem ShowS
forall {p} {t}.
p -> String -> State -> (String -> t) -> IO (String -> t)
reportError ReportProblem ShowS
forall {p} {t}.
p -> String -> State -> (String -> t) -> IO (String -> t)
reportFailure
  where
    reportStart :: p -> a -> m a
reportStart p
_ = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    reportError :: p -> String -> State -> (String -> t) -> IO (String -> t)
reportError   = String
-> String
-> p
-> String
-> State
-> (String -> t)
-> IO (String -> t)
forall {m :: * -> *} {p} {t}.
Monad m =>
String
-> String
-> p
-> String
-> State
-> (String -> t)
-> m (String -> t)
reportProblem String
"Error:"   String
"Error in:   "
    reportFailure :: p -> String -> State -> (String -> t) -> IO (String -> t)
reportFailure = String
-> String
-> p
-> String
-> State
-> (String -> t)
-> IO (String -> t)
forall {m :: * -> *} {p} {t}.
Monad m =>
String
-> String
-> p
-> String
-> State
-> (String -> t)
-> m (String -> t)
reportProblem String
"Failure:" String
"Failure in: "
    reportProblem :: String
-> String
-> p
-> String
-> State
-> (String -> t)
-> m (String -> t)
reportProblem String
p0 String
p1 p
_ String
msg State
ss String -> t
us = (String -> t) -> m (String -> t)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> t) -> m (String -> t))
-> (String -> t) -> m (String -> t)
forall a b. (a -> b) -> a -> b
$ \String
rest -> String -> t
us (String
line String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
: String
rest)
      where
        line :: String
line  = String
"### " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
kind String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
path' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg
        kind :: String
kind  = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
path' then String
p0 else String
p1
        path' :: String
path' = Path -> String
showPath [Node
x | x :: Node
x@(Label String
_) <- State -> Path
path State
ss]

{-* Common test patterns -}

{-|
Detailed output of correct/incorrect Tests in case of failure
with the option to allow a fixed number of tests to fail.
-}
allowFailures :: Int -> [HU.Test] -> HU.Assertion
allowFailures :: Int -> [Test] -> Assertion
allowFailures Int
limit [Test]
testCases = do
  ([String]
successes, [(String, SomeException)]
failures') <- [(String, Assertion)] -> IO ([String], [(String, SomeException)])
forall {a} {b}. [(a, IO b)] -> IO ([a], [(a, SomeException)])
collectResults [(String
l,Assertion
a) | HU.TestLabel String
l (HU.TestCase Assertion
a) <- [Test]
testCases]
  Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(String, SomeException)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, SomeException)]
failures' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
limit) (Assertion -> Assertion) -> Assertion -> Assertion
forall a b. (a -> b) -> a -> b
$
    String -> Assertion
forall a. HasCallStack => String -> IO a
HU.assertFailure (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n\n"
      [ String
"Too many errors occurred. There are still functions that may be implemented as required."
      , String
"Correct are: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
forall a. Show a => a -> String
show [String]
successes)
      , String
"The following errors occurred:"
      , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n---\n" [ String
"# " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
f | (String
l,SomeException
f) <- [(String, SomeException)]
failures' ]
      ]
  where
    collectResults :: [(a, IO b)] -> IO ([a], [(a, SomeException)])
collectResults = ([[(a, Maybe SomeException)]] -> ([a], [(a, SomeException)]))
-> IO [[(a, Maybe SomeException)]]
-> IO ([a], [(a, SomeException)])
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(a, Maybe SomeException)] -> ([a], [(a, SomeException)])
forall a b. [(a, Maybe b)] -> ([a], [(a, b)])
groupIntoTwoLists ([(a, Maybe SomeException)] -> ([a], [(a, SomeException)]))
-> ([[(a, Maybe SomeException)]] -> [(a, Maybe SomeException)])
-> [[(a, Maybe SomeException)]]
-> ([a], [(a, SomeException)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(a, Maybe SomeException)]] -> [(a, Maybe SomeException)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat)
      (IO [[(a, Maybe SomeException)]] -> IO ([a], [(a, SomeException)]))
-> ([(a, IO b)] -> IO [[(a, Maybe SomeException)]])
-> [(a, IO b)]
-> IO ([a], [(a, SomeException)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, IO b) -> IO [(a, Maybe SomeException)])
-> [(a, IO b)] -> IO [[(a, Maybe SomeException)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(a
l, IO b
action) -> (SomeException -> [(a, Maybe SomeException)])
-> (b -> [(a, Maybe SomeException)])
-> Either SomeException b
-> [(a, Maybe SomeException)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(SomeException
e :: SomeException) -> [(a
l,SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e)]) ([(a, Maybe SomeException)] -> b -> [(a, Maybe SomeException)]
forall a b. a -> b -> a
const [(a
l,Maybe SomeException
forall a. Maybe a
Nothing)]) (Either SomeException b -> [(a, Maybe SomeException)])
-> IO (Either SomeException b) -> IO [(a, Maybe SomeException)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO b -> IO (Either SomeException b)
forall e a. Exception e => IO a -> IO (Either e a)
try IO b
action)
    groupIntoTwoLists :: [(a,Maybe b)] -> ([a],[(a,b)])
    groupIntoTwoLists :: forall a b. [(a, Maybe b)] -> ([a], [(a, b)])
groupIntoTwoLists = ((a, Maybe b) -> ([a], [(a, b)]) -> ([a], [(a, b)]))
-> ([a], [(a, b)]) -> [(a, Maybe b)] -> ([a], [(a, b)])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(a
a,Maybe b
mb) ([a]
ns,[(a, b)]
js) -> ([a], [(a, b)])
-> (b -> ([a], [(a, b)])) -> Maybe b -> ([a], [(a, b)])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ns,[(a, b)]
js) (\b
b -> ([a]
ns,(a
a,b
b)(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:[(a, b)]
js)) Maybe b
mb) ([],[])

randomChoice :: [a] -> IO a
randomChoice :: forall a. [a] -> IO a
randomChoice [a]
xs = do
  Int
r <- (Int, Int) -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
0, [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ [a]
xs [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! Int
r

{-* Syntax predicates -}

{- |
Search a structure for a node satisfying some predicate.
Use case: scan submission code syntax tree.

Also matches the left hand side of function definitions,
so cannot be used to check if a function calls itself.

This will also match explicit imports
when searching for an identifier in the overall module via `ident`.
-}
contains :: (Typeable b, Data a) => (b -> Bool) -> a -> Bool
contains :: forall b a. (Typeable b, Data a) => (b -> Bool) -> a -> Bool
contains b -> Bool
pred = (Bool -> Bool -> Bool) -> GenericQ Bool -> GenericQ Bool
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything Bool -> Bool -> Bool
(||) (Bool -> (b -> Bool) -> a -> Bool
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ Bool
False b -> Bool
pred)

{- |
Same as `contains`, but only considers the right hand side of equations.
Can therefore be used to check for self recursion and avoids overlap with imports.
-}
rhsContains :: (Typeable b, Data a) => (b -> Bool) -> a -> Bool
rhsContains :: forall b a. (Typeable b, Data a) => (b -> Bool) -> a -> Bool
rhsContains b -> Bool
pred = (Rhs SrcSpanInfo -> Bool) -> a -> Bool
forall b a. (Typeable b, Data a) => (b -> Bool) -> a -> Bool
contains ((b -> Bool) -> Rhs SrcSpanInfo -> Bool
forall b a. (Typeable b, Data a) => (b -> Bool) -> a -> Bool
contains b -> Bool
pred :: Rhs SrcSpanInfo -> Bool)

{-* Predicates to use with `contains` and `rhsContains` -}

{- |
True if identifier is the given String.
-}
ident :: String -> Name SrcSpanInfo -> Bool
ident :: String -> Name SrcSpanInfo -> Bool
ident String
name (Ident SrcSpanInfo
_ String
name')  | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name'           = Bool
True
ident String
name (Symbol SrcSpanInfo
_ String
name') | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"("String -> ShowS
forall a. [a] -> [a] -> [a]
++String
name'String -> ShowS
forall a. [a] -> [a] -> [a]
++String
")" = Bool
True
ident String
_    Name SrcSpanInfo
_                                          = Bool
False

{- |
True if expression is a list comprehension.
-}
listComprehension :: Exp SrcSpanInfo -> Bool
listComprehension :: Exp SrcSpanInfo -> Bool
listComprehension (ListComp {}) = Bool
True
listComprehension Exp SrcSpanInfo
_             = Bool
False

{- |
True if expression is a do block.
-}
doNotation :: Exp SrcSpanInfo -> Bool
doNotation :: Exp SrcSpanInfo -> Bool
doNotation (Do SrcSpanInfo
_ [Stmt SrcSpanInfo]
_) = Bool
True
doNotation Exp SrcSpanInfo
_        = Bool
False

{- |
True if declaration is defined recursively,
but only if the recursion is stated in the righthand side of the equation.
Recursion through indirection, e.g. via a chain of global definitions is not detected.
This is usually sufficient if 'allowAdding' is set to False.

This returns a false positive if a binding in the righthand side
uses the definition's name but goes unused.
-}
locallySelfRecursive :: Decl SrcSpanInfo -> Bool
locallySelfRecursive :: Decl SrcSpanInfo -> Bool
locallySelfRecursive Decl SrcSpanInfo
decl = case Decl SrcSpanInfo
decl of
  (FunBind SrcSpanInfo
_ matches :: [Match SrcSpanInfo]
matches@(Match SrcSpanInfo
aMatch:[Match SrcSpanInfo]
_))  -> (Name SrcSpanInfo -> Bool) -> [Match SrcSpanInfo] -> Bool
forall b a. (Typeable b, Data a) => (b -> Bool) -> a -> Bool
rhsContains (Name SrcSpanInfo -> Name SrcSpanInfo -> Bool
forall {l}. Name l -> Name SrcSpanInfo -> Bool
sameIdent (Name SrcSpanInfo -> Name SrcSpanInfo -> Bool)
-> Name SrcSpanInfo -> Name SrcSpanInfo -> Bool
forall a b. (a -> b) -> a -> b
$ Match SrcSpanInfo -> Name SrcSpanInfo
matchName Match SrcSpanInfo
aMatch) [Match SrcSpanInfo]
matches
  (PatBind SrcSpanInfo
_ (PVar SrcSpanInfo
_ Name SrcSpanInfo
name) Rhs SrcSpanInfo
rhs Maybe (Binds SrcSpanInfo)
_) -> (Name SrcSpanInfo -> Bool) -> Rhs SrcSpanInfo -> Bool
forall b a. (Typeable b, Data a) => (b -> Bool) -> a -> Bool
contains (Name SrcSpanInfo -> Name SrcSpanInfo -> Bool
forall {l}. Name l -> Name SrcSpanInfo -> Bool
sameIdent Name SrcSpanInfo
name) Rhs SrcSpanInfo
rhs
  Decl SrcSpanInfo
_                               -> Bool
False
  where
    sameIdent :: Name l -> Name SrcSpanInfo -> Bool
sameIdent (Ident l
_ String
n1) = String -> Name SrcSpanInfo -> Bool
ident String
n1
    sameIdent (Symbol l
_ String
n1) = String -> Name SrcSpanInfo -> Bool
ident (String -> Name SrcSpanInfo -> Bool)
-> String -> Name SrcSpanInfo -> Bool
forall a b. (a -> b) -> a -> b
$ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

{- |
True if declaration is defined recursively,
taking the entire module into account.

This returns a false positive if a binding in a righthand side
uses the definition's name but goes unused.
-}
globallySelfRecursive :: Module SrcSpanInfo -> Decl SrcSpanInfo -> Bool
globallySelfRecursive :: Module SrcSpanInfo -> Decl SrcSpanInfo -> Bool
globallySelfRecursive Module SrcSpanInfo
mod Decl SrcSpanInfo
decl = let name :: String
name = Decl SrcSpanInfo -> String
declName Decl SrcSpanInfo
decl
  in String
name String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String -> Module SrcSpanInfo -> [String]
forall a. Data a => String -> a -> [String]
findDeclsCalling String
name Module SrcSpanInfo
mod

{- |
True if declaration is a type signature of the given function name.
-}
typeSignatureOf :: String -> Decl SrcSpanInfo -> Bool
typeSignatureOf :: String -> Decl SrcSpanInfo -> Bool
typeSignatureOf String
name (TypeSig SrcSpanInfo
_ [Name SrcSpanInfo]
xs Type SrcSpanInfo
_) = (Name SrcSpanInfo -> Bool) -> [Name SrcSpanInfo] -> Bool
forall b a. (Typeable b, Data a) => (b -> Bool) -> a -> Bool
contains (String -> Name SrcSpanInfo -> Bool
ident String
name) [Name SrcSpanInfo]
xs
typeSignatureOf String
_    Decl SrcSpanInfo
_                = Bool
False

{- |
True if name appears directly or indirectly in the declaration,
considering the entire module.

Used to detect if student code contains required exercise components
when 'AllowAdding' is set to True.
-}
callTo :: String -> Module SrcSpanInfo -> Decl SrcSpanInfo -> Bool
callTo :: String -> Module SrcSpanInfo -> Decl SrcSpanInfo -> Bool
callTo String
name Module SrcSpanInfo
mod Decl SrcSpanInfo
decl = Decl SrcSpanInfo -> String
declName Decl SrcSpanInfo
decl String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String -> Module SrcSpanInfo -> [String]
forall a. Data a => String -> a -> [String]
findDeclsCalling String
name Module SrcSpanInfo
mod

{-* Performing syntax checks -}

{- |
Run an assertion on the submission module's syntax tree.

Only enables language extensions explicitly listed in the student's submission file.
Using any hidden default extensions will cause a parse error.
-}
syntaxCheck :: (Module SrcSpanInfo -> HU.Assertion) -> HU.Assertion
syntaxCheck :: (Module SrcSpanInfo -> Assertion) -> Assertion
syntaxCheck = [String] -> (Module SrcSpanInfo -> Assertion) -> Assertion
syntaxCheckWithExts []

{- |
Same as `syntaxCheck`, but takes a list of extensions to enable
on top of what is found in the file.
-}
syntaxCheckWithExts :: [String] -> (Module SrcSpanInfo -> HU.Assertion) -> HU.Assertion
syntaxCheckWithExts :: [String] -> (Module SrcSpanInfo -> Assertion) -> Assertion
syntaxCheckWithExts [String]
exts Module SrcSpanInfo -> Assertion
check = do
  String
contents <- String -> IO String
IO.readFile String
"Submission.hs"
  let mod :: Module SrcSpanInfo
mod = case [Extension] -> String -> ParseResult (Module SrcSpanInfo)
parseFileContentsWithExts ((String -> Extension) -> [String] -> [Extension]
forall a b. (a -> b) -> [a] -> [b]
map String -> Extension
classifyExtension [String]
exts) String
contents of
              ParseOk Module SrcSpanInfo
mod'    -> Module SrcSpanInfo
mod'
              ParseFailed SrcLoc
l String
e -> String -> Module SrcSpanInfo
forall a. HasCallStack => String -> a
error (String -> Module SrcSpanInfo) -> String -> Module SrcSpanInfo
forall a b. (a -> b) -> a -> b
$ String
"Parsing file contents failed at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SrcLoc -> String
forall a. Show a => a -> String
show SrcLoc
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e
  Module SrcSpanInfo -> Assertion
check Module SrcSpanInfo
mod

{-* Syntax queries -}

{- |
Query a module's syntax tree for all top level function declarations and constants.
-}
findTopLevelDeclsOf :: String -> Module SrcSpanInfo -> [Decl SrcSpanInfo]
findTopLevelDeclsOf :: String -> Module SrcSpanInfo -> [Decl SrcSpanInfo]
findTopLevelDeclsOf String
_    XmlPage   {} = [] -- ignore non modules
findTopLevelDeclsOf String
_    XmlHybrid {} = [] -- ignore non modules
findTopLevelDeclsOf String
name (Module SrcSpanInfo
_ Maybe (ModuleHead SrcSpanInfo)
_ [ModulePragma SrcSpanInfo]
_ [ImportDecl SrcSpanInfo]
_ [Decl SrcSpanInfo]
decls) = (Decl SrcSpanInfo -> Bool)
-> [Decl SrcSpanInfo] -> [Decl SrcSpanInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
name) (String -> Bool)
-> (Decl SrcSpanInfo -> String) -> Decl SrcSpanInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decl SrcSpanInfo -> String
declName) [Decl SrcSpanInfo]
decls

{- |
Query a syntax tree for all declarations and constants.
This includes let and where bindings.
-}
findDecls :: Data a => a -> [Decl SrcSpanInfo]
findDecls :: forall a. Data a => a -> [Decl SrcSpanInfo]
findDecls = (Decl SrcSpanInfo -> Bool)
-> forall a. Data a => a -> [Decl SrcSpanInfo]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify ((Decl SrcSpanInfo -> Bool)
 -> forall a. Data a => a -> [Decl SrcSpanInfo])
-> (Decl SrcSpanInfo -> Bool)
-> forall a. Data a => a -> [Decl SrcSpanInfo]
forall a b. (a -> b) -> a -> b
$ Bool -> Decl SrcSpanInfo -> Bool
forall a b. a -> b -> a
const Bool
True

{- |
Extract the name of a declaration.
-}
declName :: Decl SrcSpanInfo -> String
declName :: Decl SrcSpanInfo -> String
declName Decl SrcSpanInfo
decl = case Decl SrcSpanInfo
decl of
  (FunBind SrcSpanInfo
_ (Match SrcSpanInfo
aMatch:[Match SrcSpanInfo]
_))  -> Name SrcSpanInfo -> String
forall {l}. Name l -> String
getName (Name SrcSpanInfo -> String) -> Name SrcSpanInfo -> String
forall a b. (a -> b) -> a -> b
$ Match SrcSpanInfo -> Name SrcSpanInfo
matchName Match SrcSpanInfo
aMatch
  (PatBind SrcSpanInfo
_ (PVar SrcSpanInfo
_ Name SrcSpanInfo
name) Rhs SrcSpanInfo
_ Maybe (Binds SrcSpanInfo)
_) -> Name SrcSpanInfo -> String
forall {l}. Name l -> String
getName Name SrcSpanInfo
name
  Decl SrcSpanInfo
_                               -> String
""
  where
    getName :: Name l -> String
getName (Ident l
_ String
n) = String
n
    getName (Symbol l
_ String
n) = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

{- |
Query a syntax tree for all declaration names containing the given name.
This also takes indirecting bindings into account.
-}
findDeclsCalling :: Data a => String -> a -> [String]
findDeclsCalling :: forall a. Data a => String -> a -> [String]
findDeclsCalling String
name a
tree = [String] -> [String] -> [String]
search [] [String
name]
  where
    search :: [String] -> [String] -> [String]
search [String]
seen (String
x:[String]
xs) =
      let newHits :: [String]
newHits = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
seen) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Decl SrcSpanInfo -> String) -> [Decl SrcSpanInfo] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Decl SrcSpanInfo -> String
declName ([Decl SrcSpanInfo] -> [String]) -> [Decl SrcSpanInfo] -> [String]
forall a b. (a -> b) -> a -> b
$
            (Decl SrcSpanInfo -> Bool)
-> forall a. Data a => a -> [Decl SrcSpanInfo]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify ((Name SrcSpanInfo -> Bool) -> Decl SrcSpanInfo -> Bool
forall b a. (Typeable b, Data a) => (b -> Bool) -> a -> Bool
rhsContains ((Name SrcSpanInfo -> Bool) -> Decl SrcSpanInfo -> Bool)
-> (Name SrcSpanInfo -> Bool) -> Decl SrcSpanInfo -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Name SrcSpanInfo -> Bool
ident String
x) a
tree
      in [String] -> [String] -> [String]
search ([String]
seen [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
newHits) ([String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
newHits)
    search [String]
seen [] = [String]
seen

matchName :: Match SrcSpanInfo -> Name SrcSpanInfo
matchName :: Match SrcSpanInfo -> Name SrcSpanInfo
matchName (Match SrcSpanInfo
_ Name SrcSpanInfo
n [Pat SrcSpanInfo]
_ Rhs SrcSpanInfo
_ Maybe (Binds SrcSpanInfo)
_)        = Name SrcSpanInfo
n
matchName (InfixMatch SrcSpanInfo
_ Pat SrcSpanInfo
_ Name SrcSpanInfo
n [Pat SrcSpanInfo]
_ Rhs SrcSpanInfo
_ Maybe (Binds SrcSpanInfo)
_) = Name SrcSpanInfo
n