Sockeye: Show global and root module fails first
[barrelfish] / tools / sockeye / SockeyeChecks.hs
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, Universitaetstr. 6, CH-8092 Zurich,
13     Attn: Systems Group.
14 -}
15
16 module SockeyeChecks where
17
18 import Control.Monad.Writer
19
20 import Data.List (nub, sort)
21
22 data FailedCheck t = FailedCheck
23     { inModule :: !String
24     , failed   :: t
25     }
26
27 newtype FailedChecks t = FailedChecks [FailedCheck t]
28
29 instance (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                 in map ((indent ++) . showFail) fs
45             showFail f = (show $ failed f)
46
47 type Checks f = Writer [FailedCheck f]
48
49 failCheck :: String -> t -> Checks t ()
50 failCheck context f = tell [FailedCheck context f]
51
52 runChecks :: Checks f a -> Either (FailedChecks f) a
53 runChecks checks = do
54     let
55         (a, fs) = runWriter checks
56     case fs of
57         [] -> return a
58         _  -> Left $ FailedChecks fs
59
60 checkDuplicates :: (Eq a) => String  -> (a -> t) -> [a] -> (Checks t) ()
61 checkDuplicates context fail xs = do
62     let
63         ds = duplicates xs
64     case ds of
65         [] -> return ()
66         _  -> mapM_ (failCheck context . fail) ds
67     where
68         duplicates [] = []
69         duplicates (x:xs)
70             | x `elem` xs = nub $ [x] ++ duplicates xs
71             | otherwise = duplicates xs