{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
module Sketch.FRP.Copilot.Types where
import Language.Copilot
import Control.Monad.Writer
import Control.Monad.State.Strict
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Type.Bool
import GHC.TypeLits
type Behavior t = Stream t
data TypedBehavior p t = TypedBehavior (Behavior t)
data Event p v = Event v (Stream Bool)
newtype GenSketch ctx t = GenSketch (WriterT [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)] (State UniqueIds) t)
deriving
( forall {ctx}. Applicative (GenSketch ctx)
forall a. a -> GenSketch ctx a
forall ctx a. a -> GenSketch ctx a
forall a b. GenSketch ctx a -> GenSketch ctx b -> GenSketch ctx b
forall a b.
GenSketch ctx a -> (a -> GenSketch ctx b) -> GenSketch ctx b
forall ctx a b.
GenSketch ctx a -> GenSketch ctx b -> GenSketch ctx b
forall ctx a b.
GenSketch ctx a -> (a -> GenSketch ctx b) -> GenSketch ctx b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> GenSketch ctx a
$creturn :: forall ctx a. a -> GenSketch ctx a
>> :: forall a b. GenSketch ctx a -> GenSketch ctx b -> GenSketch ctx b
$c>> :: forall ctx a b.
GenSketch ctx a -> GenSketch ctx b -> GenSketch ctx b
>>= :: forall a b.
GenSketch ctx a -> (a -> GenSketch ctx b) -> GenSketch ctx b
$c>>= :: forall ctx a b.
GenSketch ctx a -> (a -> GenSketch ctx b) -> GenSketch ctx b
Monad
, forall {ctx}. Functor (GenSketch ctx)
forall a. a -> GenSketch ctx a
forall ctx a. a -> GenSketch ctx a
forall a b. GenSketch ctx a -> GenSketch ctx b -> GenSketch ctx a
forall a b. GenSketch ctx a -> GenSketch ctx b -> GenSketch ctx b
forall a b.
GenSketch ctx (a -> b) -> GenSketch ctx a -> GenSketch ctx b
forall ctx a b.
GenSketch ctx a -> GenSketch ctx b -> GenSketch ctx a
forall ctx a b.
GenSketch ctx a -> GenSketch ctx b -> GenSketch ctx b
forall ctx a b.
GenSketch ctx (a -> b) -> GenSketch ctx a -> GenSketch ctx b
forall a b c.
(a -> b -> c)
-> GenSketch ctx a -> GenSketch ctx b -> GenSketch ctx c
forall ctx a b c.
(a -> b -> c)
-> GenSketch ctx a -> GenSketch ctx b -> GenSketch ctx c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. GenSketch ctx a -> GenSketch ctx b -> GenSketch ctx a
$c<* :: forall ctx a b.
GenSketch ctx a -> GenSketch ctx b -> GenSketch ctx a
*> :: forall a b. GenSketch ctx a -> GenSketch ctx b -> GenSketch ctx b
$c*> :: forall ctx a b.
GenSketch ctx a -> GenSketch ctx b -> GenSketch ctx b
liftA2 :: forall a b c.
(a -> b -> c)
-> GenSketch ctx a -> GenSketch ctx b -> GenSketch ctx c
$cliftA2 :: forall ctx a b c.
(a -> b -> c)
-> GenSketch ctx a -> GenSketch ctx b -> GenSketch ctx c
<*> :: forall a b.
GenSketch ctx (a -> b) -> GenSketch ctx a -> GenSketch ctx b
$c<*> :: forall ctx a b.
GenSketch ctx (a -> b) -> GenSketch ctx a -> GenSketch ctx b
pure :: forall a. a -> GenSketch ctx a
$cpure :: forall ctx a. a -> GenSketch ctx a
Applicative
, forall a b. a -> GenSketch ctx b -> GenSketch ctx a
forall a b. (a -> b) -> GenSketch ctx a -> GenSketch ctx b
forall ctx a b. a -> GenSketch ctx b -> GenSketch ctx a
forall ctx a b. (a -> b) -> GenSketch ctx a -> GenSketch ctx b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> GenSketch ctx b -> GenSketch ctx a
$c<$ :: forall ctx a b. a -> GenSketch ctx b -> GenSketch ctx a
fmap :: forall a b. (a -> b) -> GenSketch ctx a -> GenSketch ctx b
$cfmap :: forall ctx a b. (a -> b) -> GenSketch ctx a -> GenSketch ctx b
Functor
, MonadWriter [(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]
, MonadState UniqueIds
)
instance Monoid (GenSketch ctx ()) where
mempty :: GenSketch ctx ()
mempty = forall ctx t.
WriterT
[(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]
(State UniqueIds)
t
-> GenSketch ctx t
GenSketch (forall (m :: * -> *) a. Monad m => a -> m a
return ())
instance Semigroup (GenSketch ctx t) where
(GenSketch WriterT
[(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]
(State UniqueIds)
t
a) <> :: GenSketch ctx t -> GenSketch ctx t -> GenSketch ctx t
<> (GenSketch WriterT
[(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]
(State UniqueIds)
t
b) = forall ctx t.
WriterT
[(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]
(State UniqueIds)
t
-> GenSketch ctx t
GenSketch (WriterT
[(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]
(State UniqueIds)
t
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WriterT
[(TriggerLimit -> Spec, TriggerLimit -> GenFramework ctx)]
(State UniqueIds)
t
b)
class Ord ctx => Context ctx
class Output ctx o t where
(=:) :: o -> t -> GenSketch ctx ()
infixr 1 =:
instance Output ctx o (Event () (Stream v)) => Output ctx o (Behavior v) where
=: :: o -> Stream v -> GenSketch ctx ()
(=:) o
o Stream v
b = o
o forall ctx o t. Output ctx o t => o -> t -> GenSketch ctx ()
=: Event () (Stream v)
te
where
te :: Event () (Stream v)
te :: Event () (Stream v)
te = forall {k} (p :: k) v. v -> Stream Bool -> Event p v
Event Stream v
b Stream Bool
true
instance Output ctx o (Event p (Stream v)) => Output ctx o (TypedBehavior p v) where
=: :: o -> TypedBehavior p v -> GenSketch ctx ()
(=:) o
o (TypedBehavior Stream v
b) = o
o forall ctx o t. Output ctx o t => o -> t -> GenSketch ctx ()
=: Event p (Stream v)
te
where
te :: Event p (Stream v)
te :: Event p (Stream v)
te = forall {k} (p :: k) v. v -> Stream Bool -> Event p v
Event Stream v
b Stream Bool
true
class Input ctx o t where
input' :: o -> [t] -> GenSketch ctx (Behavior t)
data GenFramework ctx = Framework
{ forall ctx. GenFramework ctx -> [CChunk]
defines :: [CChunk]
, forall ctx. GenFramework ctx -> [CChunk]
setups :: [CChunk]
, forall ctx. GenFramework ctx -> [CChunk]
earlySetups :: [CChunk]
, forall ctx. GenFramework ctx -> Map ctx (Set PinMode)
pinmodes :: M.Map ctx (S.Set PinMode)
, forall ctx. GenFramework ctx -> [CChunk]
loops :: [CChunk]
}
instance Context ctx => Semigroup (GenFramework ctx) where
GenFramework ctx
a <> :: GenFramework ctx -> GenFramework ctx -> GenFramework ctx
<> GenFramework ctx
b = Framework
{ defines :: [CChunk]
defines = forall ctx. GenFramework ctx -> [CChunk]
defines GenFramework ctx
a forall a. Semigroup a => a -> a -> a
<> forall ctx. GenFramework ctx -> [CChunk]
defines GenFramework ctx
b
, setups :: [CChunk]
setups = forall ctx. GenFramework ctx -> [CChunk]
setups GenFramework ctx
a forall a. Semigroup a => a -> a -> a
<> forall ctx. GenFramework ctx -> [CChunk]
setups GenFramework ctx
b
, earlySetups :: [CChunk]
earlySetups = forall ctx. GenFramework ctx -> [CChunk]
earlySetups GenFramework ctx
a forall a. Semigroup a => a -> a -> a
<> forall ctx. GenFramework ctx -> [CChunk]
earlySetups GenFramework ctx
b
, pinmodes :: Map ctx (Set PinMode)
pinmodes = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith forall a. Ord a => Set a -> Set a -> Set a
S.union (forall ctx. GenFramework ctx -> Map ctx (Set PinMode)
pinmodes GenFramework ctx
a) (forall ctx. GenFramework ctx -> Map ctx (Set PinMode)
pinmodes GenFramework ctx
b)
, loops :: [CChunk]
loops = forall ctx. GenFramework ctx -> [CChunk]
loops GenFramework ctx
a forall a. Semigroup a => a -> a -> a
<> forall ctx. GenFramework ctx -> [CChunk]
loops GenFramework ctx
b
}
instance Context ctx => Monoid (GenFramework ctx) where
mempty :: GenFramework ctx
mempty = forall ctx.
[CChunk]
-> [CChunk]
-> [CChunk]
-> Map ctx (Set PinMode)
-> [CChunk]
-> GenFramework ctx
Framework forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
newtype UniqueIds = UniqueIds (M.Map String Integer)
newtype UniqueId = UniqueId Integer
data TriggerLimit
= TriggerLimit (Behavior Bool)
| NoTriggerLimit
instance Monoid TriggerLimit where
mempty :: TriggerLimit
mempty = TriggerLimit
NoTriggerLimit
instance Semigroup TriggerLimit where
TriggerLimit Stream Bool
a <> :: TriggerLimit -> TriggerLimit -> TriggerLimit
<> TriggerLimit Stream Bool
b =
Stream Bool -> TriggerLimit
TriggerLimit (Stream Bool
a Stream Bool -> Stream Bool -> Stream Bool
Language.Copilot.&& Stream Bool
b)
TriggerLimit
a <> TriggerLimit
NoTriggerLimit = TriggerLimit
a
TriggerLimit
NoTriggerLimit <> TriggerLimit
b = TriggerLimit
b
data PinMode = InputMode | InputPullupMode | OutputMode
deriving (Int -> PinMode -> ShowS
[PinMode] -> ShowS
PinMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PinMode] -> ShowS
$cshowList :: [PinMode] -> ShowS
show :: PinMode -> String
$cshow :: PinMode -> String
showsPrec :: Int -> PinMode -> ShowS
$cshowsPrec :: Int -> PinMode -> ShowS
Show, PinMode -> PinMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PinMode -> PinMode -> Bool
$c/= :: PinMode -> PinMode -> Bool
== :: PinMode -> PinMode -> Bool
$c== :: PinMode -> PinMode -> Bool
Eq, Eq PinMode
PinMode -> PinMode -> Bool
PinMode -> PinMode -> Ordering
PinMode -> PinMode -> PinMode
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
min :: PinMode -> PinMode -> PinMode
$cmin :: PinMode -> PinMode -> PinMode
max :: PinMode -> PinMode -> PinMode
$cmax :: PinMode -> PinMode -> PinMode
>= :: PinMode -> PinMode -> Bool
$c>= :: PinMode -> PinMode -> Bool
> :: PinMode -> PinMode -> Bool
$c> :: PinMode -> PinMode -> Bool
<= :: PinMode -> PinMode -> Bool
$c<= :: PinMode -> PinMode -> Bool
< :: PinMode -> PinMode -> Bool
$c< :: PinMode -> PinMode -> Bool
compare :: PinMode -> PinMode -> Ordering
$ccompare :: PinMode -> PinMode -> Ordering
Ord)
newtype CLine = CLine { CLine -> String
fromCLine :: String }
deriving (CLine -> CLine -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CLine -> CLine -> Bool
$c/= :: CLine -> CLine -> Bool
== :: CLine -> CLine -> Bool
$c== :: CLine -> CLine -> Bool
Eq, Int -> CLine -> ShowS
[CLine] -> ShowS
CLine -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CLine] -> ShowS
$cshowList :: [CLine] -> ShowS
show :: CLine -> String
$cshow :: CLine -> String
showsPrec :: Int -> CLine -> ShowS
$cshowsPrec :: Int -> CLine -> ShowS
Show, Eq CLine
CLine -> CLine -> Bool
CLine -> CLine -> Ordering
CLine -> CLine -> CLine
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
min :: CLine -> CLine -> CLine
$cmin :: CLine -> CLine -> CLine
max :: CLine -> CLine -> CLine
$cmax :: CLine -> CLine -> CLine
>= :: CLine -> CLine -> Bool
$c>= :: CLine -> CLine -> Bool
> :: CLine -> CLine -> Bool
$c> :: CLine -> CLine -> Bool
<= :: CLine -> CLine -> Bool
$c<= :: CLine -> CLine -> Bool
< :: CLine -> CLine -> Bool
$c< :: CLine -> CLine -> Bool
compare :: CLine -> CLine -> Ordering
$ccompare :: CLine -> CLine -> Ordering
Ord)
newtype CChunk = CChunk [CLine]
deriving (CChunk -> CChunk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CChunk -> CChunk -> Bool
$c/= :: CChunk -> CChunk -> Bool
== :: CChunk -> CChunk -> Bool
$c== :: CChunk -> CChunk -> Bool
Eq, Int -> CChunk -> ShowS
[CChunk] -> ShowS
CChunk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CChunk] -> ShowS
$cshowList :: [CChunk] -> ShowS
show :: CChunk -> String
$cshow :: CChunk -> String
showsPrec :: Int -> CChunk -> ShowS
$cshowsPrec :: Int -> CChunk -> ShowS
Show, Eq CChunk
CChunk -> CChunk -> Bool
CChunk -> CChunk -> Ordering
CChunk -> CChunk -> CChunk
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
min :: CChunk -> CChunk -> CChunk
$cmin :: CChunk -> CChunk -> CChunk
max :: CChunk -> CChunk -> CChunk
$cmax :: CChunk -> CChunk -> CChunk
>= :: CChunk -> CChunk -> Bool
$c>= :: CChunk -> CChunk -> Bool
> :: CChunk -> CChunk -> Bool
$c> :: CChunk -> CChunk -> Bool
<= :: CChunk -> CChunk -> Bool
$c<= :: CChunk -> CChunk -> Bool
< :: CChunk -> CChunk -> Bool
$c< :: CChunk -> CChunk -> Bool
compare :: CChunk -> CChunk -> Ordering
$ccompare :: CChunk -> CChunk -> Ordering
Ord, NonEmpty CChunk -> CChunk
CChunk -> CChunk -> CChunk
forall b. Integral b => b -> CChunk -> CChunk
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> CChunk -> CChunk
$cstimes :: forall b. Integral b => b -> CChunk -> CChunk
sconcat :: NonEmpty CChunk -> CChunk
$csconcat :: NonEmpty CChunk -> CChunk
<> :: CChunk -> CChunk -> CChunk
$c<> :: CChunk -> CChunk -> CChunk
Semigroup, Semigroup CChunk
CChunk
[CChunk] -> CChunk
CChunk -> CChunk -> CChunk
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [CChunk] -> CChunk
$cmconcat :: [CChunk] -> CChunk
mappend :: CChunk -> CChunk -> CChunk
$cmappend :: CChunk -> CChunk -> CChunk
mempty :: CChunk
$cmempty :: CChunk
Monoid)
type family BehaviorToEvent a
type instance BehaviorToEvent (Behavior v) = Event () (Stream v)
type instance BehaviorToEvent (TypedBehavior p v) = Event p (Stream v)
class IsBehavior behavior where
(@:) :: behavior -> Behavior Bool -> BehaviorToEvent behavior
instance IsBehavior (Behavior v) where
Behavior v
b @: :: Behavior v -> Stream Bool -> BehaviorToEvent (Behavior v)
@: Stream Bool
c = forall {k} (p :: k) v. v -> Stream Bool -> Event p v
Event Behavior v
b Stream Bool
c
instance IsBehavior (TypedBehavior p v) where
@: :: TypedBehavior p v
-> Stream Bool -> BehaviorToEvent (TypedBehavior p v)
(@:) (TypedBehavior Behavior v
b) Stream Bool
c = forall {k} (p :: k) v. v -> Stream Bool -> Event p v
Event Behavior v
b Stream Bool
c
data PinCapabilities
= DigitalIO
| AnalogInput
| PWM
deriving (Int -> PinCapabilities -> ShowS
[PinCapabilities] -> ShowS
PinCapabilities -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PinCapabilities] -> ShowS
$cshowList :: [PinCapabilities] -> ShowS
show :: PinCapabilities -> String
$cshow :: PinCapabilities -> String
showsPrec :: Int -> PinCapabilities -> ShowS
$cshowsPrec :: Int -> PinCapabilities -> ShowS
Show, PinCapabilities -> PinCapabilities -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PinCapabilities -> PinCapabilities -> Bool
$c/= :: PinCapabilities -> PinCapabilities -> Bool
== :: PinCapabilities -> PinCapabilities -> Bool
$c== :: PinCapabilities -> PinCapabilities -> Bool
Eq, Eq PinCapabilities
PinCapabilities -> PinCapabilities -> Bool
PinCapabilities -> PinCapabilities -> Ordering
PinCapabilities -> PinCapabilities -> PinCapabilities
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
min :: PinCapabilities -> PinCapabilities -> PinCapabilities
$cmin :: PinCapabilities -> PinCapabilities -> PinCapabilities
max :: PinCapabilities -> PinCapabilities -> PinCapabilities
$cmax :: PinCapabilities -> PinCapabilities -> PinCapabilities
>= :: PinCapabilities -> PinCapabilities -> Bool
$c>= :: PinCapabilities -> PinCapabilities -> Bool
> :: PinCapabilities -> PinCapabilities -> Bool
$c> :: PinCapabilities -> PinCapabilities -> Bool
<= :: PinCapabilities -> PinCapabilities -> Bool
$c<= :: PinCapabilities -> PinCapabilities -> Bool
< :: PinCapabilities -> PinCapabilities -> Bool
$c< :: PinCapabilities -> PinCapabilities -> Bool
compare :: PinCapabilities -> PinCapabilities -> Ordering
$ccompare :: PinCapabilities -> PinCapabilities -> Ordering
Ord)
type family IsDigitalIOPin t where
IsDigitalIOPin t =
'True ~ If (HasPinCapability 'DigitalIO t)
('True)
(TypeError ('Text "This Pin does not support digital IO"))
type family IsAnalogInputPin t where
IsAnalogInputPin t =
'True ~ If (HasPinCapability 'AnalogInput t)
('True)
(TypeError ('Text "This Pin does not support analog input"))
type family IsPWMPin t where
IsPWMPin t =
'True ~ If (HasPinCapability 'PWM t)
('True)
(TypeError ('Text "This Pin does not support PWM"))
type family HasPinCapability (c :: t) (list :: [t]) :: Bool where
HasPinCapability c '[] = 'False
HasPinCapability c (x ': xs) = SameCapability c x || HasPinCapability c xs
type family SameCapability a b :: Bool where
SameCapability 'DigitalIO 'DigitalIO = 'True
SameCapability 'AnalogInput 'AnalogInput = 'True
SameCapability 'PWM 'PWM = 'True
SameCapability _ _ = 'False