1{-
2    SockeyeChecks.hs: Helpers to run checks for Sockeye
3
4    Part of Sockeye
5
6    Copyright (c) 2017, ETH Zurich.
7
8    All rights reserved.
9
10    This file is distributed under the terms in the attached LICENSE file.
11    If you do not find this file, copies can be found by writing to:
12    ETH Zurich D-INFK, CAB F.78, Universitaetstrasse 6, CH-8092 Zurich,
13    Attn: Systems Group.
14-}
15
16module SockeyeChecks where
17
18import Control.Monad.Writer
19
20import Data.List (nub, sort)
21
22data FailedCheck t = FailedCheck
23    { inModule :: !String
24    , failed   :: t
25    }
26
27newtype FailedChecks t = FailedChecks [FailedCheck t]
28
29instance (Show t) => Show (FailedChecks t) where
30    show (FailedChecks fs) = 
31        let modules = sort  (nub $  map inModule fs)
32        in unlines $ concat (map showFailsForModule modules)
33        where
34            showFailsForModule name =
35                let
36                    title = "\nIn module '" ++ name ++ "':"
37                    fails = filter (\f -> name == inModule f) fs
38                in case name of
39                    ('@':_) -> "":showFails 0 fails
40                    _       -> title:showFails 1 fails
41            showFails indentLevel fs =
42                let
43                    indent = replicate (indentLevel * 4) ' '
44                    failStrings = nub $ map showFail fs
45                in map (indent ++) failStrings
46            showFail f = (show $ failed f)
47
48type Checks f = Writer [FailedCheck f]
49
50failCheck :: String -> t -> Checks t ()
51failCheck context f = tell [FailedCheck context f]
52
53runChecks :: Checks f a -> Either (FailedChecks f) a
54runChecks checks = do
55    let
56        (a, fs) = runWriter checks
57    case fs of
58        [] -> return a
59        _  -> Left $ FailedChecks fs
60
61checkDuplicates :: (Eq a) => String  -> (a -> t) -> [a] -> (Checks t) ()
62checkDuplicates context fail xs = do
63    let
64        ds = duplicates xs
65    case ds of
66        [] -> return ()
67        _  -> mapM_ (failCheck context . fail) ds
68    where
69        duplicates [] = []
70        duplicates (x:xs)
71            | x `elem` xs = nub $ [x] ++ duplicates xs
72            | otherwise = duplicates xs
73