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