never executed always true always false

    1 {-# LANGUAGE ConstraintKinds #-}
    2 {-# LANGUAGE TypeFamilies #-}
    3 
    4 {-# OPTIONS -fno-warn-orphans #-}
    5 
    6 {- |
    7 Module      : NITTA.Model.Time
    8 Description : Types for time description
    9 Copyright   : (c) Aleksandr Penskoi, 2019
   10 License     : BSD3
   11 Maintainer  : aleksandr.penskoi@gmail.com
   12 Stability   : experimental
   13 -}
   14 module NITTA.Model.Time (
   15     VarValTime,
   16     VarValTimeJSON,
   17     Time,
   18     TimeConstraint (..),
   19     TaggedTime (..),
   20 ) where
   21 
   22 import Data.Aeson
   23 import Data.Default
   24 import Data.Typeable
   25 import GHC.Generics
   26 import NITTA.Intermediate.Types
   27 import Numeric.Interval.NonEmpty
   28 
   29 -- | Shortcut for variable ('v'), value ('x') and time ('t') type constrains.
   30 type VarValTime v x t = (Var v, Val x, Time t)
   31 
   32 type VarValTimeJSON v x t = (VarValTime v x t, ToJSONKey v, ToJSON v, ToJSON x, ToJSON t)
   33 
   34 -- | Shortcut for time type constrain.
   35 type Time t = (Default t, Num t, Bounded t, Ord t, Show t, Typeable t, Enum t, Integral t)
   36 
   37 instance ToJSON t => ToJSON (Interval t)
   38 
   39 -- | Time constrain for processor activity.
   40 data TimeConstraint t = TimeConstraint
   41     { tcAvailable :: Interval t
   42     -- ^ Inclusive interval, when value available to transfer.
   43     , tcDuration :: Interval t
   44     -- ^ Inclusive interval, possible for value transfers.
   45     }
   46     deriving (Eq, Generic)
   47 
   48 instance (Show t, Eq t, Bounded t) => Show (TimeConstraint t) where
   49     show TimeConstraint{tcAvailable, tcDuration} = showInf tcAvailable ++ " /P " ++ showInf tcDuration
   50         where
   51             showInf i =
   52                 let a = inf i
   53                     b = sup i
   54                  in if b == maxBound
   55                         then show a ++ "..INF"
   56                         else show a ++ ".." ++ show b
   57 
   58 instance ToJSON tp => ToJSON (TimeConstraint tp)
   59 
   60 -- | Forgoten implementation of tagged time for speculative if statement. Current - dead code.
   61 data TaggedTime tag t = TaggedTime
   62     { tTag :: Maybe tag
   63     , tClock :: t
   64     }
   65     deriving (Typeable, Generic)
   66 
   67 instance Default t => Default (TaggedTime tag t) where
   68     def = TaggedTime Nothing def
   69 
   70 instance (Time t, Show tag) => Show (TaggedTime tag t) where
   71     show (TaggedTime tag t) = show t ++ maybe "" (("!" ++) . show) tag
   72 
   73 instance {-# OVERLAPS #-} Time t => Show (TaggedTime String t) where
   74     show (TaggedTime tag t) = show t ++ maybe "" ("!" ++) tag
   75 
   76 instance Eq t => Eq (TaggedTime tag t) where
   77     (TaggedTime _ a) == (TaggedTime _ b) = a == b
   78 
   79 instance Ord t => Ord (TaggedTime tag t) where
   80     (TaggedTime _ a) `compare` (TaggedTime _ b) = a `compare` b
   81 
   82 instance Enum t => Enum (TaggedTime tag t) where
   83     toEnum i = TaggedTime Nothing $ toEnum i
   84     fromEnum (TaggedTime _ i) = fromEnum i
   85 
   86 instance Num t => Bounded (TaggedTime tag t) where
   87     minBound = TaggedTime Nothing 0
   88     maxBound = TaggedTime Nothing 1000
   89 
   90 instance (Num t, Show tag, Eq tag) => Num (TaggedTime tag t) where
   91     (TaggedTime Nothing a) + (TaggedTime Nothing b) = TaggedTime Nothing (a + b)
   92     (TaggedTime (Just tag) a) + (TaggedTime Nothing b) = TaggedTime (Just tag) (a + b)
   93     (TaggedTime Nothing a) + (TaggedTime (Just tag) b) = TaggedTime (Just tag) (a + b)
   94     (TaggedTime tag_a a) + (TaggedTime tag_b b)
   95         | tag_a == tag_b = TaggedTime tag_a (a + b)
   96         | otherwise = error $ "Not equal time tag! " ++ show tag_a ++ " " ++ show tag_b
   97     fromInteger = TaggedTime Nothing . fromInteger
   98     negate t = t{tClock = negate $ tClock t}
   99     (*) = undefined
  100     abs = undefined
  101     signum = undefined