{-# LANGUAGE DeriveGeneric #-}
module Circus.DSL where
import Circus.Types
import Control.Monad.State.Class
import Data.Map (Map)
import qualified Data.Map as M
import qualified Data.Text as T
import GHC.Generics
import Generics.SYB hiding (Generic)
data GraphState = GraphState
{ GraphState -> Bit
gs_next_port :: Bit
, GraphState -> Module
gs_module :: Module
}
deriving stock ((forall x. GraphState -> Rep GraphState x)
-> (forall x. Rep GraphState x -> GraphState) -> Generic GraphState
forall x. Rep GraphState x -> GraphState
forall x. GraphState -> Rep GraphState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GraphState x -> GraphState
$cfrom :: forall x. GraphState -> Rep GraphState x
Generic)
instance Semigroup GraphState where
GraphState Bit
b1 Module
m1 <> :: GraphState -> GraphState -> GraphState
<> GraphState Bit
b2 Module
m2
= GraphState :: Bit -> Module -> GraphState
GraphState
{ gs_next_port :: Bit
gs_next_port = Bit
b1 Bit -> Bit -> Bit
forall a. Num a => a -> a -> a
+ Bit
b2
, gs_module :: Module
gs_module = Module
m1 Module -> Module -> Module
forall a. Semigroup a => a -> a -> a
<> Module
m2
}
instance Monoid GraphState where
mempty :: GraphState
mempty = GraphState :: Bit -> Module -> GraphState
GraphState
{ gs_next_port :: Bit
gs_next_port = Int -> Bit
Bit Int
0
, gs_module :: Module
gs_module = Module
forall a. Monoid a => a
mempty
}
freshBit :: MonadState GraphState m => m Bit
freshBit :: m Bit
freshBit = do
Bit
p <- (GraphState -> Bit) -> m Bit
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GraphState -> Bit
gs_next_port
(GraphState -> GraphState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((GraphState -> GraphState) -> m ())
-> (GraphState -> GraphState) -> m ()
forall a b. (a -> b) -> a -> b
$ \GraphState
gs ->
GraphState
gs { gs_next_port :: Bit
gs_next_port = GraphState -> Bit
gs_next_port GraphState
gs Bit -> Bit -> Bit
forall a. Num a => a -> a -> a
+ Bit
1 }
Bit -> m Bit
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bit
p
addCell :: MonadState GraphState m => Cell -> m ()
addCell :: Cell -> m ()
addCell Cell
c = do
Bit
uniq <- m Bit
forall (m :: * -> *). MonadState GraphState m => m Bit
freshBit
let name :: CellName
name = Text -> CellName
CellName (Text -> CellName) -> Text -> CellName
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Bit -> Int
getBit Bit
uniq
(GraphState -> GraphState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((GraphState -> GraphState) -> m ())
-> (GraphState -> GraphState) -> m ()
forall a b. (a -> b) -> a -> b
$ \GraphState
gs ->
GraphState
gs { gs_module :: Module
gs_module = GraphState -> Module
gs_module GraphState
gs
Module -> Module -> Module
forall a. Semigroup a => a -> a -> a
<> Map PortName Port -> Map CellName Cell -> Module
Module Map PortName Port
forall a. Monoid a => a
mempty (CellName -> Cell -> Map CellName Cell
forall k a. k -> a -> Map k a
M.singleton CellName
name Cell
c)
}
unifyBitsPure :: Data a => Map Bit Bit -> a -> a
unifyBitsPure :: Map Bit Bit -> a -> a
unifyBitsPure Map Bit Bit
rep = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((forall a. Data a => a -> a) -> forall a. Data a => a -> a)
-> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
forall a b. (a -> b) -> a -> b
$ (Bit -> Bit) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT ((Bit -> Bit) -> a -> a) -> (Bit -> Bit) -> a -> a
forall a b. (a -> b) -> a -> b
$ \case
Bit
b | Just Bit
b' <- Bit -> Map Bit Bit -> Maybe Bit
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Bit
b Map Bit Bit
rep -> Bit
b'
| Bool
otherwise -> Bit
b
unifyBits :: MonadState GraphState m => Map Bit Bit -> m ()
unifyBits :: Map Bit Bit -> m ()
unifyBits Map Bit Bit
rep =
(GraphState -> GraphState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((GraphState -> GraphState) -> m ())
-> (GraphState -> GraphState) -> m ()
forall a b. (a -> b) -> a -> b
$ \GraphState
gs -> GraphState
gs
{ gs_module :: Module
gs_module = Map Bit Bit -> Module -> Module
forall a. Data a => Map Bit Bit -> a -> a
unifyBitsPure Map Bit Bit
rep (Module -> Module) -> Module -> Module
forall a b. (a -> b) -> a -> b
$ GraphState -> Module
gs_module GraphState
gs
}