never executed always true always false

    1 {-# LANGUAGE AllowAmbiguousTypes #-}
    2 {-# LANGUAGE PartialTypeSignatures #-}
    3 {-# LANGUAGE TypeFamilies #-}
    4 
    5 {- |
    6 Module      : NITTA.Model.ProcessIntegrity
    7 Description : Checking the target process integrity
    8 Copyright   : (c) Artyom Kostyuchik, Aleksandr Penskoi, 2022
    9 License     : BSD3
   10 Maintainer  : aleksandr.penskoi@gmail.com
   11 Stability   : experimental
   12 -}
   13 module NITTA.Model.ProcessIntegrity (
   14     ProcessIntegrity (checkProcessIntegrity),
   15 ) where
   16 
   17 import Data.Either
   18 import Data.List qualified as L
   19 import Data.Map.Strict qualified as M
   20 import Data.Maybe
   21 import Data.Set qualified as S
   22 import Data.String.Utils qualified as S
   23 import NITTA.Model.ProcessorUnits
   24 import NITTA.Utils
   25 
   26 class ProcessIntegrity u where
   27     checkProcessIntegrity :: u -> Either String ()
   28 
   29 instance ProcessorUnit (pu v x t) v x t => ProcessIntegrity (pu v x t) where
   30     checkProcessIntegrity pu =
   31         collectChecks
   32             [ checkVerticalRelations (up2down pu) (pid2intermediate pu) (pid2endpoint pu) "intermediate not related to endpoint"
   33             , checkVerticalRelations (down2up pu) (pid2endpoint pu) (pid2intermediate pu) "endpoint not related to intermediate"
   34             , checkVerticalRelations (up2down pu) (pid2endpoint pu) (pid2instruction pu) "endpoint not related to instruction"
   35             , checkVerticalRelations (down2up pu) (pid2instruction pu) (pid2endpoint pu) "instruction not related to endpoint"
   36             ]
   37 
   38 checkVerticalRelations f dom codom errmsg =
   39     collectChecks
   40         $ map
   41             ( \x ->
   42                 let ys = M.findWithDefault S.empty x f
   43                  in if any (`M.member` codom) $ S.elems ys
   44                         then Right ()
   45                         else Left $ errmsg <> ": " <> show (dom M.! x)
   46             )
   47         $ M.keys dom
   48 
   49 -- TODO: #205 Divider: missing vertical relation between Do instruction and Endpoint
   50 skipIntegrityErrors = ["instruction not related to endpoint: Instruction: Do"]
   51 
   52 collectChecks checks = case lefts checks of
   53     [] -> Right ()
   54     errs -> case filter (`L.notElem` skipIntegrityErrors) errs of
   55         [] -> Right ()
   56         errs' -> Left $ S.join "; " errs'
   57 
   58 relationsMap pairs = M.fromList $ map merge $ L.groupBy (\a b -> fst a == fst b) $ L.sortOn fst pairs
   59     where
   60         merge xs@((a, _) : _) = (a, S.fromList $ map snd xs)
   61         merge _ = error "internal error"
   62 
   63 up2down pu = relationsMap $ mapMaybe get $ relations $ process pu
   64     where
   65         get Vertical{vUp, vDown} = Just (vUp, vDown)
   66         get _ = Nothing
   67 
   68 down2up pu = relationsMap $ mapMaybe get $ relations $ process pu
   69     where
   70         get Vertical{vUp, vDown} = Just (vDown, vUp)
   71         get _ = Nothing
   72 
   73 pid2intermediate pu = M.fromList $ mapMaybe get $ steps $ process pu
   74     where
   75         get s@Step{pID}
   76             | Just f <- getIntermediate s = Just (pID, f)
   77             | otherwise = Nothing
   78 
   79 pid2endpoint pu = M.fromList $ mapMaybe get $ steps $ process pu
   80     where
   81         get s@Step{pID}
   82             | Just ep <- getEndpoint s = Just (pID, ep)
   83             | otherwise = Nothing
   84 
   85 pid2instruction pu = M.fromList $ mapMaybe get $ steps $ process pu
   86     where
   87         get s@Step{pID}
   88             | Just instr <- getInstruction s = Just (pID, instr)
   89             | otherwise = Nothing