never executed always true always false

    1 {-# LANGUAGE ConstraintKinds #-}
    2 {-# LANGUAGE FunctionalDependencies #-}
    3 
    4 {- |
    5 Module      : NITTA.Model.Problems.Bind
    6 Description : Function distribution between processor units
    7 Copyright   : (c) Aleksandr Penskoi, 2019
    8 License     : BSD3
    9 Maintainer  : aleksandr.penskoi@gmail.com
   10 Stability   : experimental
   11 -}
   12 module NITTA.Model.Problems.Bind (
   13     Bind (..),
   14     BindProblem (..),
   15     binds2bindGroup,
   16 ) where
   17 
   18 import Data.Map.Strict qualified as M
   19 import Data.String.ToString
   20 import Data.String.Utils qualified as S
   21 import GHC.Generics
   22 import NITTA.Intermediate.Types
   23 import NITTA.Model.ProcessorUnits.Types (UnitTag)
   24 import NITTA.Utils.Base (unionsMap)
   25 
   26 data Bind tag v x
   27     = SingleBind tag (F v x)
   28     | GroupBind {isObviousBinds :: Bool, bindGroup :: M.Map tag [F v x]}
   29     deriving (Generic, Eq)
   30 
   31 binds2bindGroup :: UnitTag tag => [(tag, F v x)] -> M.Map tag [F v x]
   32 binds2bindGroup binds =
   33     foldl
   34         ( \st (tag, f) ->
   35             M.alter
   36                 ( \case
   37                     (Just fs) -> Just $ f : fs
   38                     Nothing -> Just [f]
   39                 )
   40                 tag
   41                 st
   42         )
   43         M.empty
   44         binds
   45 
   46 instance UnitTag tag => Show (Bind tag v x) where
   47     show (SingleBind uTag f) = "Bind " <> showFAndTag (f, uTag)
   48     show (GroupBind{isObviousBinds, bindGroup}) =
   49         concat
   50             [ "Binds "
   51             , if isObviousBinds then "obviousBinds " else ""
   52             , S.join "; " (map showFsAndTag $ M.assocs bindGroup)
   53             ]
   54 
   55 showFAndTag :: UnitTag tag => (F v x, tag) -> String
   56 showFAndTag (f, tag) = toString tag <> " <- " <> show f
   57 
   58 showFsAndTag :: (ToString a1, Show a2) => (a1, [a2]) -> String
   59 showFsAndTag (tag, fs) = toString tag <> " <- " <> S.join ", " (map show fs)
   60 
   61 class BindProblem u tag v x | u -> tag v x where
   62     bindOptions :: u -> [Bind tag v x]
   63     bindDecision :: u -> Bind tag v x -> u
   64 
   65 instance Var v => Variables (Bind tab v x) v where
   66     variables (SingleBind _tag f) = variables f
   67     variables GroupBind{bindGroup} = unionsMap variables $ concat $ M.elems bindGroup
   68 
   69 instance WithFunctions (Bind tag v x) (F v x) where
   70     functions (SingleBind _tag f) = [f]
   71     functions GroupBind{bindGroup} = concat $ M.elems bindGroup