-
Notifications
You must be signed in to change notification settings - Fork 3
/
Copy pathAmble.hs
105 lines (86 loc) · 3.78 KB
/
Amble.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
{-# LANGUAGE GADTs, ConstraintKinds #-}
{-# LANGUAGE StandaloneDeriving, DeriveFunctor #-}
{-# LANGUAGE RankNTypes #-} -- Needed for `step` only
{-# LANGUAGE UndecidableInstances #-} -- Needed for the `TypeError` instance of `Combine` only
-- | A container for sequences where each step can have a pre- and a
-- postamble. The postamble and the preamble of two neighbouring steps
-- are collapsed.
module Hardware.Intel8080.Amble
( Step(..)
, step
, Ends(..), Amble(End), (>:>), (>++>)
, stepsOf
) where
import Prelude ()
import Clash.Prelude
import Data.Singletons
import Data.Kind (Constraint)
type ConflictErr post pre =
Text "Conflict between postamble" :$$: Text " " :<>: ShowType post :$$:
Text "and next preamble" :$$: Text " " :<>: ShowType pre
type family Combine (post :: Maybe b) (pre :: Maybe a) :: Maybe (Either a b) where
Combine Nothing Nothing = Nothing
Combine (Just post) Nothing = Just (Right post)
Combine Nothing (Just pre) = Just (Left pre)
Combine (Just post) (Just pre) = TypeError (ConflictErr post pre)
combine
:: forall a b (post :: Maybe b) (pre :: Maybe a).
(SingKind a, SingKind b, SingI (Combine post pre))
=> Sing post -> Sing pre -> Demote (KindOf (Combine post pre))
combine _ _ = demote @(Combine post pre)
data Step (pre :: Maybe a) (post :: Maybe b) t where
Step :: Sing pre -> t -> Sing post -> Step pre post t
deriving instance Functor (Step pre post)
step :: forall pre. (SingI pre) => forall t. t -> forall post. (SingI post) => Step pre post t
step x = Step sing x sing
data Ends a b
= Empty
| NonEmpty (Maybe a) (Maybe b)
data Amble (n :: Nat) (ends :: Ends a b) t where
End :: Amble 0 Empty t
More
:: forall (a0 :: Maybe a) (bn :: Maybe b) n t. ()
=> Sing a0
-> Vec n (t, Demote (Maybe (Either a b)))
-> t
-> Sing bn
-> Amble (1 + n) (NonEmpty a0 bn) t
deriving instance Functor (Amble n ends)
type family CanCons (b1 :: Maybe b) (ends :: Ends a b) :: Constraint where
CanCons b1 Empty = ()
CanCons (b1 :: Maybe b) (NonEmpty a1 bn :: Ends a b) = (SingKind a, SingKind b, SingI (Combine b1 a1))
type family Cons (b1 :: Maybe b) (ends :: Ends a b) where
Cons b1 Empty = b1
Cons b1 (NonEmpty a1 bn) = bn
cons
:: forall (a0 :: Maybe a) b1 n (ends :: Ends a b) t. (CanCons b1 ends)
=> Step a0 b1 t
-> Amble n ends t
-> Amble (1 + n) (NonEmpty a0 (Cons b1 ends)) t
cons (Step a0 x b1) End = More a0 Nil x b1
cons (Step a0 x b1) (More a1 xs xn bn) = More a0 ((x, combine b1 a1) :> xs) xn bn
infixr 5 >:>
(>:>)
:: forall (a0 :: Maybe a) b1 n (ends :: Ends a b) t. (CanCons b1 ends)
=> Step a0 b1 t -> Amble n ends t -> Amble (1 + n) (NonEmpty a0 (Cons b1 ends)) t
(>:>) = cons
type family CanAppend (ends1 :: Ends a b) (ends2 :: Ends a b) :: Constraint where
CanAppend (NonEmpty a1 bn) ends2 = CanCons bn ends2
CanAppend ends1 ends2 = ()
type family Append (ends1 :: Ends a b) (ends2 :: Ends a b) where
Append Empty ends2 = ends2
Append ends1 Empty = ends1
Append (NonEmpty a0 bn) (NonEmpty an bm) = NonEmpty a0 bm
append :: (CanAppend ends1 ends2) => Amble n ends1 t -> Amble m ends2 t -> Amble (n + m) (Append ends1 ends2) t
append End ys = ys
append (More a0 xs xn bn) End = More a0 xs xn bn
append (More a0 xs xn bn) (More an ys ym bm) = More a0 (xs ++ singleton (xn, combine bn an) ++ ys) ym bm
infixr 5 >++>
(>++>) :: (CanAppend ends1 ends2) => Amble n ends1 t -> Amble m ends2 t -> Amble (n + m) (Append ends1 ends2) t
(>++>) = append
stepsOf
:: forall a b (ends :: Ends a b) n t. (SingKind a, SingKind b)
=> Amble n ends t
-> (Maybe (Demote a), Vec n (t, Maybe (Demote (Either a b))))
stepsOf End = (Nothing, Nil)
stepsOf (More a0 xs xn bn) = (fromSing a0, xs :< (xn, Right <$> fromSing bn))