{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}

{- |
Module      : NITTA.Model.ProcessorUnits.Types
Description : Set of types for process unit description
Copyright   : (c) Aleksandr Penskoi, 2021
License     : BSD3
Maintainer  : aleksandr.penskoi@gmail.com
Stability   : experimental
-}
module NITTA.Model.ProcessorUnits.Types (
    -- * Processor unit
    UnitTag (..),
    ProcessorUnit (..),
    bind,
    allowToProcess,
    NextTick (..),
    ParallelismType (..),

    -- * Process description
    Process (..),
    ProcessStepID,
    Step (..),
    StepInfo (..),
    Relation (..),
    descent,
    whatsHappen,
    extractInstructionAt,
    withShift,
    isRefactorStep,
    isAllocationStep,

    -- * Control
    Controllable (..),
    SignalTag (..),
    UnambiguouslyDecode (..),
    Connected (..),
    ByTime (..),
    SignalValue (..),
    (+++),

    -- * IO
    IOConnected (..),
    InputPortTag (..),
    OutputPortTag (..),
    InoutPortTag (..),
) where

import Data.Aeson (ToJSON)
import Data.Default
import Data.Either
import Data.Kind
import Data.List qualified as L
import Data.List.Utils (replace)
import Data.Maybe
import Data.Set qualified as S
import Data.String
import Data.String.Interpolate
import Data.String.ToString
import Data.Text qualified as T
import Data.Typeable
import GHC.Generics (Generic)
import NITTA.Intermediate.Types
import NITTA.Model.Problems.Endpoint
import NITTA.Model.Time
import Numeric.Interval.NonEmpty
import Numeric.Interval.NonEmpty qualified as I
import Prettyprinter

-- | Class for processor unit tag or "name"
class (Typeable tag, Ord tag, ToString tag, IsString tag, Semigroup tag) => UnitTag tag where
    -- | Whether the value can be used as a template or not
    isTemplate :: tag -> Bool

    -- | Create tag from the template and index
    fromTemplate :: tag -> String -> tag

instance UnitTag T.Text where
    isTemplate :: Text -> Bool
isTemplate Text
tag = Text -> Text -> Bool
T.isInfixOf (String -> Text
T.pack String
"{x}") Text
tag
    fromTemplate :: Text -> String -> Text
fromTemplate Text
tag String
index = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace (String -> Text
T.pack String
"{x}") (String -> Text
T.pack String
index) Text
tag

instance UnitTag String where
    isTemplate :: String -> Bool
isTemplate String
tag = String
"{x}" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isInfixOf` String
tag
    fromTemplate :: String -> String -> String
fromTemplate String
tag String
index = String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"{x}" String
index String
tag

-- | Processor unit parallelism type
data ParallelismType
    = -- | All operations can be performed in parallel mode
      Full
    | -- | All operations can be performed in pipeline mode
      Pipeline
    | -- | Other processor units
      None
    deriving (Int -> ParallelismType -> String -> String
[ParallelismType] -> String -> String
ParallelismType -> String
(Int -> ParallelismType -> String -> String)
-> (ParallelismType -> String)
-> ([ParallelismType] -> String -> String)
-> Show ParallelismType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ParallelismType -> String -> String
showsPrec :: Int -> ParallelismType -> String -> String
$cshow :: ParallelismType -> String
show :: ParallelismType -> String
$cshowList :: [ParallelismType] -> String -> String
showList :: [ParallelismType] -> String -> String
Show, (forall x. ParallelismType -> Rep ParallelismType x)
-> (forall x. Rep ParallelismType x -> ParallelismType)
-> Generic ParallelismType
forall x. Rep ParallelismType x -> ParallelismType
forall x. ParallelismType -> Rep ParallelismType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ParallelismType -> Rep ParallelismType x
from :: forall x. ParallelismType -> Rep ParallelismType x
$cto :: forall x. Rep ParallelismType x -> ParallelismType
to :: forall x. Rep ParallelismType x -> ParallelismType
Generic, ParallelismType -> ParallelismType -> Bool
(ParallelismType -> ParallelismType -> Bool)
-> (ParallelismType -> ParallelismType -> Bool)
-> Eq ParallelismType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParallelismType -> ParallelismType -> Bool
== :: ParallelismType -> ParallelismType -> Bool
$c/= :: ParallelismType -> ParallelismType -> Bool
/= :: ParallelismType -> ParallelismType -> Bool
Eq)

instance ToJSON ParallelismType

{- | Process unit - part of NITTA process with can execute a function from
intermediate representation:

1. get function for execution ('tryBind');

2. store computational process description ('process');

3. other features implemented by different type classes (see above and in
   "NITTA.Model.Problems").
-}
class VarValTime v x t => ProcessorUnit u v x t | u -> v x t where
    -- If the processor unit can execute a function, then it will return the PU
    -- model with already bound function (only registeration, actual scheduling
    -- will be happening later). If not, it will return @Left@ value with a
    -- specific reason (e.g., not support or all internal resources is over).
    tryBind :: F v x -> u -> Either String u

    -- Get a computational process description. If the processor unit embedded
    -- another PUs (like "NITTA.Model.Networks.Bus"), the description should
    -- contain process steps for all PUs.
    --
    -- 'ProcessStepID' may change from one call to another.
    process :: u -> Process t (StepInfo v x t)

    -- | Indicates what type of parallelism is supported by 'ProcessorUnit'
    parallelismType :: u -> ParallelismType
    parallelismType u
_ = ParallelismType
None

    -- | Provide the processor unit size. At the moment it's just the number of subprocessors
    puSize :: u -> Float
    puSize u
_ = Float
1

bind :: F v x -> u -> u
bind F v x
f u
pu = case F v x -> u -> Either String u
forall u v x t.
ProcessorUnit u v x t =>
F v x -> u -> Either String u
tryBind F v x
f u
pu of
    Right u
pu' -> u
pu'
    Left String
err -> String -> u
forall a. HasCallStack => String -> a
error (String -> u) -> String -> u
forall a b. (a -> b) -> a -> b
$ String
"can't bind function: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err

allowToProcess :: F v x -> b -> Bool
allowToProcess F v x
f b
pu = Either String b -> Bool
forall a b. Either a b -> Bool
isRight (Either String b -> Bool) -> Either String b -> Bool
forall a b. (a -> b) -> a -> b
$ F v x -> b -> Either String b
forall u v x t.
ProcessorUnit u v x t =>
F v x -> u -> Either String u
tryBind F v x
f b
pu

class NextTick u t | u -> t where
    nextTick :: u -> t

instance ProcessorUnit u v x t => NextTick u t where
    nextTick :: u -> t
nextTick = Process t (StepInfo v x t) -> t
forall u t. NextTick u t => u -> t
nextTick (Process t (StepInfo v x t) -> t)
-> (u -> Process t (StepInfo v x t)) -> u -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. u -> Process t (StepInfo v x t)
forall u v x t.
ProcessorUnit u v x t =>
u -> Process t (StepInfo v x t)
process

---------------------------------------------------------------------

{- | Computational process description. It was designed in ISO 15926 style, with
separated data and relations storage.
-}
data Process t i = Process
    { forall t i. Process t i -> [Step t i]
steps :: [Step t i]
    -- ^ All process steps desctiption.
    , forall t i. Process t i -> [Relation]
relations :: [Relation]
    -- ^ List of relationships between process steps (see 'Relation').
    , forall t i. Process t i -> t
nextTick_ :: t
    -- ^ Next tick for instruction. Note: instruction /= endpoint.
    , forall t i. Process t i -> Int
nextUid :: ProcessStepID
    -- ^ Next process step ID
    }
    deriving ((forall x. Process t i -> Rep (Process t i) x)
-> (forall x. Rep (Process t i) x -> Process t i)
-> Generic (Process t i)
forall x. Rep (Process t i) x -> Process t i
forall x. Process t i -> Rep (Process t i) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall t i x. Rep (Process t i) x -> Process t i
forall t i x. Process t i -> Rep (Process t i) x
$cfrom :: forall t i x. Process t i -> Rep (Process t i) x
from :: forall x. Process t i -> Rep (Process t i) x
$cto :: forall t i x. Rep (Process t i) x -> Process t i
to :: forall x. Rep (Process t i) x -> Process t i
Generic)

instance (Time t, Show i) => Pretty (Process t i) where
    pretty :: forall ann. Process t i -> Doc ann
pretty Process t i
p =
        [__i|
            Process:
                steps: #{ showList' $ reverse $ steps p }
                relations: #{ showList' $ relations p }
                nextTick: #{ nextTick p }
                nextUid: #{ nextUid p }
        |]
        where
            showList' :: [src] -> Doc ann
showList' [] = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
""
            showList' [src]
xs = Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
8 ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann]
lst)
                where
                    lst :: [Doc ann]
lst =
                        ((Int, src) -> Doc ann) -> [(Int, src)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc ann) -> ((Int, src) -> Text) -> (Int, src) -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Int
ix, src
value) -> [i|#{ ix }) #{ value }|] :: T.Text)) ([(Int, src)] -> [Doc ann]) -> [(Int, src)] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$
                            [Int] -> [src] -> [(Int, src)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [src]
xs

instance (ToJSON t, ToJSON i) => ToJSON (Process t i)

instance Default t => Default (Process t i) where
    def :: Process t i
def = Process{steps :: [Step t i]
steps = [], relations :: [Relation]
relations = [], nextTick_ :: t
nextTick_ = t
forall a. Default a => a
def, nextUid :: Int
nextUid = Int
forall a. Default a => a
def}

instance {-# OVERLAPS #-} NextTick (Process t si) t where
    nextTick :: Process t si -> t
nextTick = Process t si -> t
forall t i. Process t i -> t
nextTick_

instance Ord t => WithFunctions (Process t (StepInfo v x t)) (F v x) where
    functions :: Process t (StepInfo v x t) -> [F v x]
functions Process{[Step t (StepInfo v x t)]
steps :: forall t i. Process t i -> [Step t i]
steps :: [Step t (StepInfo v x t)]
steps} = (Step t (StepInfo v x t) -> Maybe (F v x))
-> [Step t (StepInfo v x t)] -> [F v x]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Step t (StepInfo v x t) -> Maybe (F v x)
forall {t} {v} {x} {t}. Step t (StepInfo v x t) -> Maybe (F v x)
get ([Step t (StepInfo v x t)] -> [F v x])
-> [Step t (StepInfo v x t)] -> [F v x]
forall a b. (a -> b) -> a -> b
$ (Step t (StepInfo v x t) -> t)
-> [Step t (StepInfo v x t)] -> [Step t (StepInfo v x t)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (Interval t -> t
forall a. Interval a -> a
I.inf (Interval t -> t)
-> (Step t (StepInfo v x t) -> Interval t)
-> Step t (StepInfo v x t)
-> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Step t (StepInfo v x t) -> Interval t
forall t i. Step t i -> Interval t
pInterval) [Step t (StepInfo v x t)]
steps
        where
            get :: Step t (StepInfo v x t) -> Maybe (F v x)
get Step{StepInfo v x t
pDesc :: StepInfo v x t
pDesc :: forall t i. Step t i -> i
pDesc} | IntermediateStep F v x
f <- StepInfo v x t -> StepInfo v x t
forall {v} {x} {t}. StepInfo v x t -> StepInfo v x t
descent StepInfo v x t
pDesc = F v x -> Maybe (F v x)
forall a. a -> Maybe a
Just F v x
f
            get Step t (StepInfo v x t)
_ = Maybe (F v x)
forall a. Maybe a
Nothing

-- | Unique ID of a process step. Uniquity presented only inside PU.
type ProcessStepID = Int

-- | Process step representation
data Step t i = Step
    { forall t i. Step t i -> Int
pID :: ProcessStepID
    -- ^ uniq (inside single the process unit) step ID
    , forall t i. Step t i -> Interval t
pInterval :: Interval t
    -- ^ step time
    , forall t i. Step t i -> i
pDesc :: i
    -- ^ step description
    }
    deriving (Int -> Step t i -> String -> String
[Step t i] -> String -> String
Step t i -> String
(Int -> Step t i -> String -> String)
-> (Step t i -> String)
-> ([Step t i] -> String -> String)
-> Show (Step t i)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall t i. (Show t, Show i) => Int -> Step t i -> String -> String
forall t i. (Show t, Show i) => [Step t i] -> String -> String
forall t i. (Show t, Show i) => Step t i -> String
$cshowsPrec :: forall t i. (Show t, Show i) => Int -> Step t i -> String -> String
showsPrec :: Int -> Step t i -> String -> String
$cshow :: forall t i. (Show t, Show i) => Step t i -> String
show :: Step t i -> String
$cshowList :: forall t i. (Show t, Show i) => [Step t i] -> String -> String
showList :: [Step t i] -> String -> String
Show, (forall x. Step t i -> Rep (Step t i) x)
-> (forall x. Rep (Step t i) x -> Step t i) -> Generic (Step t i)
forall x. Rep (Step t i) x -> Step t i
forall x. Step t i -> Rep (Step t i) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall t i x. Rep (Step t i) x -> Step t i
forall t i x. Step t i -> Rep (Step t i) x
$cfrom :: forall t i x. Step t i -> Rep (Step t i) x
from :: forall x. Step t i -> Rep (Step t i) x
$cto :: forall t i x. Rep (Step t i) x -> Step t i
to :: forall x. Rep (Step t i) x -> Step t i
Generic)

instance (ToJSON t, ToJSON i) => ToJSON (Step t i)

instance Ord v => Patch (Step t (StepInfo v x t)) (Changeset v) where
    patch :: Changeset v -> Step t (StepInfo v x t) -> Step t (StepInfo v x t)
patch Changeset v
diff step :: Step t (StepInfo v x t)
step@Step{StepInfo v x t
pDesc :: forall t i. Step t i -> i
pDesc :: StepInfo v x t
pDesc} = Step t (StepInfo v x t)
step{pDesc = patch diff pDesc}

-- | Informative process step description at a specific process level.
data StepInfo v x t where
    -- | CAD level step
    CADStep :: String -> StepInfo v x t
    -- | Apply refactoring
    RefactorStep :: (Typeable ref, Show ref, Eq ref) => ref -> StepInfo v x t
    -- | intermidiate level step (function execution)
    IntermediateStep :: F v x -> StepInfo v x t
    -- | endpoint level step (source or target)
    EndpointRoleStep :: EndpointRole v -> StepInfo v x t
    -- | process unit instruction (depends on process unit type)
    InstructionStep ::
        (Show (Instruction pu), Typeable (Instruction pu)) =>
        Instruction pu ->
        StepInfo v x t
    -- | wrapper for nested process unit step (used for networks)
    NestedStep :: UnitTag tag => {()
nTitle :: tag, forall t v x. StepInfo v x t -> Step t (StepInfo v x t)
nStep :: Step t (StepInfo v x t)} -> StepInfo v x t
    -- | Process unit allocation step
    AllocationStep :: (Typeable a, Show a, Eq a) => a -> StepInfo v x t

descent :: StepInfo v x t -> StepInfo v x t
descent (NestedStep tag
_ Step t (StepInfo v x t)
step) = StepInfo v x t -> StepInfo v x t
descent (StepInfo v x t -> StepInfo v x t)
-> StepInfo v x t -> StepInfo v x t
forall a b. (a -> b) -> a -> b
$ Step t (StepInfo v x t) -> StepInfo v x t
forall t i. Step t i -> i
pDesc Step t (StepInfo v x t)
step
descent StepInfo v x t
desc = StepInfo v x t
desc

isRefactorStep :: StepInfo v x t -> Bool
isRefactorStep RefactorStep{} = Bool
True
isRefactorStep StepInfo v x t
_ = Bool
False

isAllocationStep :: StepInfo v x t -> Bool
isAllocationStep AllocationStep{} = Bool
True
isAllocationStep StepInfo v x t
_ = Bool
False

instance (Var v, Show (Step t (StepInfo v x t))) => Show (StepInfo v x t) where
    show :: StepInfo v x t -> String
show (CADStep String
msg) = String
"CAD: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg
    show (AllocationStep a
alloc) = String
"Allocation: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
alloc
    show (RefactorStep ref
ref) = String
"Refactor: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ref -> String
forall a. Show a => a -> String
show ref
ref
    show (IntermediateStep F{f
fun :: f
fun :: ()
fun}) = String
"Intermediate: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> f -> String
forall a. Show a => a -> String
show f
fun
    show (EndpointRoleStep EndpointRole v
eff) = String
"Endpoint: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EndpointRole v -> String
forall a. Show a => a -> String
show EndpointRole v
eff
    show (InstructionStep Instruction pu
instr) = String
"Instruction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Instruction pu -> String
forall a. Show a => a -> String
show Instruction pu
instr
    show NestedStep{tag
nTitle :: ()
nTitle :: tag
nTitle, nStep :: forall t v x. StepInfo v x t -> Step t (StepInfo v x t)
nStep = Step{StepInfo v x t
pDesc :: forall t i. Step t i -> i
pDesc :: StepInfo v x t
pDesc}} = String
"@" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> tag -> String
forall a. ToString a => a -> String
toString tag
nTitle String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> StepInfo v x t -> String
forall a. Show a => a -> String
show StepInfo v x t
pDesc

instance Ord v => Patch (StepInfo v x t) (Changeset v) where
    patch :: Changeset v -> StepInfo v x t -> StepInfo v x t
patch Changeset v
diff (IntermediateStep F v x
f) = F v x -> StepInfo v x t
forall v x t. F v x -> StepInfo v x t
IntermediateStep (F v x -> StepInfo v x t) -> F v x -> StepInfo v x t
forall a b. (a -> b) -> a -> b
$ Changeset v -> F v x -> F v x
forall f diff. Patch f diff => diff -> f -> f
patch Changeset v
diff F v x
f
    patch Changeset v
diff (EndpointRoleStep EndpointRole v
ep) = EndpointRole v -> StepInfo v x t
forall v x t. EndpointRole v -> StepInfo v x t
EndpointRoleStep (EndpointRole v -> StepInfo v x t)
-> EndpointRole v -> StepInfo v x t
forall a b. (a -> b) -> a -> b
$ Changeset v -> EndpointRole v -> EndpointRole v
forall f diff. Patch f diff => diff -> f -> f
patch Changeset v
diff EndpointRole v
ep
    patch Changeset v
diff (NestedStep tag
tag Step t (StepInfo v x t)
nStep) = tag -> Step t (StepInfo v x t) -> StepInfo v x t
forall tag t v x.
UnitTag tag =>
tag -> Step t (StepInfo v x t) -> StepInfo v x t
NestedStep tag
tag (Step t (StepInfo v x t) -> StepInfo v x t)
-> Step t (StepInfo v x t) -> StepInfo v x t
forall a b. (a -> b) -> a -> b
$ Changeset v -> Step t (StepInfo v x t) -> Step t (StepInfo v x t)
forall f diff. Patch f diff => diff -> f -> f
patch Changeset v
diff Step t (StepInfo v x t)
nStep
    patch Changeset v
_ StepInfo v x t
instr = StepInfo v x t
instr

-- | Relations between process steps.
data Relation
    = {- | Vertical relationships (up and down). For example, the intermediate
      step (function execution) can be translated to a sequence of endpoint
      steps (receiving and sending variable), and process unit instructions.
      -}
      Vertical {Relation -> Int
vUp, Relation -> Int
vDown :: ProcessStepID}
    | {- | Horizontal relationships (on one level). For example, we bind the
      function and apply the refactoring. The binding step should be
      connected to refactoring steps, including new binding steps.
      -}
      Horizontal {Relation -> Int
hPrev, Relation -> Int
hNext :: ProcessStepID}
    deriving (Int -> Relation -> String -> String
[Relation] -> String -> String
Relation -> String
(Int -> Relation -> String -> String)
-> (Relation -> String)
-> ([Relation] -> String -> String)
-> Show Relation
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Relation -> String -> String
showsPrec :: Int -> Relation -> String -> String
$cshow :: Relation -> String
show :: Relation -> String
$cshowList :: [Relation] -> String -> String
showList :: [Relation] -> String -> String
Show, (forall x. Relation -> Rep Relation x)
-> (forall x. Rep Relation x -> Relation) -> Generic Relation
forall x. Rep Relation x -> Relation
forall x. Relation -> Rep Relation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Relation -> Rep Relation x
from :: forall x. Relation -> Rep Relation x
$cto :: forall x. Rep Relation x -> Relation
to :: forall x. Rep Relation x -> Relation
Generic, Eq Relation
Eq Relation =>
(Relation -> Relation -> Ordering)
-> (Relation -> Relation -> Bool)
-> (Relation -> Relation -> Bool)
-> (Relation -> Relation -> Bool)
-> (Relation -> Relation -> Bool)
-> (Relation -> Relation -> Relation)
-> (Relation -> Relation -> Relation)
-> Ord Relation
Relation -> Relation -> Bool
Relation -> Relation -> Ordering
Relation -> Relation -> Relation
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Relation -> Relation -> Ordering
compare :: Relation -> Relation -> Ordering
$c< :: Relation -> Relation -> Bool
< :: Relation -> Relation -> Bool
$c<= :: Relation -> Relation -> Bool
<= :: Relation -> Relation -> Bool
$c> :: Relation -> Relation -> Bool
> :: Relation -> Relation -> Bool
$c>= :: Relation -> Relation -> Bool
>= :: Relation -> Relation -> Bool
$cmax :: Relation -> Relation -> Relation
max :: Relation -> Relation -> Relation
$cmin :: Relation -> Relation -> Relation
min :: Relation -> Relation -> Relation
Ord, Relation -> Relation -> Bool
(Relation -> Relation -> Bool)
-> (Relation -> Relation -> Bool) -> Eq Relation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Relation -> Relation -> Bool
== :: Relation -> Relation -> Bool
$c/= :: Relation -> Relation -> Bool
/= :: Relation -> Relation -> Bool
Eq)

instance ToJSON Relation

whatsHappen :: a -> Process a i -> [Step a i]
whatsHappen a
t Process{[Step a i]
steps :: forall t i. Process t i -> [Step t i]
steps :: [Step a i]
steps} = (Step a i -> Bool) -> [Step a i] -> [Step a i]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> Interval a -> Bool
forall {a}. Ord a => a -> Interval a -> Bool
atSameTime a
t (Interval a -> Bool)
-> (Step a i -> Interval a) -> Step a i -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Step a i -> Interval a
forall t i. Step t i -> Interval t
pInterval) [Step a i]
steps
    where
        atSameTime :: a -> Interval a -> Bool
atSameTime a
a Interval a
ti = a
a a -> Interval a -> Bool
forall {a}. Ord a => a -> Interval a -> Bool
`member` Interval a
ti

extractInstructionAt :: u -> t -> [Instruction u]
extractInstructionAt u
pu t
t = (Step t (StepInfo v x t) -> Maybe (Instruction u))
-> [Step t (StepInfo v x t)] -> [Instruction u]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (u -> Step t (StepInfo v x t) -> Maybe (Instruction u)
forall pu t v x.
Typeable (Instruction pu) =>
pu -> Step t (StepInfo v x t) -> Maybe (Instruction pu)
inst u
pu) ([Step t (StepInfo v x t)] -> [Instruction u])
-> [Step t (StepInfo v x t)] -> [Instruction u]
forall a b. (a -> b) -> a -> b
$ t -> Process t (StepInfo v x t) -> [Step t (StepInfo v x t)]
forall {a} {i}. Ord a => a -> Process a i -> [Step a i]
whatsHappen t
t (Process t (StepInfo v x t) -> [Step t (StepInfo v x t)])
-> Process t (StepInfo v x t) -> [Step t (StepInfo v x t)]
forall a b. (a -> b) -> a -> b
$ u -> Process t (StepInfo v x t)
forall u v x t.
ProcessorUnit u v x t =>
u -> Process t (StepInfo v x t)
process u
pu
    where
        inst :: Typeable (Instruction pu) => pu -> Step t (StepInfo v x t) -> Maybe (Instruction pu)
        inst :: forall pu t v x.
Typeable (Instruction pu) =>
pu -> Step t (StepInfo v x t) -> Maybe (Instruction pu)
inst pu
_ Step{pDesc :: forall t i. Step t i -> i
pDesc = InstructionStep Instruction pu
instr} = Instruction pu -> Maybe (Instruction pu)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Instruction pu
instr
        inst pu
_ Step t (StepInfo v x t)
_ = Maybe (Instruction pu)
forall a. Maybe a
Nothing

{- | Shift @nextTick@ value if it is not zero on a specific offset. Use case: The
processor unit has buffered output, so we should provide @oe@ signal for one
tick before data actually send to the bus. That raises the following cases:

1. First usage. We can receive value immediately on nextTick

    @
    tick | Endpoint     | Instruction |
     0   | Target "c"   | WR          | <- nextTick
    @

2. Not first usage. We need to wait for one tick from the last instruction due to the offset between instruction and data transfers.

    @
    tick | Endpoint     | Instruction |
      8  |              | OE          |
      9  | Source ["b"] |             | <- nextTick
     10  | Target "c"   | WR          |
    @
-}
a
0 withShift :: a -> a -> a
`withShift` a
_offset = a
0
a
tick `withShift` a
offset = a
tick a -> a -> a
forall a. Num a => a -> a -> a
+ a
offset

---------------------------------------------------------------------

{- | Type class for controllable units. Defines two level of a unit behaviour
representation (see ahead).
-}
class Controllable pu where
    -- Instruction describe unit behaviour on each mUnit cycle. If instruction
    -- not defined for some cycles - it should be interpreted as NOP.
    data Instruction pu :: Type

    -- | Microcode desctibe controll signals on each mUnit cycle (without exclusion).
    data Microcode pu :: Type

    -- | Zip port signal tags and value.
    zipSignalTagsAndValues :: Ports pu -> Microcode pu -> [(SignalTag, SignalValue)]

    -- | Get list of used control signal tags.
    usedPortTags :: Ports pu -> [SignalTag]

    -- | Take signal tags from inifinite list of tags.
    takePortTags :: [SignalTag] -> pu -> Ports pu

-- | Getting microcode value at a specific time.
class ByTime pu t | pu -> t where
    microcodeAt :: pu -> t -> Microcode pu

instance
    ( Show (Instruction pu)
    , Default (Microcode pu)
    , ProcessorUnit pu v x t
    , UnambiguouslyDecode pu
    , Typeable pu
    ) =>
    ByTime pu t
    where
    microcodeAt :: pu -> t -> Microcode pu
microcodeAt pu
pu t
t = case pu -> t -> [Instruction pu]
forall {u} {v} {x} {t}.
(ProcessorUnit u v x t, Typeable u) =>
u -> t -> [Instruction u]
extractInstructionAt pu
pu t
t of
        [] -> Microcode pu
forall a. Default a => a
def
        [Instruction pu
instr] -> Instruction pu -> Microcode pu
forall pu. UnambiguouslyDecode pu => Instruction pu -> Microcode pu
decodeInstruction Instruction pu
instr
        [Instruction pu]
is -> String -> Microcode pu
forall a. HasCallStack => String -> a
error [i|instruction collision at #{ t } tick: #{ is } #{ pretty $ process pu }|]

newtype SignalTag = SignalTag {SignalTag -> Text
signalTag :: T.Text} deriving (SignalTag -> SignalTag -> Bool
(SignalTag -> SignalTag -> Bool)
-> (SignalTag -> SignalTag -> Bool) -> Eq SignalTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SignalTag -> SignalTag -> Bool
== :: SignalTag -> SignalTag -> Bool
$c/= :: SignalTag -> SignalTag -> Bool
/= :: SignalTag -> SignalTag -> Bool
Eq, Eq SignalTag
Eq SignalTag =>
(SignalTag -> SignalTag -> Ordering)
-> (SignalTag -> SignalTag -> Bool)
-> (SignalTag -> SignalTag -> Bool)
-> (SignalTag -> SignalTag -> Bool)
-> (SignalTag -> SignalTag -> Bool)
-> (SignalTag -> SignalTag -> SignalTag)
-> (SignalTag -> SignalTag -> SignalTag)
-> Ord SignalTag
SignalTag -> SignalTag -> Bool
SignalTag -> SignalTag -> Ordering
SignalTag -> SignalTag -> SignalTag
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SignalTag -> SignalTag -> Ordering
compare :: SignalTag -> SignalTag -> Ordering
$c< :: SignalTag -> SignalTag -> Bool
< :: SignalTag -> SignalTag -> Bool
$c<= :: SignalTag -> SignalTag -> Bool
<= :: SignalTag -> SignalTag -> Bool
$c> :: SignalTag -> SignalTag -> Bool
> :: SignalTag -> SignalTag -> Bool
$c>= :: SignalTag -> SignalTag -> Bool
>= :: SignalTag -> SignalTag -> Bool
$cmax :: SignalTag -> SignalTag -> SignalTag
max :: SignalTag -> SignalTag -> SignalTag
$cmin :: SignalTag -> SignalTag -> SignalTag
min :: SignalTag -> SignalTag -> SignalTag
Ord)

instance Show SignalTag where
    show :: SignalTag -> String
show = Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> (SignalTag -> Text) -> SignalTag -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignalTag -> Text
signalTag

-- | Type class of processor units with control ports.
class Connected pu where
    -- | A processor unit control ports (signals, flags).
    data Ports pu :: Type

{- | Decoding microcode from a simple instruction (microcode don't change over
time).

TODO: Generalize that class for all process units, including networks.
-}
class UnambiguouslyDecode pu where
    decodeInstruction :: Instruction pu -> Microcode pu

-- | Control line value.
data SignalValue
    = -- | undefined by design (`x`)
      Undef
    | -- | boolean (`0` or `1`)
      Bool Bool
    | -- | broken value (`x`) by data colision
      BrokenSignal
    deriving (SignalValue -> SignalValue -> Bool
(SignalValue -> SignalValue -> Bool)
-> (SignalValue -> SignalValue -> Bool) -> Eq SignalValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SignalValue -> SignalValue -> Bool
== :: SignalValue -> SignalValue -> Bool
$c/= :: SignalValue -> SignalValue -> Bool
/= :: SignalValue -> SignalValue -> Bool
Eq)

instance Default SignalValue where
    def :: SignalValue
def = SignalValue
Undef

instance Show SignalValue where
    show :: SignalValue -> String
show SignalValue
Undef = String
"x"
    show (Bool Bool
True) = String
"1"
    show (Bool Bool
False) = String
"0"
    show SignalValue
BrokenSignal = String
"B"

SignalValue
Undef +++ :: SignalValue -> SignalValue -> SignalValue
+++ SignalValue
v = SignalValue
v
SignalValue
v +++ SignalValue
Undef = SignalValue
v
SignalValue
_ +++ SignalValue
_ = SignalValue
BrokenSignal

------------------------------------------------------------

-- | Type class of processor units with IO ports.
class IOConnected pu where
    data IOPorts pu :: Type

    -- | External input ports, which go outside of NITTA mUnit.
    inputPorts :: IOPorts pu -> S.Set InputPortTag
    inputPorts IOPorts pu
_ = Set InputPortTag
forall a. Set a
S.empty

    -- | External output ports, which go outside of NITTA mUnit.
    outputPorts :: IOPorts pu -> S.Set OutputPortTag
    outputPorts IOPorts pu
_ = Set OutputPortTag
forall a. Set a
S.empty

    -- | External output ports, which go outside of NITTA mUnit.
    inoutPorts :: IOPorts pu -> S.Set InoutPortTag
    inoutPorts IOPorts pu
_ = Set InoutPortTag
forall a. Set a
S.empty

newtype InputPortTag = InputPortTag {InputPortTag -> Text
inputPortTag :: T.Text} deriving (InputPortTag -> InputPortTag -> Bool
(InputPortTag -> InputPortTag -> Bool)
-> (InputPortTag -> InputPortTag -> Bool) -> Eq InputPortTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InputPortTag -> InputPortTag -> Bool
== :: InputPortTag -> InputPortTag -> Bool
$c/= :: InputPortTag -> InputPortTag -> Bool
/= :: InputPortTag -> InputPortTag -> Bool
Eq, Eq InputPortTag
Eq InputPortTag =>
(InputPortTag -> InputPortTag -> Ordering)
-> (InputPortTag -> InputPortTag -> Bool)
-> (InputPortTag -> InputPortTag -> Bool)
-> (InputPortTag -> InputPortTag -> Bool)
-> (InputPortTag -> InputPortTag -> Bool)
-> (InputPortTag -> InputPortTag -> InputPortTag)
-> (InputPortTag -> InputPortTag -> InputPortTag)
-> Ord InputPortTag
InputPortTag -> InputPortTag -> Bool
InputPortTag -> InputPortTag -> Ordering
InputPortTag -> InputPortTag -> InputPortTag
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: InputPortTag -> InputPortTag -> Ordering
compare :: InputPortTag -> InputPortTag -> Ordering
$c< :: InputPortTag -> InputPortTag -> Bool
< :: InputPortTag -> InputPortTag -> Bool
$c<= :: InputPortTag -> InputPortTag -> Bool
<= :: InputPortTag -> InputPortTag -> Bool
$c> :: InputPortTag -> InputPortTag -> Bool
> :: InputPortTag -> InputPortTag -> Bool
$c>= :: InputPortTag -> InputPortTag -> Bool
>= :: InputPortTag -> InputPortTag -> Bool
$cmax :: InputPortTag -> InputPortTag -> InputPortTag
max :: InputPortTag -> InputPortTag -> InputPortTag
$cmin :: InputPortTag -> InputPortTag -> InputPortTag
min :: InputPortTag -> InputPortTag -> InputPortTag
Ord)
instance Show InputPortTag where show :: InputPortTag -> String
show = Text -> String
forall a. ToString a => a -> String
toString (Text -> String)
-> (InputPortTag -> Text) -> InputPortTag -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputPortTag -> Text
inputPortTag

newtype OutputPortTag = OutputPortTag {OutputPortTag -> Text
outputPortTag :: T.Text} deriving (OutputPortTag -> OutputPortTag -> Bool
(OutputPortTag -> OutputPortTag -> Bool)
-> (OutputPortTag -> OutputPortTag -> Bool) -> Eq OutputPortTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OutputPortTag -> OutputPortTag -> Bool
== :: OutputPortTag -> OutputPortTag -> Bool
$c/= :: OutputPortTag -> OutputPortTag -> Bool
/= :: OutputPortTag -> OutputPortTag -> Bool
Eq, Eq OutputPortTag
Eq OutputPortTag =>
(OutputPortTag -> OutputPortTag -> Ordering)
-> (OutputPortTag -> OutputPortTag -> Bool)
-> (OutputPortTag -> OutputPortTag -> Bool)
-> (OutputPortTag -> OutputPortTag -> Bool)
-> (OutputPortTag -> OutputPortTag -> Bool)
-> (OutputPortTag -> OutputPortTag -> OutputPortTag)
-> (OutputPortTag -> OutputPortTag -> OutputPortTag)
-> Ord OutputPortTag
OutputPortTag -> OutputPortTag -> Bool
OutputPortTag -> OutputPortTag -> Ordering
OutputPortTag -> OutputPortTag -> OutputPortTag
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: OutputPortTag -> OutputPortTag -> Ordering
compare :: OutputPortTag -> OutputPortTag -> Ordering
$c< :: OutputPortTag -> OutputPortTag -> Bool
< :: OutputPortTag -> OutputPortTag -> Bool
$c<= :: OutputPortTag -> OutputPortTag -> Bool
<= :: OutputPortTag -> OutputPortTag -> Bool
$c> :: OutputPortTag -> OutputPortTag -> Bool
> :: OutputPortTag -> OutputPortTag -> Bool
$c>= :: OutputPortTag -> OutputPortTag -> Bool
>= :: OutputPortTag -> OutputPortTag -> Bool
$cmax :: OutputPortTag -> OutputPortTag -> OutputPortTag
max :: OutputPortTag -> OutputPortTag -> OutputPortTag
$cmin :: OutputPortTag -> OutputPortTag -> OutputPortTag
min :: OutputPortTag -> OutputPortTag -> OutputPortTag
Ord)
instance Show OutputPortTag where show :: OutputPortTag -> String
show = Text -> String
forall a. ToString a => a -> String
toString (Text -> String)
-> (OutputPortTag -> Text) -> OutputPortTag -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputPortTag -> Text
outputPortTag

newtype InoutPortTag = InoutPortTag {InoutPortTag -> Text
inoutPortTag :: T.Text} deriving (InoutPortTag -> InoutPortTag -> Bool
(InoutPortTag -> InoutPortTag -> Bool)
-> (InoutPortTag -> InoutPortTag -> Bool) -> Eq InoutPortTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InoutPortTag -> InoutPortTag -> Bool
== :: InoutPortTag -> InoutPortTag -> Bool
$c/= :: InoutPortTag -> InoutPortTag -> Bool
/= :: InoutPortTag -> InoutPortTag -> Bool
Eq, Eq InoutPortTag
Eq InoutPortTag =>
(InoutPortTag -> InoutPortTag -> Ordering)
-> (InoutPortTag -> InoutPortTag -> Bool)
-> (InoutPortTag -> InoutPortTag -> Bool)
-> (InoutPortTag -> InoutPortTag -> Bool)
-> (InoutPortTag -> InoutPortTag -> Bool)
-> (InoutPortTag -> InoutPortTag -> InoutPortTag)
-> (InoutPortTag -> InoutPortTag -> InoutPortTag)
-> Ord InoutPortTag
InoutPortTag -> InoutPortTag -> Bool
InoutPortTag -> InoutPortTag -> Ordering
InoutPortTag -> InoutPortTag -> InoutPortTag
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: InoutPortTag -> InoutPortTag -> Ordering
compare :: InoutPortTag -> InoutPortTag -> Ordering
$c< :: InoutPortTag -> InoutPortTag -> Bool
< :: InoutPortTag -> InoutPortTag -> Bool
$c<= :: InoutPortTag -> InoutPortTag -> Bool
<= :: InoutPortTag -> InoutPortTag -> Bool
$c> :: InoutPortTag -> InoutPortTag -> Bool
> :: InoutPortTag -> InoutPortTag -> Bool
$c>= :: InoutPortTag -> InoutPortTag -> Bool
>= :: InoutPortTag -> InoutPortTag -> Bool
$cmax :: InoutPortTag -> InoutPortTag -> InoutPortTag
max :: InoutPortTag -> InoutPortTag -> InoutPortTag
$cmin :: InoutPortTag -> InoutPortTag -> InoutPortTag
min :: InoutPortTag -> InoutPortTag -> InoutPortTag
Ord)
instance Show InoutPortTag where show :: InoutPortTag -> String
show = Text -> String
forall a. ToString a => a -> String
toString (Text -> String)
-> (InoutPortTag -> Text) -> InoutPortTag -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InoutPortTag -> Text
inoutPortTag