circus (empty) → 0.1.0.0

raw patch · 8 files changed

+548/−0 lines, 8 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, containers, mtl, syb, text

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +41/−0
Setup.hs +2/−0
circus.cabal +72/−0
src/Circus/DSL.hs +77/−0
src/Circus/Simplify.hs +60/−0
src/Circus/Types.hs +263/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for circus++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Sandy Maguire (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Sandy Maguire nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,41 @@+# circus++[![Build Status](https://travis-ci.com/isovector/circus.svg?branch=master)](https://travis-ci.org/isovector/circus)++## Dedication++> Like it? Well I don't see why I oughtn't to like it. Does a boy get a chance+> to whitewash a fence every day?"+>+> --Tom Sawyer, 'The Adventures Of Tom Sawyer'+++## Overview++This package contains types and a little DSL for producing JSON worthy of [netlistsvg](https://github.com/nturley/netlistsvg) --- a fantastic program for drawing circuit diagrams.+++## Usage++While the `Circus.Types` module contains the bare-metal types that serialize in+the expected format, it's not a joyful experience to use for yourself. Instead,+`mkCell` is a smart constructor that will do what you want.++The most interesting types are `Cell`s, which correspond to electrical+components, and `Module`s, which are circuits themselves. The oddly named `Bit`+represents an electrical node (a wire), and two components are connected by+making them share a `Bit`.++Of course, `Module`s form a monoid, so they're easy to put together.++But what makes them easier to put together is the `Circus.DSL` module, which+provides some monadic actions for building `Module`s. It gives you access to a+fresh supply of unique `Bit`s, automatically accumulates `Cell`s, and allows for+`Bit` unification (feedback loops.)++Optimistically added components that never ended up getting used? Automatically+prune them with the `simplify` from `Circus.Simplify`!++When you're all done, call `renderModuleBS` or `renderModuleString` to get a+JSON representation ready to ship off to `netlistsvg`. Easy as that, my dude.+

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ circus.cabal view

@@ -0,0 +1,72 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           circus+version:        0.1.0.0+synopsis:       Types and a small DSL for working with netlistsvg+description:    Please see the README on GitHub at <https://github.com/isovector/circus#readme>+category:       Hardware+homepage:       https://github.com/isovector/circus#readme+bug-reports:    https://github.com/isovector/circus/issues+author:         Sandy Maguire+maintainer:     sandy@sandymaguire.me+copyright:      Sandy Maguire+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/isovector/circus++library+  exposed-modules:+      Circus.DSL+      Circus.Simplify+      Circus.Types+  other-modules:+      Paths_circus+  hs-source-dirs:+      src+  default-extensions:+      BangPatterns+      ConstraintKinds+      DataKinds+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      GADTSyntax+      GeneralizedNewtypeDeriving+      LambdaCase+      MultiParamTypeClasses+      PatternSynonyms+      RankNTypes+      ScopedTypeVariables+      TupleSections+      TypeFamilies+      TypeOperators+      TypeSynonymInstances+      ViewPatterns+  ghc-options: -Wall+  build-depends:+      aeson >=1.0.0.0+    , base >=4.10 && <5+    , bytestring+    , containers+    , mtl+    , syb+    , text+  default-language: Haskell2010

+ src/Circus/DSL.hs view

@@ -0,0 +1,77 @@+{-# 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+  { gs_next_port :: Bit+  , gs_module    :: Module+  }+  deriving stock (Generic)++instance Semigroup GraphState where+  GraphState b1 m1 <> GraphState b2 m2+    = GraphState+    { gs_next_port = b1 + b2+    , gs_module = m1 <> m2+    }++instance Monoid GraphState where+  mempty = GraphState+    { gs_next_port = Bit 0+    , gs_module = mempty+    }+++------------------------------------------------------------------------------+-- | Synthesize a fresh 'Bit', suitable for connecting 'Cell's+-- together.+freshBit :: MonadState GraphState m => m Bit+freshBit = do+  p <- gets gs_next_port+  modify $ \gs ->+    gs { gs_next_port = gs_next_port gs + 1 }+  pure p+++------------------------------------------------------------------------------+-- | Add a 'Cell' to the 'Module' under construction.+addCell :: MonadState GraphState m => Cell -> m ()+addCell c = do+  uniq <- freshBit+  let name = CellName $ T.pack $ show $ getBit uniq+  modify' $ \gs ->+    gs { gs_module = gs_module gs+                  <> Module mempty (M.singleton name c)+       }+++------------------------------------------------------------------------------+-- | Like 'unifyBits', but works in pure contexts.+unifyBitsPure :: Data a => Map Bit Bit -> a -> a+unifyBitsPure rep  = everywhere $ mkT $ \case+  b | Just b' <- M.lookup b rep -> b'+    | otherwise -> 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 rep =+  modify' $ \gs -> gs+    { gs_module = unifyBitsPure rep $ gs_module gs+    }+

+ src/Circus/Simplify.hs view

@@ -0,0 +1,60 @@+module Circus.Simplify (simplify) where++import           Circus.Types+import           Control.Arrow+import           Data.List+import qualified Data.Map as M+import           Data.Maybe+import           Data.Set (Set)+import qualified Data.Set as S++------------------------------------------------------------------------------+-- | Gather sets of input and output ports for the given cell.+cellPorts :: Cell -> (Set PortName, Set PortName)+cellPorts c =+  let ports = M.assocs $ cellPortDirections c+      (ip, op) = fmap fst *** fmap fst $ partition ((== Input) . snd) ports+   in (S.fromList ip, S.fromList op)+++------------------------------------------------------------------------------+-- | Gather input and output bits for the given cell.+ioBits :: Module -> (Set Bit, Set Bit)+ioBits m = flip foldMap (moduleCells m) $ \c ->+  let (ip, op) = cellPorts c+      ib = foldMap (fromMaybe [] . flip M.lookup (cellConnections c)) $ ip+      ob = foldMap (fromMaybe [] . flip M.lookup (cellConnections c)) $ op+      mod_ports = fmap (portDirection &&& portBits) $ M.elems $ modulePorts m+      (iports, oports) = (snd =<<) *** (snd =<<) $ partition ((== Input) . fst) mod_ports+   in (S.fromList $ ib <> oports, S.fromList $ ob <> iports)+++------------------------------------------------------------------------------+-- | Delete any cells which output only bits in the @to_kill@ set.+pruneCellsOutput :: Set Bit -> Module -> Module+pruneCellsOutput to_kill m = m+  { moduleCells = M.filter (not . should_kill) $ moduleCells m+  }+  where+    should_kill :: Cell -> Bool+    should_kill c =+      let (_, op) = cellPorts c+       in case S.toList op of+            [pn] ->+              let bits = fromMaybe [] $ M.lookup pn $ cellConnections c+               in all (flip S.member to_kill) bits+            _ -> False+++------------------------------------------------------------------------------+-- | Recursively delete cells that output only bits which are unused in the+-- circuit.+simplify :: Module -> Module+simplify m =+  let (ib, ob) = ioBits m+      to_kill = ob S.\\ ib+      m' = pruneCellsOutput to_kill m+   in case m == m' of+        True -> m+        False -> simplify m'+

+ src/Circus/Types.hs view

@@ -0,0 +1,263 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++module Circus.Types where++import           Control.Applicative (empty)+import           Data.Aeson+import           Data.Aeson.TH+import           Data.Aeson.Types (toJSONKeyText)+import           Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy.Char8 as BS+import           Data.Char+import           Data.Data (Data)+import           Data.Map (Map)+import qualified Data.Map as M+import           Data.String (IsString)+import           Data.Text (Text)+import qualified Data.Text as T+import           GHC.Generics (Generic)+++------------------------------------------------------------------------------+-- | A collection of modules.+newtype Schema = Schema+  { schemaModules :: Map ModuleName Module+  }+  deriving stock (Eq, Show, Data)+  deriving newtype (Semigroup, Monoid)+++data Module = Module+  { -- | Inputs and outputs+    modulePorts :: Map PortName Port+    -- | Components+  , moduleCells :: Map CellName Cell+  }+  deriving stock (Eq, Show, Data)++instance Semigroup Module where+  (<>) (Module p1 c1) (Module p2 c2) = Module+    { modulePorts = p1 <> p2+    , moduleCells = c1 <> c2+    }++instance Monoid Module where+  mempty = Module {modulePorts = mempty, moduleCells = mempty}++newtype ModuleName = ModuleName { getModuleName :: Text }+  deriving stock (Data)+  deriving newtype (Eq, Ord, Show, IsString, ToJSONKey, FromJSONKey, FromJSON, ToJSON)++newtype PortName = PortName { getPortName :: Text }+  deriving stock (Data)+  deriving newtype (Eq, Ord, Show, IsString, ToJSONKey, FromJSONKey, FromJSON, ToJSON)++newtype CellName = CellName { getCellName :: Text }+  deriving stock (Data)+  deriving newtype (Eq, Ord, Show, IsString, ToJSONKey, FromJSONKey, FromJSON, ToJSON)++++data Port = Port+  { -- | Whether this port is an input or an output+    portDirection :: Direction+    -- | The individual wires connected to this port. They are numbered in the+    -- same order they are described here.+  , portBits :: [Bit]+  }+  deriving stock (Eq, Show, Data)++------------------------------------------------------------------------------+-- | A single wire. Bits are defined implicitly by a unique ID. Every component+-- that references the bit will be connected with a common node.+newtype Bit = Bit { getBit :: Int }+  deriving stock (Eq, Ord, Show, Data)+  deriving newtype (Num, ToJSON, FromJSON)+++data Cell = Cell+  { -- | The symbol to use when drawing this cell.+    cellType :: CellType+  , cellParameters :: Map Parameter Int+  , cellAttributes :: Map Text Value+    -- | Which ports are inputs and outputs.+  , cellPortDirections :: Map PortName Direction+    -- | What are the ports connected to? Each port may connect to several+    -- bits, but make sure you set the 'Width' cell 'Parameter' if this is the+    -- case.+  , cellConnections :: Map PortName [Bit]+  }+  deriving stock (Eq, Show, Data)+++data Parameter+  = -- | How many bits wide is the given 'Port'?+    Width PortName+    -- | Is the given 'Port' signed?+  | Signed PortName+  deriving stock (Eq, Ord, Show, Generic, Data)+  deriving anyclass (FromJSON, ToJSON)++instance ToJSONKey Parameter where+  toJSONKey = toJSONKeyText $ \case+    Width pn -> getPortName pn <> "_WIDTH"+    Signed pn -> getPortName pn <> "_SIGNED"+  toJSONKeyList = error "toJSONKeyList called on Parameter"++instance FromJSONKey Parameter where+  fromJSONKey = undefined+++data Direction+  = Input+  | Output+  deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Data)++instance ToJSON Direction where+  toJSON Input = String "input"+  toJSON Output = String "output"++instance FromJSON Direction where+  parseJSON = withText "Direction" $ \case+    "input" ->  pure Input+    "output" -> pure Output+    _ -> empty+++------------------------------------------------------------------------------+-- | Master list of cells, and their associated names is available here:+--+-- https://raw.githubusercontent.com/nturley/netlistsvg/master/lib/default.svg?sanitize=true+data CellType = CellGeneric Text+  deriving stock (Eq, Ord, Show, Data)+++pattern CellMux :: CellType+pattern CellMux = CellGeneric "$mux"++pattern CellMuxBus :: CellType+pattern CellMuxBus = CellGeneric "$mux-bus"++pattern CellTribuf :: CellType+pattern CellTribuf = CellGeneric "$tribuf"++pattern CellAnd :: CellType+pattern CellAnd = CellGeneric "$and"++pattern CellOr :: CellType+pattern CellOr = CellGeneric "$or"++pattern CellNand :: CellType+pattern CellNand = CellGeneric "$nand"++pattern CellNor :: CellType+pattern CellNor = CellGeneric "$nor"++pattern CellXor :: CellType+pattern CellXor = CellGeneric "$xor"++pattern CellXnor :: CellType+pattern CellXnor = CellGeneric "$xnor"++pattern CellNot :: CellType+pattern CellNot = CellGeneric "$not"++pattern CellAdd :: CellType+pattern CellAdd = CellGeneric "$add"++pattern CellEq :: CellType+pattern CellEq = CellGeneric "$eq"++pattern CellDff :: CellType+pattern CellDff = CellGeneric "$dff"++pattern CellDffn :: CellType+pattern CellDffn = CellGeneric "$dffn-bus"++pattern CellLt :: CellType+pattern CellLt = CellGeneric "$lt"++pattern CellGe :: CellType+pattern CellGe = CellGeneric "$ge"++pattern CellConstant :: CellType+pattern CellConstant = CellGeneric "$_constant_"+++instance ToJSON CellType where+  toJSON (CellGeneric t) = String t++instance FromJSON CellType where+  parseJSON = withText "CellType" $ pure . CellGeneric++$(deriveJSON+    defaultOptions+      { fieldLabelModifier = camelTo2 '_' . drop 4+      , constructorTagModifier = map toLower+      }+      ''Cell+ )++$(deriveJSON+    defaultOptions+      { fieldLabelModifier = camelTo2 '_' . drop 4+      , constructorTagModifier = map toLower+      }+      ''Port+ )++$(deriveJSON+    defaultOptions+      { fieldLabelModifier = camelTo2 '_' . drop 6+      , constructorTagModifier = map toLower+      }+      ''Module+ )++$(deriveJSON+    defaultOptions+      { fieldLabelModifier = camelTo2 '_' . drop 6+      , constructorTagModifier = map toLower+      }+      ''Schema+ )+++renderModuleBS :: Module -> ByteString+renderModuleBS+  = encode+  . Schema+  . M.singleton "module"+++renderModuleString :: Module -> String+renderModuleString+  = BS.unpack+  . renderModuleBS+++------------------------------------------------------------------------------+-- | Helper function for constructing 'Cell's.+mkCell+    :: CellType+    -> M.Map PortName (Direction, [Bit])+    -> Cell+mkCell = flip mkCell' mempty+++------------------------------------------------------------------------------+-- | Helper function for constructing 'Cell's with explicit attributes.+mkCell'+    :: CellType+    -> M.Map T.Text Value  -- ^ Attributes+    -> M.Map PortName (Direction, [Bit])+    -> Cell+mkCell' ty as m =+  Cell+    ty+    (M.fromList $ fmap (\(pn, bs) -> (Width pn, length bs)) $ M.toList $ fmap snd m)+    as+    (fmap fst m)+    (fmap snd m)+