{-# 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
    }


------------------------------------------------------------------------------
-- | Synthesize a fresh 'Bit', suitable for connecting 'Cell's
-- together.
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


------------------------------------------------------------------------------
-- | Add a 'Cell' to the 'Module' under construction.
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)
       }


------------------------------------------------------------------------------
-- | Like 'unifyBits', but works in pure contexts.
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


------------------------------------------------------------------------------
-- | Given a mapping from source 'Bit's to target 'Bit's, replace
-- all occurences of the source bits in the 'Module' with the target bits.
--
-- This function allows you to call 'addCell' as you go, and create
-- feedback loops later without needing to know about them in
-- advance.
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
    }