HHDL (empty) → 0.1.0.0

raw patch · 14 files changed

+2483/−0 lines, 14 filesdep +basedep +containersdep +mtlsetup-changed

Dependencies added: base, containers, mtl, template-haskell

Files

• HHDL.cabal +82/−0
• LICENSE +30/−0
• Setup.hs +2/−0
• src/Hardware/HHDL.hs +10/−0
• src/Hardware/HHDL/BitRepr.hs +86/−0
• src/Hardware/HHDL/Examples/Clock.hs +22/−0
• src/Hardware/HHDL/Examples/RunningSum.hs +28/−0
• src/Hardware/HHDL/Examples/RunningSumMaybes.hs +60/−0
• src/Hardware/HHDL/Examples/SimpleSum.hs +18/−0
• src/Hardware/HHDL/HDLPrelude.hs +119/−0
• src/Hardware/HHDL/HHDL.hs +1211/−0
• src/Hardware/HHDL/TH.hs +457/−0
• src/Hardware/HHDL/ToWires.hs +113/−0
• src/Hardware/HHDL/TyLeA.hs +245/−0

@@ -0,0 +1,82 @@+-- HHDL.cabal auto-generated by cabal init. For additional options,
+-- see
+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.
+-- The name of the package.
+Name:                HHDL
+
+-- The package version. See the Haskell package versioning policy
+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for
+-- standards guiding when and how versions should be incremented.
+Version:             0.1.0.0
+
+-- A short (one-line) description of the package.
+Synopsis:            Hardware Description Language embedded in Haskell.
+
+-- A longer description of the package.
+Description:         Hardware Description Language embedded in Haskell.
+                     Main distinction from Lava or similar packages is
+                     that HHDL supports algebraic types with pattern matching.
+
+-- URL for the project homepage or repository.
+Homepage:            http://thesz.mskhug.ru/svn/hhdl/hackage/hhdl/
+
+-- The license under which the package is released.
+License:             BSD3
+
+-- The file containing the license text.
+License-file:        LICENSE
+
+-- The package author(s).
+Author:              Serguey Zefirov
+
+-- An email address to which users can send suggestions, bug reports,
+-- and patches.
+Maintainer:          sergueyz@gmail.com
+
+-- Stability is experimental right now.
+Stability:           experimental
+
+-- A copyright notice.
+Copyright:           Copyright (C) 2010, 2011 Serguey Zefirov
+
+Category:            Hardware
+
+Build-type:          Simple
+
+-- Extra files to be distributed with the package, such as examples or
+-- a README.
+-- Extra-source-files:  
+
+-- Constraint on the version of Cabal needed to build this package.
+Cabal-version:       >=1.2
+
+-- Tested with.
+Tested-with: GHC == 6.12.1
+
+
+Library
+  -- Modules exported by the library.
+  Exposed-modules:     Hardware.HHDL
+
+  -- Sources are in proper directory:
+  hs-source-dirs:      src
+
+  -- Packages needed in order to build this package.
+  Build-depends:       base >= 3.0 && < 4.0,
+                       template-haskell >= 2.4 && < 2.5,
+                       containers >= 0.3 && < 0.4,
+                       mtl >= 1.1
+  
+  -- Modules not exported by this package.
+  Other-modules:       Hardware.HHDL.HHDL, Hardware.HHDL.TH, 
+                       Hardware.HHDL.BitRepr, Hardware.HHDL.HDLPrelude,
+                       Hardware.HHDL.ToWires, Hardware.HHDL.TyLeA,
+                       Hardware.HHDL.Examples.Clock, Hardware.HHDL.Examples.RunningSum,
+                       Hardware.HHDL.Examples.SimpleSum,
+                       Hardware.HHDL.Examples.RunningSumMaybes
+  
+  -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.
+  -- Build-tools:         
+
+  -- Tested with.
+  -- tested-with: ghc-6.12.1

@@ -0,0 +1,30 @@+Copyright (c)2011, Serguey Zefirov
+
+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 Serguey Zefirov 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.

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

@@ -0,0 +1,10 @@+-- |Hardware.HHDL
+-- Convenient top-level module that exports everything HHDL-related.
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Hardware.HHDL(
+	  module Hardware.HHDL.HHDL
+	) where
+
+import Hardware.HHDL.HHDL

@@ -0,0 +1,86 @@+-- |BitRepr.hs
+-- Bit representation.
+
+{-# LANGUAGE RankNTypes, GADTs, TypeFamilies, TypeOperators, TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, OverlappingInstances #-}
+
+module Hardware.HHDL.BitRepr where
+
+import Data.Bits
+
+import Hardware.HHDL.TyLeA
+
+-------------------------------------------------------------------------------
+-- Main class.
+
+class Nat (BitVectorSize a) => BitRepr a where
+	type BitVectorSize a
+
+	-- |Convert value to an integer.
+	toBitVector :: a -> Integer
+
+	-- |Convert integer to value. Conversion should ignore any bits above
+	-- "bitVectorSize result".
+	fromBitVector :: Integer -> a
+
+	-- |Size of value in bits.
+	bitVectorSize :: a -> Int
+	bitVectorSize a = i
+		where
+			getSize :: a -> BitVectorSize a
+			getSize a = undefined
+			i = fromNat (getSize a)
+
+	-- |Mask for value's significant bits.
+	-- In usual bit vectors they are all significant (default variant below).
+	-- In algebraic types they aren't: data T = B Bool | W Word64.
+	-- The mask for B x could ignore significant bits from Word64 in W.
+	-- Right now it is not widely used, so it is safe to leave it as it is.
+	bitMask :: a -> Integer
+	bitMask a = shiftL 1 (bitVectorSize a) - 1
+
+
+-------------------------------------------------------------------------------
+-- Support definitions and type functions for algebraic types.
+-- instances are generated by calling generateMakeMatches from TH.hs.
+
+-- |How much bits do we need to pass arguments for any constructor?
+type family ArgsBusSize a
+
+-- |How much bits do we need for constructor selector?
+type family SelectorBusSize a
+
+
+-- Utility conversion function.
+-- USed for toBitVector/fromBitVector implementations.
+_toArgsBusSize :: a -> ArgsBusSize a
+_toArgsBusSize = undefined
+
+_toArgsBusSizeInt :: Nat (ArgsBusSize a) => a -> Int
+_toArgsBusSizeInt = fromNat . _toArgsBusSize
+
+_toSelBusSize :: a -> SelectorBusSize a
+_toSelBusSize = undefined
+
+_toSelBusSizeInt :: Nat (SelectorBusSize a) => a -> Int
+_toSelBusSizeInt = fromNat . _toSelBusSize
+
+_combineConstructorIndexArgs :: Integer -> Int -> Integer -> Integer
+_combineConstructorIndexArgs argsVector shift ci = shiftL ci shift .|. argsVector
+
+-- |Helper class that breaks some type checking dependencies and
+-- allow for faster compilation.
+class (Nat (ArgsBusSize a), Nat (SelectorBusSize a)) => AlgTypeBitEnc a where
+	algTypeArgsBusSize :: a -> Int
+	algTypeArgsBusSize a = fromNat (_toArgsBusSize a)
+
+	algTypeArgsBusMask :: a -> Integer
+	algTypeArgsBusMask a = shiftL 1 (algTypeArgsBusSize a) - 1
+
+	algTypeSelectorBusSize :: a -> Int
+	algTypeSelectorBusSize = _toSelBusSizeInt
+
+	algTypeSelectorBusMask :: a -> Integer
+	algTypeSelectorBusMask a = shiftL 1 (_toSelBusSizeInt a) - 1
+

@@ -0,0 +1,22 @@+-- |Hardware.HHDL.Examples.Clock
+-- Clock description for examples.
+
+{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts, DoRec #-}
+{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude, TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+
+module Hardware.HHDL.Examples.Clock where
+
+import Hardware.HHDL
+
+data Clk = Clk deriving Typeable
+data Reset = Reset deriving Typeable
+instance Clock Clk where
+	type ClkReset Clk = Reset
+	clockValue = Clk
+	clockResetPositive _ = False
+	clockFrontEdge _ = True
+
+fixClockedClock :: Clocked (Clk :. Nil) ins outs -> Clocked (Clk :. Nil) ins outs
+fixClockedClock clocked = clocked

@@ -0,0 +1,28 @@+{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts, DoRec #-}+{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude, TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++module Hardware.HHDL.Examples.RunningSum where++import Data.Word++import Hardware.HHDL++import Hardware.HHDL.Examples.Clock+import Hardware.HHDL.Examples.SimpleSum++-------------------------------------------------------------------------------+-- Running polymorphic sum, ie, accumulator.+-- Demonstrates registers.++runningSumRec :: (Show a, ArithResult a ~ a, ClockAllowed c clks, IntegerConstant a, BitRepr a, BitRepr (ArithResult a), Arith (Wire c a)) => Clocked clks (Wire c a :. Nil) (Wire c a :. Nil)+runningSumRec = mkClocked "runningSum" $ \(a :. Nil) -> do+	rec+		sum <- register 0 nextSum+		(nextSum :. Nil) <- instantiate simpleSum (a :. sum :. Nil)+	return $ sum :. Nil++runningSumRecVHDLText = writeHDLText VHDL (runningSumRec :: Clocked (Clk :. Nil) (Wire Clk Word8 :. Nil) (Wire Clk Word8 :. Nil))+	(\s -> putStrLn s >> writeFile "runningSum.vhdl" s)++test = runningSumRecVHDLText

@@ -0,0 +1,60 @@+-- Many extensions. I overload many things from Haskell Prelude in the style+-- of Awesome Prelude. Also you may need a Template Haskell transformations+-- on declarations, which derives classes and type families instances, etc, etc.+{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts, DoRec #-}+{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude, TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++module Hardware.HHDL.Examples.RunningSumMaybes where++import Data.Word++-- The main module of the library. It exports everything I deemed useful+-- for hardware description - code generation over ADT, netlist operators, some+-- handy functions from Prelude...+-- Also, it contains making of wires for Either and Maybe and matching functions.+import Hardware.HHDL++-- The description of clocking frequency for our example.+import Hardware.HHDL.Examples.Clock++-------------------------------------------------------------------------------+-- How to pattern match an algebraic type.++-- Clocked is a type of entity. It has three arguments: a list of clocking frequencies allowed+-- in netlist, types of inputs and outputs.+runningSumMaybes :: Clock c => Mealy c (Wire c (Maybe Word8) :. Nil) (Wire c Word8 :. Nil)+runningSumMaybes = mkMealyNamed+	-- names of inputs and outputs.+	(Just ("maybeA" :. Nil, "currentSum" :. Nil))+	-- default value for state.+	(0 :. Nil)+	"runningSumMaybes" $ \(sum :. Nil) (mbA :. Nil) -> do+        -- here we pattern match in the <a href=http://hackage.haskell.org/package/first-class-patterns>"First class patterns"</a> style.+        -- the idea is that for each constructor Cons of algebraic type T we automatically+        -- create two functions:+        --   - mkCons which creates a wire (of type Wire c T) from wires of arguments and+        --   - pCons which matches a wire of type Wire c T with patterns of types of Cons+        --     arguments.+        -- pJust and pNothing were generated in Hardware.HHDL.HHDL from the description of+        -- Maybe type.+        -- pvar is a pattern that matches anything and passes that anything as an argument+        -- to processing function.+	a <- match mbA [+                -- if we have Just x, return it!+		  pJust pvar --> \(x :. Nil) -> return x+                -- default with 0, if Nothing.+		, pNothing --> \Nil -> return (constant 0)+		]+        -- compute the sum.+	nextSum <- assignWire (sum + a)+        -- return currently locked sum.+	return (nextSum :. Nil, sum :. Nil)++-- How to obtain VHDL text - we fix polymorphic parameters in Clocked, generate text (with any+-- entities we have to use) and pass it to display and write function.+runningSumMaybesVHDLText = writeHDLText VHDL (runningSumMaybes :: Mealy Clk (Wire Clk (Maybe Word8) :. Nil) (Wire Clk Word8 :. Nil))+	(\s -> putStrLn s >> writeFile "runningSumMaybes.vhdl" s)++-- a shortcut.+test = runningSumMaybesVHDLText

@@ -0,0 +1,18 @@+{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts, DoRec #-}+{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude, TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++module Hardware.HHDL.Examples.SimpleSum where++import Data.Word++import Hardware.HHDL++-------------------------------------------------------------------------------+-- Polymorphic sum of inputs.++simpleSum :: (Show a, BitRepr a, BitRepr (ArithResult a), Arith (Wire c a)) => Comb (Wire c a :. Wire c a :. Nil) (Wire c (ArithResult a) :. Nil)+simpleSum = mkComb "simpleSum" $ \(a :. b :. Nil) -> do+	t <- assignWire (a+b)+	return $ t :. Nil+

@@ -0,0 +1,119 @@+{-# LANGUAGE RankNTypes, GADTs, TypeFamilies, TypeOperators, TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, OverlappingInstances, NoImplicitPrelude #-}
+
+
+module Hardware.HHDL.HDLPrelude where
+
+import Prelude
+	( putStrLn, ($), (.), IO, (++), String, repeat, zipWith, head
+	, fst, snd, length, map, Show(..), reverse, Int, Integer, flip, filter
+	, unwords, unlines, replicate, const, undefined, error, Ordering(..)
+	, concat, concatMap, tail, iterate, Bool, Char, id)
+
+import qualified Prelude
+import Data.Word
+
+-------------------------------------------------------------------------------
+-- Replacement for Prelude classes.
+
+infixl 6 +, -
+infixl 7 *
+class Arith op where
+	type ArithResult op
+	(+), (-), (*) :: op -> op -> ArithResult op
+
+class IntegerConstant a where
+	fromInteger :: Integer -> a
+
+class ToInteger a where
+	toInteger :: a -> Integer
+
+convertThroughInteger :: (IntegerConstant res, ToInteger arg) => arg -> res
+convertThroughInteger = fromInteger . toInteger
+
+infix 4 ==, /=
+class Eq a where
+	type EqResult a
+	(==), (/=) :: a -> a -> EqResult a
+
+infixr 3 &&
+infixr 2 ||
+class Boolean b where
+	not :: b -> b
+	(&&), (||) :: b -> b -> b
+
+infix 4 <, >, <=, >=
+class Boolean b => Compare a b where
+	(>), (<), (>=), (<=) :: a -> a -> b
+
+
+-------------------------------------------------------------------------------
+-- Required instances.
+
+instance IntegerConstant Int where
+	fromInteger = Prelude.fromInteger
+
+instance ToInteger Int where
+	toInteger = Prelude.toInteger
+
+instance IntegerConstant Integer where
+	fromInteger = Prelude.fromInteger
+
+instance ToInteger Integer where
+	toInteger = Prelude.toInteger
+
+instance Boolean Bool where
+	not = Prelude.not
+	(&&) = (Prelude.&&)
+	(||) = (Prelude.||)
+
+instance Arith Int where
+	type ArithResult Int = Int
+	(+) = (Prelude.+)
+	(-) = (Prelude.-)
+	(*) = (Prelude.*)
+
+instance Arith Integer where
+	type ArithResult Integer = Integer
+	(+) = (Prelude.+)
+	(-) = (Prelude.-)
+	(*) = (Prelude.*)
+
+instance Eq Char where
+	type EqResult Char = Bool
+	(==) = (Prelude.==)
+	(/=) = (Prelude./=)
+
+instance Eq Int where
+	type EqResult Int = Bool
+	(==) = (Prelude.==)
+	(/=) = (Prelude./=)
+
+instance Compare Int Bool where
+	(>) = (Prelude.>)
+	(<) = (Prelude.<)
+	(>=) = (Prelude.>=)
+	(<=) = (Prelude.<=)
+
+instance Arith Word8 where
+	type ArithResult Word8 = Word8
+	(+) = (Prelude.+)
+	(-) = (Prelude.-)
+	(*) = (Prelude.*)
+
+instance Eq Word8 where
+	type EqResult Word8 = Bool
+	(==) = (Prelude.==)
+	(/=) = (Prelude./=)
+
+instance Eq Integer where
+	type EqResult Integer = Bool
+	(==) = (Prelude.==)
+	(/=) = (Prelude./=)
+
+instance IntegerConstant Word8 where
+	fromInteger = Prelude.fromInteger
+
+instance ToInteger Word8 where
+	toInteger = Prelude.toInteger

@@ -0,0 +1,1211 @@+{-# LANGUAGE RankNTypes, GADTs, TypeFamilies, TypeOperators, TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses, OverlappingInstances, NoImplicitPrelude #-}+{-# LANGUAGE DoRec #-}+-- {-# LANGUAGE NoMonomorphismRestriction #-}++module Hardware.HHDL.HHDL(+	-- convenience exports.+	  module Data.Typeable+	, module Hardware.HHDL.HDLPrelude+	, module Prelude+	, module Control.Monad.Fix+	, module Hardware.HHDL.BitRepr+	, module Hardware.HHDL.TyLeA+	, module Hardware.HHDL.TH+	-- This module exports.+	, (:.)(..), Nil(Nil)	-- our own HList.+	, Wire			-- abstract type.+	, HDL(..)		-- what kind of HDL you want to generate.+	, WireOp(..)		-- the means to extend operations.+	, toBits		-- a method to get bit vector from a type.+	, WList+	, WiresList		-- a class that defines list of wires.+	, NLM+	, Clock(..), ClockAllowed+	, Clocked		-- the type constructor of clocked circuits.+	, mkClockedNamed	-- for top-level exported entities.+	, mkClocked+	, Comb			-- the type constrictor of combinational (stateless) circuits.+	, mkComb+	, Mealy			-- simple MEaly state machine.+	, mkMealyNamed		-- for top-level exported entities.+	, mkMealy+	, assignWire		-- w <- assignWire (expression)+	, assignFlattened+	, register		-- latched <- register defaultValue wireToLatch+	, instantiate		-- instantiate entity, literally. outputs <- instantiate entity inputs+	, constant		-- convert Haskell value (BitRepr one) into wire.+	, writeHDLText		-- write HDL text of an entity.+	, match			-- match expression against list of patterns.+	, (-->)			-- combine pattern and netlists.+	, pvar, pcst, pwild	-- variable match, constant match, wildcard match.+	, pJust, mkJust, pNothing, mkNothing	-- generated for Maybe.+	, pLeft, mkLeft, pRight, mkRight	-- generated for Maybe.+	) where++-- what we need from Prelude:+import Prelude+	( putStrLn, ($), (.), IO, (++), String, repeat, zipWith, head+	, fst, snd, length, map, Show(..), reverse, Int, Integer, flip, filter+	, unwords, unlines, replicate, const, undefined, error, Ordering(..)+	, concat, concatMap, take, tail, iterate, Bool(..), Monad(..)+	, writeFile, otherwise, asTypeOf+	, foldr, foldl, foldl1, zipWith3, zip, init, Maybe(..), Either(..))++import qualified Prelude++import Control.Monad.State+import Control.Monad+import Control.Monad.Fix+import qualified Data.Bits as B+import qualified Data.Bits+import Data.IORef+import Data.List (nub, intersperse)+import Data.Maybe+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Typeable+import Data.Word+import qualified Language.Haskell.TH as TH+import System.IO.Unsafe+import qualified Text.Printf++import Hardware.HHDL.BitRepr+import Hardware.HHDL.HDLPrelude+import Hardware.HHDL.TH+import Hardware.HHDL.TyLeA++-------------------------------------------------------------------------------+-- Our own HList.++infixr 5 :.++data a :. as = a :. as deriving Show+data Nil = Nil++-------------------------------------------------------------------------------+-- Unique index generation.++{-# NOINLINE uniqueCounterRef #-}+uniqueCounterRef :: IORef Int+uniqueCounterRef = unsafePerformIO (newIORef 0)++createUniqueIndex :: (String -> Int -> a) -> String -> a+createUniqueIndex mk n = unsafePerformIO $ do+	atomicModifyIORef uniqueCounterRef (\x -> (x+1,()))+	i <- readIORef uniqueCounterRef+	return $ mk n i++-------------------------------------------------------------------------------+-- What is wire.++data Wire clk ty where+	Wire :: Maybe String -> Int -> Wire clk ty+	Expr :: WireOp (op c ty) => op c ty -> Wire c ty++instance Show (Wire c ty) where+	show w = error "No show for wires right now!"++data HDL = VHDL | Verilog+	deriving (Prelude.Eq, Prelude.Ord, Show)++class BitRepr (WireOpType op) => WireOp op where+	type WireOpType op+	-- |Transformation to HDL.+	opToHDL :: BitRepr (WireOpType op) => HDL -> op -> String++	-- |Flattening transformation.+	opFlatten :: op -> NLM clocks op++	opType :: op -> WireOpType op+	opType op = undefined++	opTypeSize :: op -> Int+	opTypeSize op = bitVectorSize (opType op)++data SimpleOps c ty where+	OpConst :: (BitRepr ty, Show ty) => ty -> SimpleOps c ty+	OpSimpleBin :: (BitRepr res, BitRepr arg) =>+		Wire c arg -> [(HDL,String)] -> Wire c arg -> SimpleOps c res+	OpSimpleUn :: (BitRepr res, BitRepr arg) => [(HDL,String)] -> Wire c arg -> SimpleOps c res++instance BitRepr ty => WireOp (Wire c ty) where+	type WireOpType (Wire c ty) = ty+	opToHDL hdl wire = case wire of+		Wire _ _ -> signalName wire+		Expr e -> opToHDL hdl e+	opFlatten w@(Wire _ _) = return w+	opFlatten (Expr e) = liftM Expr $ opFlatten e++toBits :: BitRepr ty => ty -> String+toBits x+	| n > 1 = show bits+	| otherwise = show $ head bits+	where+		i = toBitVector x+		n = bitVectorSize x+		bits = reverse $ concatMap show $ take n $ map snd $ tail $+			iterate ((`Prelude.divMod` 2) . fst) (i,0)++instance BitRepr ty => WireOp (SimpleOps c ty) where+	type WireOpType (SimpleOps c ty) = ty+	opToHDL hdl (OpConst x) = toBits x+	opToHDL hdl (OpSimpleBin l ops r) = opToHDL hdl l++hdlOp++opToHDL hdl r+		where+			hdlOp = (" "++) $ (++" ") $+				maybe (error $ "No op for hdl "++show hdl) Prelude.id $+					Prelude.lookup hdl ops+	opFlatten o@(OpConst x) = return o+	opFlatten (OpSimpleBin l ops r) = do+		l <- assignFlattened l+		r <- assignFlattened r+		return $ OpSimpleBin l ops r++instance (Show ty, BitRepr ty, IntegerConstant ty) => IntegerConstant (Wire c ty) where+	fromInteger i = Expr (OpConst (fromInteger i))++simpleBinAnyHDL a op b = OpSimpleBin a (Prelude.zip [VHDL, Verilog] (repeat op)) b++instance (BitRepr ty, Arith ty, BitRepr (ArithResult ty)) => Arith (Wire c ty) where+	type ArithResult (Wire c ty) = Wire c (ArithResult ty)+	a + b = Expr $ simpleBinAnyHDL a "+" b+	a - b = Expr $ simpleBinAnyHDL a "-" b+	a * b = Expr $ simpleBinAnyHDL a "*" b++instance Boolean (Wire c Bool) where+	not x = Expr $ OpSimpleUn [(VHDL, "not"), (Verilog, "!")] x+	a && b = Expr $ OpSimpleBin a [(VHDL, "and"),(Verilog, "&&")] b+	a || b = Expr $ OpSimpleBin a [(VHDL, "or"),(Verilog, "||")] b+++type family WList c ts+type instance WList c Nil = Nil+type instance WList c (t :. ts)  = Wire c t :. WList c ts++class WiresList a where+	type WireNamesList a+	mkWireList :: Maybe (WireNamesList a) -> NLM clocks a+	copyWireList :: Maybe (WireNamesList a) -> a -> NLM clocks a+instance WiresList Nil where+	type WireNamesList Nil = Nil+	mkWireList _ = return Nil+	copyWireList _ _ = return Nil+instance (BitRepr a, WiresList as) => WiresList (Wire c a :. as) where+	type WireNamesList (Wire c a :. as) = String :. WireNamesList as+	mkWireList names = do+		let (n,ns) = case names of+			Just (n :. ns) -> (Just n, Just ns)+			Nothing -> (Nothing, Nothing)+		a <- mkWire n+		as <- mkWireList ns+		return (a :. as)+	copyWireList names ~(w :. ws) = do+		let (n,ns) = case names of+			Just (n :. ns) -> (Just n, Just ns)+			Nothing -> (Nothing, Nothing)+		w <- assignWithForcedCopy n w+		ws <- copyWireList ns ws+		return (w :. ws)++class RegisterWiresList a clocks where+	type RegisterDefault a+	registerWiresList :: RegisterDefault a -> a -> NLM clocks a+instance RegisterWiresList Nil clocks where+	type RegisterDefault Nil = Nil+	registerWiresList _ _ = return Nil+instance (Show a, BitRepr a, ClockAllowed c clocks, RegisterWiresList as clocks) => RegisterWiresList (Wire c a :. as) clocks where+	type RegisterDefault (Wire c a :. as) = a :. RegisterDefault as+	registerWiresList ~(a :. as) ~(w :. ws) = do+		w' <- register a w+		ws' <- registerWiresList as ws+		return $ w' :. ws'++data SignalKind = BitSignal | BusSignal Int deriving Show++class HDLSignal a where+	signalNameKind :: a -> (String, SignalKind)++signalName :: HDLSignal a => a -> String+signalName = fst . signalNameKind++signalKind :: HDLSignal a => a -> SignalKind+signalKind = snd . signalNameKind++wireBusSize :: BitRepr a => Wire c a -> Int+wireBusSize wire = bitVectorSize (wireType wire)+	where+		wireType :: BitRepr a => Wire c a -> a+		wireType _ = undefined++wireOpBusSize :: (BitRepr (WireOpType op), WireOp op) => op -> Int+wireOpBusSize op = bitVectorSize (projectType op)+	where+		projectType :: WireOp op => op -> WireOpType op+		projectType = undefined++instance BitRepr a => HDLSignal (Wire c a) where+	signalNameKind wire = (name,kind)+		where+			kind = if width == 1 then BitSignal else BusSignal width+			width = wireBusSize wire+			name = case wire of+				Wire Nothing i -> "generated_temporary_name_"++show i+				Wire (Just n) i -> concat [n,"_",show i]+++class HDLSignals a where+	signalsWires :: a -> [(String,SignalKind)]+instance HDLSignals Nil where+	signalsWires Nil = []+instance (HDLSignal a, HDLSignals as) => HDLSignals (a :. as) where+	signalsWires (w :. ws) = signalNameKind w : signalsWires ws++class HDLOp op where+	opArgs :: WiresList as => op clk ty -> as+	opSize :: BitRepr ty => op clk ty -> Int++class (Typeable c, Typeable (ClkReset c)) => Clock c where+	type ClkReset c+	-- |Provide construction of clock value to carry around.+	clockValue :: c+	-- |Reset sensitivity.+	clockResetPositive :: c -> Bool+	-- |Front sensitivity.+	clockFrontEdge :: c -> Bool++changeDotsToUnderscores :: Typeable t => t -> String+changeDotsToUnderscores = map (\c -> if c == '.' then '_' else c) . show . typeOf++clockName :: Clock c => c -> String+clockName c = changeDotsToUnderscores c++clockResetName :: Clock c => c -> String+clockResetName c = changeDotsToUnderscores $ clockReset c+	where+		clockReset :: Clock c => c -> ClkReset c+		clockReset _ = undefined++class ClockList l where+	clockListValue :: l+	clockListClocks :: l -> [String]+	clockListResets :: l -> [String]+instance ClockList Nil where+	clockListValue = Nil+	clockListClocks = const []+	clockListResets = const []+instance (ClockList t, Clock h) => ClockList (h :. t) where+	clockListValue = clockValue :. clockListValue+	clockListClocks (c :. cs) = nub $ clockName c : clockListClocks cs+	clockListResets (c :. cs) = nub $ clockResetName c : clockListResets cs++class (Clock c, ClockList cs) => ClockAllowed c cs+instance (Clock c, Clock c1, ClockAllowed c cs) => ClockAllowed c (c1 :. cs)+instance (Clock c, ClockList (c :. cs)) => ClockAllowed c (c :. cs)++class (ClockList clockSubset, ClockList clockSet) => ClockSubset clockSubset clockSet+instance ClockList clockSet => ClockSubset Nil clockSet+instance (Clock c, ClockAllowed c clockSet, ClockSubset css clockSet, ClockList clockSet) => ClockSubset (c :. css) clockSet++wireClock :: Clock c => Wire c a -> c+wireClock w = clockValue++-- |Basic netlist operations.+data NetlistOp domain where+ 	-- Latching wires. First comes default+	Register :: (ClockAllowed c clocks, BitRepr a, Show a) =>+		a -> Wire c a -> Wire c a -> NetlistOp clocks+++	-- Assign dest what+	-- dest <= what;+	Assign :: BitRepr ty => Wire c ty -> Wire c ty -> NetlistOp clocks++	-- Instance ent+	-- entity ent port map (...);+	Instance :: (Instantiable entity, HDLSignals ins, HDLSignals outs+		, EntityIns entity ~ ins, EntityOuts entity ~ outs) => +		entity -> ins -> outs -> NetlistOp clocks++-- |Netlist type.+data Netlist clocks = Netlist { netlistOperations :: [NetlistOp clocks] }++-- |State of netlist construction monad.+data NLMS domain = NLMS {+	  nlmsNetlist	:: Netlist domain+	, nlmsCounter	:: Int+	}+emptyNLMS :: NLMS clocked+emptyNLMS = NLMS (Netlist []) 0++type NLM clocked a = State (NLMS clocked) a++mkWire :: BitRepr a => Maybe String -> NLM clocked (Wire c a)+mkWire name = do+	n <- liftM nlmsCounter get+	modify $ \nlms -> nlms { nlmsCounter = n+1 }+	return $ Wire name n++tempWire :: BitRepr a => NLM clocked (Wire c a)+tempWire = mkWire Nothing++constant :: (BitRepr a, Show a) => a -> Wire c a+constant c = Expr $ OpConst c++class (ClockList (EntityClocks entity)+	, HDLSignals (EntityIns entity)+	, HDLSignals (EntityOuts entity)+	, GenHDL entity) => Instantiable entity where+	type EntityClocks entity+	type EntityIns entity+	type EntityOuts entity+	getInputsOuputsClocks :: entity+		-> (EntityIns entity, EntityOuts entity, EntityClocks entity)++data Comb ins outs where+	Comb :: (HDLSignals ins, HDLSignals outs) => +		String -> Int -> ins -> outs -> Netlist Nil -> Comb ins outs++instance (HDLSignals ins+	, HDLSignals outs+	, GenHDL (Comb ins outs)) => Instantiable (Comb ins outs) where+	type EntityClocks (Comb ins outs) = Nil+	type EntityIns (Comb ins outs) = ins+	type EntityOuts (Comb ins outs) = outs+	getInputsOuputsClocks (Comb _ _ ins outs _) = (ins, outs, Nil)++runNetlistCreation :: (WiresList ins, WiresList outs, HDLSignals ins, HDLSignals outs)+	=> Maybe (WireNamesList ins, WireNamesList outs)+	-> (ins -> outs -> Netlist domain -> a) -> (ins -> NLM domain outs) -> a+runNetlistCreation names q f = mk $ do+	ins <- mkWireList (fmap fst names)+	outs <- f ins+	outs <- copyWireList (fmap snd names) outs+	return (ins,outs)+	where+		mk act = (\((ins,outs),nlms) -> q ins outs (nlmsNetlist nlms)) $+			runState act emptyNLMS++-- |Create a combinational circut with named inputs and outputs from netlist description.+mkCombNamed :: (HDLSignals ins, HDLSignals outs, WiresList ins, WiresList outs)+	=> Maybe (WireNamesList ins, WireNamesList outs) -> String -> (ins -> NLM Nil outs) -> Comb ins outs+mkCombNamed names n f = runNetlistCreation names (createUniqueIndex Comb n) f++-- |Create a combinational circut anonymous inputs and outputs from netlist description.+mkComb :: (HDLSignals ins, HDLSignals outs, WiresList ins, WiresList outs)+	=> String -> (ins -> NLM Nil outs) -> Comb ins outs+mkComb n f = mkCombNamed Nothing n f++-- |Create a combinational circuit from pure function.+-- You can easily shoot your foot here by creating cyclic expressions like+-- 'f a = y where { x = a+y; y = x-a}.+-- Use with care.+mkCombPure :: (HDLSignals ins, HDLSignals outs, WiresList ins, WiresList outs) => String -> (ins -> outs) -> Comb ins outs+mkCombPure n f = mkComb n (\ins -> return (f ins))++data Clocked clks ins outs where+	Clocked :: (HDLSignals ins, HDLSignals outs, ClockList clks) =>+		clks -> String -> Int -> ins -> outs -> Netlist clks -> Clocked clks ins outs++instance (ClockList clks+	, HDLSignals ins+	, HDLSignals outs+	, GenHDL (Clocked clks ins outs)) => Instantiable (Clocked clks ins outs) where+	type EntityClocks (Clocked clks ins outs) = clks+	type EntityIns (Clocked clks ins outs) = ins+	type EntityOuts (Clocked clks ins outs) = outs+	getInputsOuputsClocks (Clocked clks _ _ ins outs _) = (ins, outs, clks)++mkClockedNamed :: (ClockList clks, WiresList ins, WiresList outs, HDLSignals ins, HDLSignals outs)+	=> Maybe (WireNamesList ins, WireNamesList outs) -> String+	-> (ins -> NLM clks outs) -> Clocked clks ins outs+mkClockedNamed names n f = runNetlistCreation names (createUniqueIndex (Clocked clockListValue) n) f++mkClocked :: (ClockList clks, WiresList ins, WiresList outs, HDLSignals ins, HDLSignals outs)+	=> String -> (ins -> NLM clks outs) -> Clocked clks ins outs+mkClocked n f = mkClockedNamed Nothing n f++data Mealy clk ins outs where+	Mealy :: (HDLSignals ins, HDLSignals outs, Clock clk) =>+		clk -> String -> Int -> ins -> outs -> Netlist (clk :. Nil) -> Mealy clk ins outs++instance (Clock clk+	, HDLSignals ins+	, HDLSignals outs+	, GenHDL (Mealy clk ins outs)) => Instantiable (Mealy clk ins outs) where+	type EntityClocks (Mealy clk ins outs) = clk :. Nil+	type EntityIns (Mealy clk ins outs) = ins+	type EntityOuts (Mealy clk ins outs) = outs+	getInputsOuputsClocks (Mealy clk _ _ ins outs _) = (ins, outs, clk :. Nil)++mkMealyNamed :: (Clock clk, WiresList state, HDLSignals state, WiresList ins, WiresList outs, HDLSignals ins, HDLSignals outs, RegisterWiresList state (clk :. Nil))+	=> Maybe (WireNamesList ins, WireNamesList outs)+	-> RegisterDefault state -> String -> (state -> ins -> NLM (clk :. Nil) (state, outs))+	-> Mealy clk ins outs+mkMealyNamed names defs n f = runNetlistCreation names (createUniqueIndex (Mealy clockValue) n) action+	where+		action ins = do+			rec+				state <- registerWiresList defs nextState+				~(nextState, outs) <- f state ins+			return outs+mkMealy:: (Clock clk, WiresList state, HDLSignals state, WiresList ins, WiresList outs, HDLSignals ins, HDLSignals outs, RegisterWiresList state (clk :. Nil))+	=> RegisterDefault state -> String -> (state -> ins -> NLM (clk :. Nil) (state, outs))+	-> Mealy clk ins outs+mkMealy defs n f = mkMealyNamed Nothing defs n f++-------------------------------------------------------------------------------+-- BitRepr instances.++instance BitRepr Int where+	type BitVectorSize Int = $(tySize 32)+	toBitVector x = convertThroughInteger x+	fromBitVector x = convertThroughInteger x+	bitVectorSize x = 32++instance BitRepr Word8 where+	type BitVectorSize Word8 = $(tySize 8)+	toBitVector x = convertThroughInteger x+	fromBitVector x = convertThroughInteger x+	bitVectorSize x = 8++instance BitRepr Nil where+	type BitVectorSize Nil = $(tySize 0)+	toBitVector x = 0+	fromBitVector x = Nil+	bitVectorSize x = 0++instance (BitRepr a, BitRepr as+	, Nat (Plus (BitVectorSize a) (BitVectorSize as)))+	=> BitRepr (a :. as) where+	type BitVectorSize (a :. as) = Plus (BitVectorSize a) (BitVectorSize as)+	toBitVector (a :. as) = B.shiftL (toBitVector a) (bitVectorSize as)+		B..|. toBitVector as+	fromBitVector x = a :. as+		where+			mask :: BitRepr a => a -> Integer+			mask x = B.shiftL (1 :: Integer) (bitVectorSize x) - 1+			ys = x B..&. mask as+			y = B.shiftR x (bitVectorSize as) B..&. mask a+			a = fromBitVector y+			as = fromBitVector ys+	bitVectorSize (a :. as) = bitVectorSize a + bitVectorSize as++instance BitRepr () where+	type BitVectorSize () = $(tySize 0)+	toBitVector = const 0+	fromBitVector = const ()++-------------------------------------------------------------------------------+-- Dumping HDL.++data HDLGenState = HDLGenState {+	-- errors, if we encounter any.+	  hdlgErrors		:: [String]+	-- Mapping from entities to their "real" names.+	, hdlgGeneratedEntities	:: Map.Map (String, Int) String+	-- how deep we recurred?+	, hdlgRecursionLevel	:: Int+	-- lines of generated text. In reverse order.+	, hdlgTextLines		:: [String]+	-- nesting level.+	, hdlgNestLevel		:: Int+	-- what kind of language we generate.+	, hdlgLanguage		:: HDL+	-- set of defined names.+	, hdlgDefinedNames	:: Set.Set String+	}+	deriving (Prelude.Eq, Prelude.Ord, Show)+type HDLGen a = State HDLGenState a++emptyHDLGenState hdl = HDLGenState {+	  hdlgErrors		= []+	, hdlgGeneratedEntities	= Map.empty+	, hdlgRecursionLevel	= 0+	, hdlgTextLines		= []+	, hdlgNestLevel		= 0+	, hdlgLanguage		= hdl+	, hdlgDefinedNames	= Set.empty+	}++runHDLGeneration :: GenHDL a => HDL -> a -> (String, [String])+runHDLGeneration hdl entity = (text, errors)+	where+		errors = hdlgErrors state+		text = unlines $ reverse $ hdlgTextLines state+		(_,state) = runState (generateHDL entity) (emptyHDLGenState hdl)++generateLine :: String -> HDLGen ()+generateLine s = modify $ \hdlg -> hdlg {+		  hdlgTextLines = (replicate (hdlgNestLevel hdlg) ' '++s) : hdlgTextLines hdlg+		}++generateEmptyLines :: Int -> HDLGen ()+generateEmptyLines n = modify $ \hdlg -> hdlg {+		  hdlgTextLines = (replicate n "") ++ hdlgTextLines hdlg+		}++generateNest :: HDLGen a -> HDLGen a+generateNest act = do+	nest <- liftM hdlgNestLevel get+	modify $ \hdlg -> hdlg { hdlgNestLevel = nest + 4 }+	x <- act+	modify $ \hdlg -> hdlg { hdlgNestLevel = nest }+	return x++generateDashes :: HDLGen ()+generateDashes = modify $ \hdlg -> hdlg {+		  hdlgTextLines = dashesLine (hdlgLanguage hdlg) (hdlgNestLevel hdlg)+			 : hdlgTextLines hdlg+		}+	where+		dashesLine hdl n = concat [replicate n ' ',prefix hdl, replicate (79-n-2) '-']+		prefix hdl = case hdl of+			VHDL -> "--"+			Verilog -> "//"++generateError :: String -> HDLGen ()+generateError err = modify $ \hdlg -> hdlg { hdlgErrors = err : hdlgErrors hdlg}++generateComment :: String -> HDLGen ()+generateComment c = do+	hdl <- liftM hdlgLanguage get+	let commentPrefix = case hdl of+		VHDL -> "--"+		Verilog -> "//"+	generateLine $ unwords [commentPrefix,c]++generateDashesComment :: String -> HDLGen ()+generateDashesComment c = do+	generateDashes+	generateComment c++generateDefineName :: String -> HDLGen ()+generateDefineName name = modify $ \hdlg -> hdlg {+	  hdlgDefinedNames = Set.insert name $ hdlgDefinedNames hdlg+	}++generateFilterDefined :: [a] -> (a -> String) -> HDLGen [a]+generateFilterDefined things nameProjection = do+	defined <- liftM hdlgDefinedNames get+	let things' = filter (not . flip Set.member defined . nameProjection) things+	mapM (generateDefineName . nameProjection) things'+	return things'++class GenHDL a where+	generateHDL :: a -> HDLGen ()++names :: HDLSignals s => s -> [String]+names s = map fst $ signalsWires s+entityPortsList dir signals = (+			 map fst wiresKinds+			,map (\(name,kind) -> (name,unwords [name,":",dir,vhdlType kind])) wiresKinds)+			where+				wiresKinds = signalsWires signals+				vhdlType BitSignal = "bit"+				vhdlType (BusSignal width) =+					"unsigned ("++show (width-1)++" downto 0)"+generateHDLForEntity :: (HDLSignals ins, HDLSignals outs, ClockList clocks) =>+	String -> Int -> ins -> outs -> clocks -> Netlist domain -> HDLGen ()+generateHDLForEntity name index ins outs clocks netlist = do+	hdl <- liftM hdlgLanguage get+	n <- liftM (Map.lookup key . hdlgGeneratedEntities) get+	case n of+		Nothing -> do+			ourName <- registerOurEntity+			mapM_ subEntity $ netlistOperations netlist+			case hdl of+				VHDL -> vhdlText ourName+				Verilog -> verilogText ourName+		Just _ -> return ()+	where+		key = (name, index)+		registerOurEntity = do+			names <- liftM (Set.fromList . Map.elems . hdlgGeneratedEntities) get+			let newNames = map (name++) $+				map ('_':) $ map show [(1::Int)..]+			let ourName = head $ filter (not . (`Set.member` names)) newNames+			modify $ \hdlgs -> hdlgs { hdlgGeneratedEntities = Map.insert key ourName $ hdlgGeneratedEntities hdlgs }+			return ourName+		subEntity :: NetlistOp domain -> HDLGen ()+		subEntity (Instance entity ins outs) = do+			generateHDL entity+		subEntity _ = return ()+		generateEntityClocksResets clks = map addTypeDir $ clocks ++ resets+			where+				addTypeDir name = name ++ ": in std_logic"+				clocks = clockListClocks clks+				resets = clockListResets clks+		generateVHDLDeclarations ops' = do+			ops <- generateFilterDefined ops' fst+			forM ops $ \(name, kind) -> do+				let ty = case kind of+					BitSignal -> "bit"+					BusSignal n -> "unsigned ("++show (n-1)++" downto 0)"+				generateLine $ concat ["signal ", name, " : ", ty,";"]+			return ()+		declareOperationSignals :: NetlistOp domain -> HDLGen ()+		declareOperationSignals op = generateVHDLDeclarations $ case op of+			Register _ wa wb -> signalsWires $ wa :. Nil+			Assign wa op -> signalsWires $ wa :. Nil+			Instance entity ins outs -> signalsWires outs+		vhdlOperation :: NetlistOp domain -> HDLGen ()+		vhdlOperation op = case op of+			Register def wa wb -> do+				let c = wireClock wa+				let cn = clockName c+				let edge = (if clockFrontEdge c then "rising_edge" else "falling_edge")+					++"("++cn++")"+				let rn = clockResetName c+				let resetFunc = +					rn ++ " = "+					++ (if clockResetPositive c then "'1'" else "'0'")+				generateLine $ "process ("++cn++", "++rn++") is"+				generateLine $ "begin"+				generateNest $ do+					generateLine $ unwords ["if",resetFunc, "then"]+					generateNest $ vhdlOperation (Assign wa (constant def))+					generateLine $ unwords ["elsif",edge, "then"]+					generateNest $ vhdlOperation (Assign wa wb)+					generateLine "end if;"+				generateLine $ "end process;"+			Assign wa op -> do+				generateLine $ concat+					[signalName wa, " <= "+					,opToHDL VHDL op, ";"]+			Instance entity ins outs -> do+				let (eins, eouts, eclks) = getInputsOuputsClocks entity+				let insNames = names ins+				let outsNames = names outs+				let einsNames = names eins+				let eoutsNames = names eouts+				let clocks = nub $ clockListClocks eclks+				let resets = nub $ clockListResets eclks+				let connect a b = a ++" => " ++ b+				let allNames = zipWith connect insNames einsNames+					++ zipWith connect outsNames eoutsNames+					++ map (\c -> connect c c) clocks+					++ map (\c -> connect c c) resets+				let withCommas = zipWith (++) ("  ":repeat ", ") allNames+				generateLine "entity ("+				generateNest $ mapM generateLine withCommas+				generateLine ");"+		vhdlText name = do+			generateEmptyLines 2+			generateDashesComment $ "Entity declaration and architecture for "++name++"."+			generateEmptyLines 1+			generateLine "library ieee;"+			generateLine "use ieee.std_logic_1164.all;"+			generateLine "use ieee.numeric_bit.all;"+			generateEmptyLines 1+			generateLine $ "entity "++name++" is"+			generateNest $ do+				generateLine "port ("+				let (inputsNames,inputs) =+					entityPortsList "in" ins+				let (outputsNames, outputs) =+					entityPortsList "out" outs+				let clockResets = generateEntityClocksResets clocks+				let inouts = inputs ++ outputs+				let allSignals = (map snd inouts) ++ clockResets+				let signals = reverse $+					zipWith (++) (reverse allSignals) ("" : repeat ";")+				mapM generateDefineName $ map fst inouts+				generateNest $ do+					mapM generateLine signals+				generateLine ");"+				return $ inputsNames ++ outputsNames+			generateLine $ "end entity "++name++";"+			generateEmptyLines 2+			generateLine $ "architecture hhdl_generated of "++name++" is"+			generateNest $ do+				addSupportFunctions+				mapM declareOperationSignals $ netlistOperations netlist+			generateLine $ "begin"+			generateNest $ do+				mapM vhdlOperation $ netlistOperations netlist+			generateLine $ "end architecture hhdl_generated;"+			return ()++		verilogText name = do+			generateLine $ "Verilog text for entity "++name++		addSupportFunctions = mapM generateLine [+			  replicate 60 '-'+			, "-- Supporting functions."+			, ""+			, "pure function select_func(s : in bit; t, f : in bit) return bit is"+			, "begin"+			, "    if s = '1' then"+			, "        return t;"+			, "    else"+			, "        return f;"+			, "    end if;"+			, "end function select_func;"+			, ""+			, "pure function select_func(s : in bit; t, f : in unsigned) return unsigned is"+			, "begin"+			, "    if s = '1' then"+			, "        return t;"+			, "    else"+			, "        return f;"+			, "    end if;"+			, "end function select_func;"+			, ""+			, "pure function bit_equality(a, b : in bit) return bit is"+			, "begin"+			, "    if a = b then"+			, "        return '1';"+			, "    else"+			, "        return '0';"+			, "    end if;"+			, "end function bit_equality;"+			, ""+			, "pure function bit_equality(a, b : in unsigned) return bit is"+			, "begin"+			, "    if a = b then"+			, "        return '1';"+			, "    else"+			, "        return '0';"+			, "    end if;"+			, "end function bit_equality;"+			, ""+			]++instance GenHDL (Comb ins outs) where+	generateHDL (Comb name index ins outs netlist) = do+		generateHDLForEntity name index ins outs Nil netlist++instance GenHDL (Clocked cs ins outs) where+	generateHDL (Clocked clocks name index ins outs netlist) = do+		generateHDLForEntity name index ins outs clocks netlist++instance GenHDL (Mealy c ins outs) where+	generateHDL (Mealy c name index ins outs netlist) = do+		generateHDLForEntity name index ins outs (c :. Nil) netlist++writeHDLText :: GenHDL a => HDL -> a -> (String -> IO ()) -> IO ()+writeHDLText hdl entity write = do+	let (text, errors) = runHDLGeneration hdl entity+	write text+	case errors of+		[] -> return ()+		errs -> do+			putStrLn $ "\n\n\nErrors:"+			mapM putStrLn errs+			putStrLn "------------------"+			putStrLn $ "Total " ++ show (length errs) ++ " errors in HDL generation."++-------------------------------------------------------------------------------+-- Bit vectors.++data BV size = BV Integer++instance Nat size => BitRepr (BV size) where+	type BitVectorSize (BV size) = size+	toBitVector (BV i) = i+	fromBitVector i = r+		where+			r = BV (i B..&. bitMask r)++instance Nat size => IntegerConstant (BV size) where+	fromInteger i = fromBitVector i++instance Show (BV size) where+	showsPrec n (BV i) = (concat [o,Text.Printf.printf "BV 0x%x" i,c]++)+		where+			(o,c)+				| n > 10 = ("(",")")+				| otherwise = ("","")++instance Nat size => Eq (BV size) where+	type EqResult (BV size) = Bool+	a == b = toBitVector a == toBitVector b+	a /= b = toBitVector a /= toBitVector b++_toSelBusSizeBitVector :: AlgTypeBitEnc a => a -> BV (SelectorBusSize a)+_toSelBusSizeBitVector = undefined++_toSelBusSizeBitVectorWireExpr :: AlgTypeBitEnc a => Wire c a -> BV (SelectorBusSize a)+_toSelBusSizeBitVectorWireExpr = undefined++_toArgsBusSizeBitVector :: AlgTypeBitEnc a => Wire c a -> Wire c (BV (ArgsBusSize a))+_toArgsBusSizeBitVector = undefined++-------------------------------------------------------------------------------+-- Netlist operations.++addNetlistOperation op =+	modify $ \nlms -> nlms {+	  nlmsNetlist = Netlist $ op : netlistOperations (nlmsNetlist nlms)+	}+register :: (ClockAllowed c clocks, BitRepr a, Show a) => a -> Wire c a -> NLM clocks (Wire c a)+register resetValue computedValue = do+	w <- tempWire+	modify $ \nlms -> nlms {+		  nlmsNetlist = Netlist (Register resetValue w computedValue : netlistOperations (nlmsNetlist nlms))+		}+	return w++instantiate :: (Instantiable entity, ClockSubset (EntityClocks entity) clocks+	, WiresList (EntityIns entity), WiresList (EntityOuts entity)) =>+	entity -> EntityIns entity -> NLM clocks (EntityOuts entity)+instantiate entity ins = do+	outs <- mkWireList Nothing+	addNetlistOperation $ Instance entity ins outs+	return outs++assignWire :: (BitRepr ty) => Wire c ty -> NLM registers (Wire c ty)+assignWire what = do+	assignFlattened what++assignWithForcedCopy n wire = do+	t <- mkWire n+	addNetlistOperation $ Assign t wire+	return t++assignFlattened :: (BitRepr ty) => Wire c ty -> NLM registers (Wire c ty)+assignFlattened w@(Wire _ _) = return w+assignFlattened (Expr op) = do+	op <- opFlatten op+	assignWithForcedCopy Nothing $ Expr op++extendZero :: (Nat src, Nat dest) => Wire c (BV src) -> Wire c (BV dest)+extendZero what = Expr $ Extend False what++extendSign :: (Nat src, Nat dest) => Wire c (BV src) -> Wire c (BV dest)+extendSign what = Expr $ Extend True what++castWires :: (BitRepr src, BitRepr res, BitVectorSize src ~ BitVectorSize res) =>+	Wire c src -> Wire c res+castWires what = Expr $ CastWires what++_runPureNetlist :: NLM Nil a -> NLM clocks a+_runPureNetlist action = do+	s <- get+	let (a,s') = runState action (copyNLMS s)+	put (copyNLMSBack s' s)+	return a+	where+		copyNLMS (NLMS (Netlist netlist) cntr) = NLMS (Netlist []) cntr+		copyNLMSBack :: NLMS Nil -> NLMS clocks -> NLMS clocks+		copyNLMSBack (NLMS (Netlist ops1) cntr) (NLMS (Netlist ops2) _)+			= NLMS (Netlist $ copyOps ops1 ops2) cntr+		copyOps :: [NetlistOp Nil] -> [NetlistOp clocks] -> [NetlistOp clocks]+		copyOps [] ops2 = ops2+		copyOps (Assign to what : ops1) ops2 = copyOps ops1 (ops2++[Assign to what])+		copyOps (Instance ent ins outs  : ops1) ops2 = copyOps ops1 (ops2++[Instance ent ins outs])++-------------------------------------------------------------------------------+-- Operations for expressions.++data Extend c dest where+	-- bool flag is whether we're using sign (we are when True).+	Extend :: (Nat src, Nat res) => Bool -> Wire c (BV src) -> Extend c (BV res)++instance BitRepr res => WireOp (Extend c res) where+	type WireOpType (Extend c res) = res+	opToHDL hdl op@(Extend signExtendFlag arg)+		| widen = widenExpr+		| narrow = narrowExpr+		| otherwise = subExpr+		where+			destSize = wireOpBusSize op+			srcSize = wireOpBusSize arg+			widen = destSize > srcSize+			narrow = destSize > srcSize+			delta = destSize - srcSize+			sign = case hdl of+				VHDL -> subExpr ++"("++show (srcSize-1)++")"+				Verilog -> subExpr ++"["++show (srcSize-1)++"]"+			extension = case hdl of+				VHDL -> if signExtendFlag+						then concat $ intersperse " & " (replicate delta sign)+						else show (replicate delta '0')+				Verilog -> if signExtendFlag+						then concat $ intersperse ", " (replicate delta sign)+						else show (replicate delta '0')+			subExpr = opToHDL hdl arg+			widenExpr = case hdl of+				VHDL -> unwords [extension, subExpr]+				Verilog -> "{"++concat [extension, ", ", subExpr]++"}"+			narrowExpr = case hdl of+				VHDL -> subExpr ++"("++show (destSize-1)++" downto 0)"+	opFlatten (Extend se a) = liftM (Extend se) $ assignFlattened a++data CastWires c res where+	-- bool flag is whether we're using sign (we are when True).+	CastWires :: (BitRepr src, BitRepr res, BitVectorSize src ~ BitVectorSize res) =>+		Wire c src -> CastWires c res++instance BitRepr res => WireOp (CastWires c res) where+	type WireOpType (CastWires c res) = res+	opToHDL hdl (CastWires op) = opToHDL hdl op+	opFlatten (CastWires op) = do+		op <- assignFlattened op+		return $ CastWires op++class BitRepr (WireOpListTypes a) => WireOpList a where+	type WireOpListTypes a+--	type WireOpListClock a+	opsToHDL :: HDL -> a -> [String]+instance WireOpList Nil where+	type WireOpListTypes Nil = Nil+	opsToHDL hdl = const []+instance (WireOp x, WireOpList xs+	, Nat (Plus (BitVectorSize (WireOpType x)) (BitVectorSize (WireOpListTypes xs)))) => WireOpList (x :. xs) where+	type WireOpListTypes (x :. xs) = WireOpType x :. WireOpListTypes xs+	opsToHDL hdl (a :. as) = opToHDL hdl a : opsToHDL hdl as++data SplitWiresOp c r where+	SplitWiresOp :: BitRepr s => Wire c s -> Int -> SplitWiresOp c r++instance BitRepr r => WireOp (SplitWiresOp c r) where+	type WireOpType (SplitWiresOp c r) = r+	opToHDL hdl x@(SplitWiresOp wire ofs) = case hdl of+		VHDL+			| rSize > 1 -> unwords [subExpr, "(", show (rSize+ofs-1), "downto", show ofs, ")"]+			| otherwise -> unwords [subExpr, "(", show ofs,")"]+		Verilog -> error "Verilog SplitWiresOp!!!"+		where+			rSize = opTypeSize x+			subExpr = opToHDL hdl wire+	opFlatten (SplitWiresOp wire ofs) = liftM (\w -> SplitWiresOp w ofs) $ assignFlattened wire++type family SplitProjection c w+class BitRepr w => SplitWires w where+	splitWires :: Wire c w -> SplitProjection c w++instance (BitRepr a, BitRepr b, Nat (Plus (BitVectorSize a) (BitVectorSize b)), Nat (BitVectorSize(a,b))) => BitRepr (a,b) where+	type BitVectorSize (a,b) = Plus (BitVectorSize a) (BitVectorSize b)+	toBitVector (x0,x1) = B.shiftL (toBitVector x0) (bitVectorSize x1) B..|. toBitVector x1+	fromBitVector v = (x0,x1)+		where+			x1 = fromBitVector v+			x0 = fromBitVector (B.shiftR v (bitVectorSize x1))++type instance SplitProjection c (a,b) = (Wire c a, Wire c b)+instance (BitRepr a, BitRepr b, BitRepr (a,b)) => SplitWires (a,b) where+	splitWires wab = (wa, wb)+		where+			wa = Expr $ SplitWiresOp wab (wireBusSize wb)+			wb = Expr $ SplitWiresOp wab 0++splitWires2 :: (BitRepr a, BitRepr b, BitRepr (a,b)) => Wire clk (a,b) -> (Wire clk a, Wire clk b)+splitWires2 = splitWires++$(liftM concat $ forM [3..8] $ \n -> let+		typeNames' = map (\i -> TH.mkName ("t_"++show i)) [1..n]+		typeNames = map TH.VarT typeNames'+		ty = foldl TH.AppT (TH.TupleT n) typeNames+		clkN = TH.mkName "clk"+		clk = TH.VarT clkN+		wireTy ty = TH.ConT (TH.mkName "Wire") `TH.AppT` clk `TH.AppT` ty+		wiresTy = foldl TH.AppT (TH.TupleT n) $ map wireTy typeNames+		bitReprP ty = TH.ClassP (TH.mkName "BitRepr") [ty]+		bitVectorSizeT ty = TH.ConT (TH.mkName "BitVectorSize") `TH.AppT` ty+		commonCxt = map bitReprP typeNames+		brCxt = TH.ClassP (TH.mkName "Nat") [bitVectorSizeT ty] : commonCxt+		swCxt = bitReprP ty : commonCxt+		argNames = map (\i -> TH.mkName ("x"++show i)) [1..n]+		shiftNames = map (\i -> TH.mkName ("s"++show i)) [1..n]+		argVars = map TH.VarE argNames+		prevArgs = Prelude.scanr (:) [] argVars+		sumWidths ws = foldr (\a b -> TH.InfixE (Just a) (TH.VarE $ TH.mkName "+") (Just b)) (TH.LitE $ TH.IntegerL 0) $ map (TH.AppE (TH.VarE (TH.mkName "wireBusSize"))) ws+		def v widths = flip (TH.ValD (TH.VarP v)) [] $ TH.NormalB $+			TH.ConE (TH.mkName "Expr") `TH.AppE`+			(TH.ConE (TH.mkName "SplitWiresOp")+				`TH.AppE` vV `TH.AppE` sumWidths widths)+		defs = zipWith def argNames (tail prevArgs)+		vN = TH.mkName "v"+		vV = TH.VarE vN+		bitVecSizeTy = TH.TySynInstD (TH.mkName "BitVectorSize") [ty] $+			foldl1 (\a b -> TH.ConT (TH.mkName "Plus") `TH.AppT` a `TH.AppT` b) $ map bitVectorSizeT typeNames+		defShift Nothing def arg = TH.ValD (TH.VarP def) (TH.NormalB $ TH.LitE $ TH.IntegerL 0) []+		defShift (Just prev) def arg = TH.ValD (TH.VarP def) (TH.NormalB $ TH.InfixE (Just (TH.VarE prev)) (TH.VarE $ TH.mkName "+") (Just sz)) []+			where+				sz = TH.VarE (TH.mkName "bitVectorSize") `TH.AppE` TH.VarE arg+		shiftDefs = Prelude.zipWith3 defShift (map Just (Prelude.init shiftNames) ++ [Nothing]) shiftNames argNames+		toBVE = Prelude.foldr1 (\x y -> TH.InfixE (Just x) (TH.VarE $ TH.mkName "Data.Bits..|.") (Just y))+			$ zipWith (\x s -> TH.VarE (TH.mkName "Data.Bits.shiftL")+				`TH.AppE` (TH.VarE (TH.mkName "toBitVector") `TH.AppE` TH.VarE x)+				`TH.AppE` TH.VarE s) argNames shiftNames+		toBV = TH.FunD (TH.mkName "toBitVector")+			[TH.Clause [TH.TupP $ map TH.VarP argNames] (TH.NormalB toBVE) shiftDefs]+		fromBVEShiftDef x s pxs = [+			  TH.ValD (TH.VarP x) (TH.NormalB convertedX) []+			, TH.ValD (TH.VarP s) (TH.NormalB shiftE) []+			]+			where+				vx = TH.VarE x+				convertedX = TH.VarE (TH.mkName "fromBitVector") `TH.AppE` shiftedV+				shiftedV = TH.VarE (TH.mkName "Data.Bits.shiftR") `TH.AppE` vV `TH.AppE` TH.VarE s+				shiftE = case pxs of+					Nothing -> TH.LitE $ TH.IntegerL 0+					Just (x,s) -> TH.InfixE+						(Just $ TH.VarE (TH.mkName "bitVectorSize") `TH.AppE` TH.VarE x)+						(TH.VarE $ TH.mkName "+")+						(Just $ TH.VarE s)+		shiftArgs as = map Just (tail as) ++ [Nothing]+		fromBVEShiftDefs = concat $ zipWith3 fromBVEShiftDef argNames shiftNames (shiftArgs $ zip argNames shiftNames)+		fromBVE = TH.TupE $ map TH.VarE argNames+		fromBV = TH.FunD (TH.mkName "fromBitVector")+			[TH.Clause [TH.VarP vN] (TH.NormalB fromBVE) fromBVEShiftDefs]+		split = TH.FunD (TH.mkName "splitWires")+			[TH.Clause [TH.VarP vN] (TH.NormalB $ TH.TupE argVars) defs]+		specializedSplitN = TH.mkName $ "splitWires"++show n+		decls = [ TH.InstanceD swCxt (TH.ConT (TH.mkName "SplitWires") `TH.AppT` ty) [split]+			, TH.TySynInstD (TH.mkName "SplitProjection") [clk,ty] wiresTy+			, TH.InstanceD brCxt (TH.ConT (TH.mkName "BitRepr") `TH.AppT` ty) [bitVecSizeTy, toBV, fromBV]+			, TH.SigD specializedSplitN $ TH.ForallT (map TH.PlainTV $ clkN : typeNames') brCxt $ (TH.AppT (TH.AppT TH.ArrowT $ wireTy ty) wiresTy)+			, TH.FunD specializedSplitN [TH.Clause [] (TH.NormalB $ TH.VarE (TH.mkName "splitWires")) []]+			]+	in do+--		runIO $ mapM (putStrLn . show . ppr) decls+		return decls+ )++_castAlgTypeToPair :: (Nat (Plus (SelectorBusSize a) (ArgsBusSize a)), BitRepr a+	, Plus (SelectorBusSize a) (ArgsBusSize a) ~ BitVectorSize a, AlgTypeBitEnc a) => Wire c a -> Wire c (BV (SelectorBusSize a), BV (ArgsBusSize a))+_castAlgTypeToPair w = castWires w+_splitAlgType :: (Plus (SelectorBusSize a) (ArgsBusSize a) ~ BitVectorSize a, Nat (Plus (SelectorBusSize a) (ArgsBusSize a)), AlgTypeBitEnc a, BitRepr a) => Wire c a -> (Wire c (BV (SelectorBusSize a)), Wire c (BV (ArgsBusSize a)))+_splitAlgType w = splitWires $ _castAlgTypeToPair w+_castArgsWires :: (Nat (ArgsBusSize a), AlgTypeBitEnc a, BitRepr a, BitRepr b) => Wire c a -> Wire c (BV (ArgsBusSize a)) -> Wire c b+_castArgsWires a w = r+	where+		r = castWires (extendZero w)++data Join c w where+	Join :: (BitRepr a, BitRepr b) => Wire c a -> Wire c b -> Join c (a :. b)++instance BitRepr w => WireOp (Join c w) where+	type WireOpType (Join c w) = w+	opToHDL hdl (Join l r) = case hdl of+		VHDL -> unwords ["(",opToHDL hdl l,"&",opToHDL hdl r,")"]+		Verilog -> concat ["{",opToHDL hdl l,",",opToHDL hdl r,"}"]+	opFlatten (Join l r) = liftM2 Join (assignFlattened l) (assignFlattened r)++infixr 5 &+(&) :: (BitRepr a, BitRepr b, Nat (Plus (BitVectorSize a) (BitVectorSize b))) => Wire c a -> Wire c b -> Wire c (a :. b)+a & b = Expr $ Join a b++data Equality c w where+	-- first is the flag for equality testing, if true.+	Equality :: BitRepr w => Bool -> Wire c w -> Wire c w -> Equality c Bool++instance BitRepr w => WireOp (Equality c w) where+	type WireOpType (Equality c w) = w+	opToHDL hdl (Equality eq l r) = case hdl of+		VHDL -> concat ["bit_equality( ", opToHDL hdl l,", ", opToHDL hdl r,")"]+		Verilog -> error "Equality Verilog!!!"+		where+			op = case hdl of+				VHDL -> if eq then "=" else "/="+				Verilog -> if eq then "==" else "!="+	opFlatten (Equality eq l r) = liftM2 (Equality eq) (assignFlattened l) (assignFlattened r)++instance (Eq w, EqResult w ~ Bool, BitRepr w) => Eq (Wire c w) where+	type EqResult (Wire c w) = Wire c Bool+	a == b = Expr $ Equality True  a b+	a /= b = Expr $ Equality False a b++data Select c w where+	Select :: Wire c Bool -> Wire c a -> Wire c a -> Select c a++instance BitRepr a => WireOp (Select c a) where+	type WireOpType (Select c a) = a+	opToHDL hdl (Select c l r) = case hdl of+		VHDL -> concat["select_func(",cv, ", ", lv,", ",rv,")"]+		Verilog -> error "Verilog Select!!!"+		where+			cv = opToHDL hdl c+			lv = opToHDL hdl l+			rv = opToHDL hdl r+	opFlatten (Select c l r) = do+		c <- assignFlattened c+		l <- assignFlattened l+		r <- assignFlattened r+		return $ Select c l r++selectWires :: BitRepr a => Wire c Bool -> Wire c a -> Wire c a -> Wire c a+selectWires sel true false = Expr $ Select sel true false++-------------------------------------------------------------------------------+-- Pattern matching.+-- We hardwire (pun intended) Wire(s) into Patterns because we can match+-- only on bit vectors. And those bit vectors get transferred by Wire(s).++type family ConcatPatList a b+type instance ConcatPatList a b = ConcatWiresList (a :. b)+--type instance ConcatPatList (x :. xs) ys = x :. (ConcatPatList xs ys)++class (WiresList (ConcatWiresList a)) => WiresListConcat a where+	type ConcatWiresList a+	concatWiresList :: a -> ConcatWiresList a++instance WiresListConcat Nil where+	type ConcatWiresList Nil = Nil+	concatWiresList Nil = Nil++instance WiresList as => WiresListConcat (Nil :. as) where+	type ConcatWiresList (Nil :. as) = as+	concatWiresList (Nil :. as) = as++instance (WiresListConcat (as :. bs), WiresList (a :. ConcatWiresList (as :. bs))) => WiresListConcat ((a :. as) :. bs) where+	type ConcatWiresList ((a :. as) :. bs) = a :. ConcatWiresList (as :. bs)+	concatWiresList ((a :. as) :. bs) = a :. concatWiresList (as :. bs)++data PatMatch v r where+	PatMatch :: (Wire c v -> NLM Nil (Wire c Bool, Wire c result))+		-> PatMatch (Wire c v) (Wire c result)++data Pattern w o where+	Pattern :: {unPattern :: WiresList o => (Wire c w -> NLM Nil (o, Wire c Bool))} -> Pattern (Wire c w) o++match :: (ClockAllowed c registers, BitRepr v, BitRepr r) => Wire c v+	-> [PatMatch (Wire c v) (Wire c r)] -> NLM registers (Wire c r)+match v ms = do+	w <- assignWire v+	_runPureNetlist $ reduceMatches w ms+	where+		reduceMatches :: BitRepr r => Wire c v -> [PatMatch (Wire c v) (Wire c r)] -> NLM Nil (Wire c r)+		reduceMatches w [] = error "Empty list of pattern matches!"+		reduceMatches w [PatMatch pm] = do+			(_,r) <- pm w+			return r+		reduceMatches w pms = do+			pms' <- reduceMatchesByTwo pms+			reduceMatches w pms'+		reduceMatchesByTwo :: BitRepr r => [PatMatch (Wire c v) (Wire c r)] -> NLM Nil [PatMatch (Wire c v) (Wire c r)]+		reduceMatchesByTwo [] = return []+		reduceMatchesByTwo [pm] = return [pm]+		reduceMatchesByTwo (PatMatch pm1:PatMatch pm2:pms) = do+			let pm = PatMatch $ \v -> do+				(f1,r1) <- pm1 v+				(f2,r2) <- pm2 v+				fw <- assignWire $ f1 || f2+				sw <- assignWire $ selectWires f1 r1 r2+				return (fw, sw)+			pms' <- reduceMatchesByTwo pms+			return $ pm : pms'++infixl 8 -->+(-->) :: WiresList wires => Pattern (Wire c t) wires -> (wires -> NLM Nil (Wire c result))+	-> PatMatch (Wire c t) (Wire c result)+(Pattern p) --> f = PatMatch $ \w -> do+	(ws,flag) <- p w+	r <- f ws+	return (flag, r)++-- |Constant match.+pcst :: (Eq a, EqResult a ~ Bool, Eq (Wire c a), Show a, BitRepr a) => a -> Pattern (Wire c a) Nil+pcst c = Pattern $ \w -> return (Nil, w == constant c)++pvar :: BitRepr a => Pattern (Wire c a) (Wire c a :. Nil)+pvar = Pattern $ \w -> return (w :. Nil, constant True)++pwild :: BitRepr a => Pattern (Wire c a) Nil+pwild = Pattern $ \w -> return (Nil, constant True)++-- Pattern matching for some Prelude types.+$(reifyGenerateMakeMatch [''Maybe, ''Either, ''Bool])

@@ -0,0 +1,457 @@+{-# LANGUAGE TemplateHaskell, PatternGuards #-}++module Hardware.HHDL.TH(reifyGenerateMakeMatch, generateMakeMatches) where++import Control.Monad+import Data.List+import Language.Haskell.TH++import Hardware.HHDL.TyLeA++-------------------------------------------------------------------------------+-- Build BitRepr instance, make and pattern combinators for algebraic types.+--+-- For every constructor Cons in declarations we will build mkCons with Cons'+-- arguments wrapped into WireOps amd pCons pattern match which matches+-- constructor against Wire.++generateMakeMatches :: Q [Dec] -> Q [Dec]+generateMakeMatches decs = do+	ds <- decs+	liftM concat $ forM ds generateMakeMatch++reifyGenerateMakeMatch :: [Name] -> Q[Dec]+reifyGenerateMakeMatch names = liftM concat $ mapM checkReifyGenerate names+	where+		checkReifyGenerate n = do+			i <- reify n+			case i of+				TyConI dec -> generateMakeMatchGen dec+				_ -> error $ show n ++ " does not reify to type declaration."++logGen s = runIO $ appendFile "gen" $ s++"\n"++generateMakeMatch dec = liftM (dec:) $ generateMakeMatchGen dec++generateMakeMatchGen :: Dec -> Q [Dec]+generateMakeMatchGen d@(DataD cxt name args conses _)+	| not $ null cxt = declError "Context is not empty."+	| Nothing <- bindersAreVars = declError "Only variable args are supported."+	| Just argVars <- bindersAreVars = do+		let justTyName = mkName $ nameBase name+		ds <- forM (zip [0..] conses) (uncurry $ generateConMakeMatch justTyName argVars)+		argsBusSize <- generateArgsBusSize justTyName argVars conses+		selBusSize <- generateSelBusSize justTyName argVars conses+		bitReprIns <- generateBitRepr justTyName argVars conses+		let result = argsBusSize : selBusSize : bitReprIns ++ concat ds+		logGen $ unlines (map (show . ppr) result)+		return result+	where+		declError e = error $ unlines [+			  e+			, "", ""+			, "Declaration:"+			, show (ppr d)+			]+		bindersAreVars = mapM binderIsVar args+		binderIsVar (PlainTV  v) = return v+		binderIsVar _ = Nothing+generateMakeMatchGen d = return []++generateConMakeMatch :: Name -> [Name] -> Integer -> Con -> Q [Dec]+generateConMakeMatch dataName args selectorIndex c@(NormalC conName types) = do+	return [makeType, makeFunc, matchTypeD, matchFunc]+--	return [matchTypeD, matchFunc]+	where+		matchName = mkName $ "p"++nameBase conName+		matchFunc = FunD matchName+			[Clause argPatterns (NormalB $ ConE (mkName "Pattern") `AppE` (LamE [wP] (DoE matchStats))) []]+		wN = mkName "w"+		wP = VarP wN+		wV = VarE wN+		returnStat e = NoBindS $ VarE (mkName "return") `AppE` e+		cN = mkName "c"+		cP = VarP cN+		cV = VarE cN+		asN = mkName "as"+		asP = VarP asN+		asV = VarE asN+		conpN = mkName "conp"+		conpV = VarE conpN+		conpP = VarP conpN+		resultingCondN = mkName "resultingCond"+		resultingCondV = VarE resultingCondN+		resultingCondP = VarP resultingCondN+		argumentsWiresN = mkName "argumentsWires"+		argumentsWiresV = VarE argumentsWiresN+		argumentsWiresP = VarP argumentsWiresN+		constructorSplit = VarE (mkName "_splitAlgType") `AppE` wV+		argMatch (argPat, argWire, matchResult, matchCond) = BindS+			(TupP [VarP matchResult, VarP matchCond]) f+			where+				unpatterned = VarE (mkName "unPattern") `AppE` VarE argPat+				f = unpatterned `AppE` VarE argWire+		splitWiresN e+			| length types > 1 = VarE (mkName $ "splitWires"++show (length types))+				`AppE` e+			| length types == 1 = e+		splitAssign = case types of+			[] -> []+			[_] -> [LetS+                                [ValD (VarP $ head aws) (NormalB $ castWires $ extendZero asV) []]]+			xs -> [LetS+                                [ ValD argumentsWiresP (NormalB $ castWires $ extendZero asV) []+				, ValD (TupP $ map VarP aws) (NormalB $ splitWiresN argumentsWiresV) []]]+		consT a b = ConT (mkName ":.") `AppT` a `AppT` b+		consE a b = ConE (mkName ":.") `AppE` a `AppE` b+		nil = ConE nilN+		assignWire p e = BindS p $ VarE (mkName "assignWire") `AppE` e+		matchStats = concat [+			  [LetS [ValD (TupP [cP,asP]) (NormalB constructorSplit) []]]+			, splitAssign+			--, [BindS conpP (VarE (mkName "assignWire") `AppE` (VarE (mkName "_fixAsBoolWire") `AppE` (InfixE (Just cV) (VarE $ mkName "==") (Just $ VarE (mkName "asTypeOf") `AppE` (LitE $ IntegerL $ fromIntegral selectorIndex) `AppE` cV ))))]+			, [assignWire conpP (InfixE (Just cV) (VarE $ mkName "==") (Just $ VarE (mkName "asTypeOf") `AppE` (LitE $ IntegerL $ fromIntegral selectorIndex) `AppE` cV ))]+			, map argMatch $ zip4 argNames aws mrs mcs+			, [assignWire resultingCondP $ foldr and conpV $ map VarE mcs]+			, [returnStat $ TupE [concatWLs mrs, resultingCondV]]+			]+			where+				and a b = InfixE (Just a) (VarE $ mkName "&&") (Just b)+				concatWL a = VarE (mkName "concatWiresList") `AppE` a+				concatWLs vs = concatWL $ foldr consE nil $ map VarE mrs+		matchTypeD = SigD matchName matchType+		concatTyLists a b = ConT (mkName "ConcatPatList") `AppT` a `AppT` b+		patternT ty o = ConT (mkName "Pattern") `AppT` wireT ty `AppT` o+		wireT ty = ConT (mkName "Wire") `AppT` clkT `AppT` ty+		nilN = mkName "Nil"+		nilT = ConT nilN+		mkMatchType _ t _ [] [] = let +			in (patternT resultT nilT, nilT, [], [])+		mkMatchType n t os wss [] = let+				concatenated = add concatTyLists $ reverse $ map VarT wss+				listOfTyLists = foldr consT nilT $ reverse $ map VarT wss+			in (t $ patternT resultT $ ConT (mkName "ConcatWiresList") `AppT` listOfTyLists, concatenated, os, wss)+		mkMatchType n t os wss (ty:tys) =+			mkMatchType (n+1) t' (out:os) (out:wss) tys+			where+				t' = t . (patternT ty (VarT out) `arr`)+				arr a b = ArrowT `AppT` a `AppT` b+				out = mkName $ "o_"++show n+		baseDataTy = foldl AppT (ConT dataName) $ map VarT args+		matchType = ForallT (map PlainTV vars) (nub context) ty+			where+				bitReprInst ty = ClassP (mkName "BitRepr") [ty]+				bitVectorNatInst ty = ClassP (mkName "Nat") [bitVectorSize ty]+				wiresList c = ClassP (mkName "WiresList") [c]+				context = --wiresList cs+					{-:-} bitReprInst baseDataTy+					: bitVectorNatInst baseDataTy+					: ClassP (mkName "AlgTypeBitEnc") [baseDataTy]+					: map (wiresList . VarT) os+					++ map (bitReprInst . VarT) args+					++ map (bitVectorNatInst . VarT) args+					++ argumentsNat+					++ [resultsWiresList]+				(ty,cs,os,vs) = mkMatchType 0 id [] [] (map snd types)+				vars = nub $ tyVars ty+				tyVars (AppT a b) = tyVars a ++ tyVars b+				tyVars (VarT v) = [v]+				tyVars _ = []+		clk = mkName "c"+		clkT = VarT clk+		nameMake = mkName $ "mk"++nameBase conName+		wire = AppT (ConT $ mkName "Wire") clkT+		resultT = foldl AppT (ConT dataName) (map VarT args)+		mkTy [] = AppT wire resultT+		mkTy (t:ts) = AppT (AppT ArrowT (AppT wire (snd t))) (mkTy ts)+		typesVars = nub $ concatMap (typeVars . snd) types ++ args+		typeVars (AppT a b) = typeVars a ++ typeVars b+		typeVars (VarT v) = [v]+		typeVars _ = []+		mkCxt _   [] = []+		mkCxt brs (ty:ts) =+			bitRepr ++ mkCxt (ty:brs) ts+			where+				bitRepr+					| ty `elem` brs = []+					| not (anyVars ty) = []+					| otherwise =+						[ClassP (mkName "BitRepr") [ty]]+		anyVars (AppT a b) = anyVars a || anyVars b+		anyVars (VarT _) = True+		anyVars _ = False+		context = nub $ mkCxt [] (map VarT args ++ map snd types)++algTypeCxt+			++ sumNat (map snd types) ++ [wholeTypeNat]+			++ argumentsNat+		argumentsNat = map sumNat $ init $ tails types+			where+				sumNat ts = ClassP (mkName "Nat") [foldl1 plusT $ map (bitVectorSize . snd) ts]+		resultsWiresList = ClassP (mkName "WiresListConcat")+			[foldr consT nilT $ map (VarT . mkName) $ map (("o_"++) . show) $ zipWith const [0..] types]+		bitVectorSize ty = ConT (mkName "BitVectorSize") `AppT` ty+		natPred ty = ClassP (mkName "Nat") [ty]+		plusT a b = ConT (mkName "Plus") `AppT` a `AppT` b+		sumNat [] = []+		sumNat [ty]+			| anyVars ty = [natPred ty]+			| otherwise = []+		sumNat (ty:tys) = sumNat tys ++ thisNat ++ [sumNats]+			where+				thisNat+					| anyVars ty = [natPred $ bitVectorSize ty]+					| otherwise = []+				(t:ts) = map bitVectorSize $ (ty:tys)+				sumNats = natPred (add plusT $ t:ts)+		add f [a] = a+		add f (a:as) = f a (add f as)+		selectorBusSize ty = ConT selectorBusSizeName `AppT` ty+		argsBusSize ty = ConT (mkName "ArgsBusSize") `AppT` ty+		wholeTypeNat = natPred (foldl1 plusT $ selectorBusSize resultT : argsBusSize resultT : [])+		algTypeCxt+			| not $ null args = [ClassP (mkName "AlgTypeBitEnc") [resultT]]+			| otherwise = []+		makeType = SigD nameMake $ ForallT (map PlainTV $ clk : typesVars) context $ mkTy types+		namesWithPrefix pfx = zipWith (\i _ -> mkName $ pfx++"_"++show i) [0..] types+		argNames = namesWithPrefix "a"+		aws = namesWithPrefix "argumentWire"+		mrs = namesWithPrefix "matchResult"+		mcs = namesWithPrefix "matchCond"+		argPatterns = map VarP argNames+		argsVector = case map VarE argNames of+			[] -> VarE (mkName "constant") `AppE` LitE (IntegerL 0)+			(as) -> extendZero $ castWires $ add join as+		resultN = mkName "result"+		resultV = VarE resultN+		resultD = ValD (VarP resultN)+			(NormalB (castWires (selectorV `join` argsVectorV)))+			[]+		selectorN = mkName "selector"+		selectorV = VarE selectorN+		selectorD = ValD (VarP selectorN) (NormalB sel) []+			where+				sel = VarE (mkName "constant") `AppE` e+				e = InfixE+					(Just $ LitE (IntegerL selectorIndex))+					(VarE $ mkName "asTypeOf")+					(Just $ VarE (mkName "_toSelBusSizeBitVectorWireExpr") `AppE` resultV)+		castWires x = VarE (mkName "castWires") `AppE` x+		join a b = InfixE (Just a) (VarE $ mkName "&") (Just b)+		argsVectorN = mkName "argsVector"+		argsVectorV = VarE argsVectorN+		extendZero e = (VarE $ mkName "extendZero") `AppE` e+		argsVectorD = ValD (VarP argsVectorN) (NormalB r) []+			where+				e = argsVector+				r = InfixE (Just e) (VarE (mkName "asTypeOf"))+					(Just $ VarE (mkName "_toArgsBusSizeBitVector") `AppE` resultV)+		makeFunc = FunD nameMake+			[Clause argPatterns (NormalB resultV)+				[resultD, selectorD, argsVectorD+				]]++generateConMakeMatch dataName args selectorIndex c =+	error $ unlines ["Only normal constructors are supported!", "We're given "++show (ppr c)++"."]++bitVectorSize :: Type -> Type+bitVectorSize a = AppT (ConT $ mkName "BitVectorSize") a+tyBinary f a b = AppT (AppT (ConT $ mkName f) a) b+sizeMax a b = tyBinary "Max" a b+sizeAdd a b = tyBinary "Plus" a b++argumentsBusSize = mkName "ArgsBusSize"++data V a = T a | P (V a) (V a) | M (V a) (V a)+	deriving (Eq, Show)++opt :: Eq a => V a -> V a+opt v = snd r+	where+		r = minimumBy (\a b -> compare (fst a) (fst b)) fixedWeighted+		fixed = incrComb [v]+		fixedWeighted = map (\v -> (nops v, v)) fixed+		incrComb vs+			| length vs == length next = vs+			| otherwise = incrComb next+			where+				next = nub $ concatMap comb vs++{-+t = foldl1 M $ map (foldl1 P) $ map (map T) ts+ts = nub [+	 [1,2]		--	JALR 1.regv 2.RI+	,[3,1,1,2]	--	Ternary	3.TernaryOp 1.regv 1.regv 2.RI+	,[4,1,1]	--	Mult 4.Signed 1.regv 1.regv+	,[4,1,1]	--	Div 4.Signed 1.regv 1.regv+	,[5,1,2,6]	--	Shift 5.ShiftOp 1.regv 2.RI 6.Imm5+	--,[]		--	SysCall+	,[7,1,1]	--	Trap 7.Cond 1.regv 1.regv+	,[2]		--	MFHi 2.RI+	,[2]		--	MFLo 2.RI+	,[1]		--	JR 1.regv+	,[4,1,1,2]	--	SLT 4.Signed 1.regv 1.regv 2.RI+	,[8,1,2,9]	--	Imm16Op 8.ImmOp 1.regv 2.RI 9.Imm16+	,[10,11]	--	J 10.Link 11.Imm26+	,[12,4,1,2,9]	--	Load 12.Gran 4.Signed 1.regv 2.RI 9.Imm16+	,[2,9]		--	LUI 2.RI 9.Imm16+	,[12,1,1,9]	--	Store 12.Gran 1.regv 1.regv 9.Imm16+	,[7,10,1,1,9]	--	Branch 7.Cond 10.Link 1.regv 1.regv 9.Imm16+	]+-}+++nops (T _) = 1+nops (P a b) = nops a + nops b + 1+nops (M a b) = nops a + nops b + 1++comb (P a b) = concat [[P x y, P y x] | x <- comb a, y <- comb b]+comb (M a b)+	| a == b = comb a+comb (M (P a b) (P c d))+	| a == c = comb $ P a (M b d)+comb (M (P a b) c)+	| c == a = comb $ P a b+	| c == b = comb $ P a b+comb (M a b) = concat [[M x y, M y x] | x <- comb a, y <- comb b]+comb v = [v]++opt2 :: Eq a => [[a]] -> V a+opt2 [[a]] = T a+opt2 [as] = foldl1 P $ map T as+opt2 tss = result+	where+		inc t [] = [(1,t)]+		inc t ((c,a):cas)+			| t == a = (c+1,a) : cas+			| otherwise = (c,a) : inc t cas+		mostOccured = snd $ maximumBy (\a b -> compare (fst a) (fst b))$+			foldr inc [] $ concat tss+		(withMostOccured', withoutMostOccured) =+			partition (mostOccured `elem`) tss+		delMostOccured [] = []+		delMostOccured (x:xs)+			| x == mostOccured = xs+			| otherwise = x : delMostOccured xs+		withMostOccured = filter (not . null) $+			map delMostOccured withMostOccured'+		left = case withMostOccured of+			[] -> T mostOccured+			_ -> P (T mostOccured) $ opt2 withMostOccured+		right = opt2 withoutMostOccured+		result = case withoutMostOccured of+			[] -> left+			_ -> M left right+		+++generateArgsBusSize :: Name -> [Name] -> [Con] -> Q Dec+generateArgsBusSize dataName argVars conses = do+	case interestingConses of+		[] -> return ()+		_ -> do+			logGen $ "Starting expression: "++show v+			logGen $ "Optimized expression: "++show ov+	return result+	where+		result = TySynInstD argumentsBusSize+			[foldl AppT (ConT dataName) (map VarT argVars)] $+			newVariant+		newVariant = case interestingConses of+			[] -> tySizePure 0+			_ -> fromV ov+		oldVariant =+			case conArgsSizes of+				[] -> tySizePure 0+				cs -> foldl1 (\a b -> sizeMax a b) cs+		fromV (T t) = bitVectorSize t+		fromV (P a b) = sizeAdd (fromV a) (fromV b)+		fromV (M a b) = sizeMax (fromV a) (fromV b)+		consesArgs :: [[Type]]+		consesArgs = map conArgs conses+		conArgs (NormalC _ as) = map snd as+		conArgs c = error $ "Unsupported constructor "++show (ppr c)+		conArgsSizes = map conArgsSize interestingConses+		interestingConses = nub $ filter (not . null) consesArgs+		v = foldl1 M $ map (foldl1 P) $ map (map T) interestingConses+		ov =+			--opt v+			opt2 interestingConses+		conArgsSize [] = tySizePure 0+		conArgsSize as = foldl1 sizeAdd (map bitVectorSize as)++selectorBusSizeName = mkName "SelectorBusSize"++generateSelBusSize :: Name -> [Name] -> [Con] -> Q Dec+generateSelBusSize dataName argVars conses = do+	return result+	where+		result = TySynInstD selectorBusSizeName+			[foldl AppT (ConT dataName) (map VarT argVars)] $+			tySizePure (log2 $ length conses)++log2 0 = 0+log2 1 = 0+log2 n = 1 + log2 (div (n+1) 2)++generateBitRepr :: Name -> [Name] -> [Con] -> Q [Dec]+generateBitRepr dataName argVars conses = return [bitReprInstance, algTypeEncInstance]+	where+		bitReprName = mkName "BitRepr"+		algTypeEncName = mkName "AlgTypeBitEnc"+		bitReprInstance = InstanceD context (AppT (ConT bitReprName) dataType) decls+		algTypeEncInstance = InstanceD+			[ClassP (mkName "Nat") [AppT (ConT $ mkName "ArgsBusSize") dataType]]+			(AppT (ConT algTypeEncName) dataType)+			[]+		dataType = foldl AppT (ConT dataName) (map VarT argVars)+		decls = [bitVectorSizeInst, toBitVector, fromBitVector]+		context = natHeads++varBitRepr++[algType]+		natHeads = map (\t -> ClassP (mkName "Nat") [t])+			[bitVectorSize dataType] --, AppT (ConT $ mkName "ArgsBusSize") dataType]+		varBitRepr = map (\v -> ClassP bitReprName [VarT v]) argVars+		algType = ClassP algTypeEncName [dataType]++		nx = mkName "x"+		vx = VarE nx+                toBitVector = FunD (mkName "toBitVector") [Clause [VarP nx] (NormalB toBitVectorCase) []]+		toBitVectorCase = CaseE vx $ zipWith toBitVectorConsMatch [0..] conses+		nxi = zipWith (\i _ -> mkName $ "x_"++show i) [0..]+		nsi = zipWith (\i _ -> mkName $ "s_"++show i) [0..]+		pxi = map VarP . nxi+		vxi = map VarE . nxi+		toBitVectorConsMatch i (NormalC cn as) = Match pattern (NormalB e) []+			where+				pattern = AsP (mkName "y") (ConP (mkName $ nameBase cn) (pxi as))+				ci = LitE $ IntegerL (fromIntegral i)+				vs = vxi as+				argsVector = foldl combine (LitE $ IntegerL 0) vs+				combine acc x = r+					where+						sacc = VarE (mkName "Data.Bits.shiftL") `AppE` acc `AppE` (AppE (VarE $ mkName $ "bitVectorSize") x)+						r = InfixE (Just sacc) (VarE $ mkName "Data.Bits..|.") (Just $ VarE (mkName "toBitVector") `AppE` x)+				e = (VarE $ mkName "_combineConstructorIndexArgs") `AppE` argsVector `AppE` (VarE (mkName "algTypeArgsBusSize") `AppE` VarE (mkName "y")) `AppE` ci+                fromBitVector = FunD (mkName "fromBitVector") [Clause [VarP nx] (NormalB (VarE $ mkName "r"))+			[ValD (VarP nr) (NormalB fromBitVectorE) []]]+		nr = mkName "r"+		vr = VarE $ nr+		fromBitVectorConsMatch i (NormalC n as) =+				Match (LitP $ IntegerL (fromInteger i)) (NormalB r) decls+			where+				xs = nxi as+				ss = nsi as+				decls = snd $ foldl accShift (LitE $ IntegerL 0, []) (zip ss xs)+				accShift (p,acc) (s,x) = (VarE s,sdecl:xdecl:acc)+					where+						xdecl = ValD (VarP x)+							(NormalB $ VarE (mkName "fromBitVector") `AppE` (VarE (mkName "Data.Bits.shiftR") `AppE` vx `AppE` p))+							[]+						sdecl = ValD (VarP s)+							(NormalB $ InfixE (Just p) (VarE $ mkName "+") (Just $ VarE (mkName "bitVectorSize") `AppE` VarE x))+							[]+				r = foldr (flip AppE) (ConE $ mkName $ nameBase n) (map VarE xs)+		fromBitVectorE = CaseE sel $ zipWith fromBitVectorConsMatch [0..] conses+			where+				sel = InfixE (Just shifted) (VarE $ mkName "Data.Bits..&.") (Just $ VarE (mkName "algTypeSelectorBusMask") `AppE` vr)+				shifted = (VarE $ mkName "Data.Bits.shiftR") `AppE` vx `AppE` (VarE (mkName "algTypeArgsBusSize") `AppE` vr)+		bitVectorSizeInst = TySynInstD (mkName "BitVectorSize") [dataType]+			(sizeAdd (AppT (ConT selectorBusSizeName) dataType)+				(AppT (ConT argumentsBusSize) dataType))

@@ -0,0 +1,113 @@+-- |ToWires.hs+--+-- A class that converts between Haskell types and bit vectors (Integer)+-- with instance for some handy types.+--+-- Copyright (C) Serguey Zefirov, 2009++{-# LANGUAGE TypeOperators, TemplateHaskell, TypeFamilies, FlexibleContexts, UndecidableInstances #-}++module Hardware.HHDL.ToWires where++import Data.Bits+import Data.Word++import Hardware.HHDL.TyLeA++class Nat (BusSize a) => ToWires a where+	type BusSize a+	wireSizeType :: a -> BusSize a+	wireSizeType _ = undefined+	wireSize :: a -> Int+	wireSize x = fromNat $ wireSizeType x+	wireMul :: a -> Integer+	wireMul x = Data.Bits.shiftL 1 (wireSize x)+	wireSelSize :: a -> Int+	wireSelSize = const 0+	-- Integer should occupy no more than wireSize bits, higher ones should be 0+	toWires :: a -> Integer+	-- fromWires should work with integers that have non-zero bits+	-- above wireSize index.+	fromWires :: Integer -> a+	-- enumeration size.+	-- valuesCount of (Maybe a) returns 1+valuesCount (x::a)+	-- valuesCount of Either a b returns valuesCount (x::a) + valuesCount (yLLb)+	-- valuesCount of (a,b) returns valuesCoutn (x::a) * valuesCount (y::b)+--	valuesCount :: a -> Integer+--	-- valueIndex.+--	-- get a value and return an index inside enumeration.+--	valueIndex :: a -> Integer+	-- enumerate values.+--	enumerate :: [a]++castWires :: (ToWires a, ToWires b, BusSize a ~ BusSize b) => a -> b+castWires from = to+	where+		to = fromWires $ toWires from++infixr 5 :&:	-- just like (:)+data l :&: r = l :&: r+instance (Nat (Plus (BusSize l) (BusSize r)), ToWires l, ToWires r) => ToWires (l :&: r) where+	type BusSize (l :&: r) = Plus (BusSize l) (BusSize r)+	toWires (a :&: b) = Data.Bits.shiftL (toWires a) (wireSize b) .|. toWires b+	fromWires x = a :&: b+		where+			b = fromWires x+			a = fromWires $ Data.Bits.shiftR x (wireSize b)+--	enumerate = [a :&: b | a <- enumerate, b <- enumerate]+--	valuesCount (a :&: b) = valuesCount a * valuesCount b++infixr 4 :|:	-- allows us to write a :&: b :|: c :&: d which equal to (a :&: b) :|: (c :&: d)+data l :|: r = l :|: r+instance (Nat (Max (BusSize l) (BusSize r)), ToWires l, ToWires r) => ToWires (l :|: r) where+	type BusSize (l :|: r) = Max (BusSize l) (BusSize r)+	toWires (a :|: b) = toWires a .|. toWires b+	fromWires x = a :|: b+		where+			b = fromWires x+			a = fromWires x+--	enumerate = error "no enumeration for :|:"+		-- [a :|: b | a <- enumerate, b <- enumerate]+--	valuesCount (a :|: b) = max (valuesCount a) (valuesCount b)++instance ToWires Int where+	type BusSize Int = $(tySize 32)+	toWires n = fromIntegral n .&. 0xffffffff+	fromWires x = fromIntegral x .&. 0xffffffff+--	valuesCount = const (Data.Bits.shiftL (1::Integer) 32)+--	valueIndex = fromIntegral+--	enumerate = [fromIntegral n | n <- [0..0xffffffff]]++instance ToWires Word32 where+	type BusSize Word32 = $(tySize 32)+	toWires n = fromIntegral n .&. 0xffffffff+	fromWires x = fromIntegral x .&. 0xffffffff+--	valuesCount = const (Data.Bits.shiftL (1::Integer) 32)+--	valueIndex = fromIntegral+--	enumerate = [fromIntegral n | n <- [0..0xffffffff]]++instance ToWires Word16 where+	type BusSize Word16 = $(tySize 16)+	toWires n = fromIntegral n .&. 0xffff+	fromWires x = fromIntegral x .&. 0xffff+--	valuesCount = const (Data.Bits.shiftL (1::Integer) 32)+--	valueIndex = fromIntegral+--	enumerate = [fromIntegral n | n <- [0..0xffffffff]]++instance ToWires Word8 where+	type BusSize Word8 = $(tySize 8)+	toWires n = fromIntegral n .&. 0xff+	fromWires x = fromIntegral x .&. 0xff+--	valuesCount = const (Data.Bits.shiftL (1::Integer) 32)+--	valueIndex = fromIntegral+--	enumerate = [fromIntegral n | n <- [0..0xffffffff]]++instance ToWires () where+	type BusSize () = $(tySize 0)+	toWires _ = 0+	fromWires _ = ()+--	valuesCount = const 1+--	valueIndex = fromIntegral+--	enumerate = [()]++

@@ -0,0 +1,245 @@+-- |TyLeA.hs
+--
+-- Type level decimal arithmetic.
+--
+-- Decimal numbers represented either by standalone digits (Dx)
+-- or by lists of standalone digits (D1 :. D2 :. D8), (D2 :. D4).
+--
+-- Author: Serguey Zefirov, 2011
+--
+-- I place it into public domain.
+
+{-# LANGUAGE TypeFamilies, TemplateHaskell, TypeOperators, UndecidableInstances #-}
+
+module Hardware.HHDL.TyLeA(
+	-- how to convert from types to runtime values.
+	  Nat(fromNat)
+	-- numbers construction.
+	-- numbers are either single digits or digits, separated by ":." operator.
+	, D0, D1, D2, D3, D4
+	, D5, D6, D7, D8, D9
+	, (:*)(..)
+	-- functions.
+	, Max, Plus
+	, Mul, Div2, Log2
+	-- shortcuts.
+	, tySizePure
+	, tySize	-- use it as SomeSizedType $(tySize 1024) (equal to D1 :* D0 :* D2 :* D4)
+) where
+
+import Control.Monad
+import Language.Haskell.TH
+
+data D0 = D0
+data D1 = D1
+data D2 = D2
+data D3 = D3
+data D4 = D4
+data D5 = D5
+data D6 = D6
+data D7 = D7
+data D8 = D8
+data D9 = D9
+
+infixl 5 :*
+data ds :* d = ds :* d deriving Show
+
+-------------------------------------------------------------------------------
+-- Maximum.
+
+data Equal = Equal deriving Show
+data Less = Less deriving Show
+data Greater = Greater deriving Show
+
+class Mat a where mat :: a
+instance Mat Equal where mat = Equal
+instance Mat Less where mat = Less
+instance Mat Greater where mat = Greater
+
+type family Max a b
+type instance Max a b = SelectMax (Compare a b Equal) a b
+
+type family SelectMax what a b
+type instance SelectMax Equal a b = a
+type instance SelectMax Less a b = b
+type instance SelectMax Greater a b = a
+
+type family Compare a b prevCond
+$(liftM concat $ forM [(a,b) | a <- [0..9], b <- [0..9]] $ \(a,b) -> do
+	let compareName = mkName "Compare"
+	let digit n = ConT $ mkName $ "D"++show n
+	let prevCond = VarT $ mkName "prevCond"
+	let less = ConT $ mkName "Less"
+	let greater = ConT $ mkName "Greater"
+	let da = digit a
+	let db = digit b
+	let compareDigits = TySynInstD compareName [da, db,prevCond] $ case compare a b of
+		EQ -> prevCond
+		LT -> less
+		GT -> greater
+	let va = VarT $ mkName "a"
+	let vb = VarT $ mkName "b"
+	let vc = VarT $ mkName "c"
+	let number h l = AppT (AppT (ConT $ mkName ":*") h) l
+	let compareNumberRight = TySynInstD compareName [da, number vb db, prevCond] less
+	let compareNumberLeft  = TySynInstD compareName [number va da, db, prevCond] greater
+	let compareNumbers = TySynInstD compareName [number va da, number vb db, prevCond] $ case compare a b of
+		EQ -> ConT compareName `AppT` va `AppT` vb `AppT` prevCond
+		LT -> ConT compareName `AppT` va `AppT` vb `AppT` less
+		GT -> ConT compareName `AppT` va `AppT` vb `AppT` greater
+	let r = [compareDigits, compareNumberLeft, compareNumberRight, compareNumbers]
+--	runIO $ mapM (putStrLn . show . ppr) r
+	return r
+ )
+
+-------------------------------------------------------------------------------
+-- Addition.
+
+type family Sum3 a b c
+$(liftM concat $ forM [(a,b,c) | a <- [0..9], b <- [0..9], c <- [0..1]] $ \(a,b,c) -> do
+	let sum3Name = mkName "Sum3"
+	let sum = a+b+c
+	let s = sum `mod` 10
+	let propC = sum `div` 10
+	let digit n = ConT $ mkName $ "D"++show n
+	let number h l = AppT (AppT (ConT $ mkName ":*") h) l
+	let ds = digit s
+	let digitSumResult
+		| propC == 0 = ds
+		| otherwise = number (digit propC) (ds)
+	let da = digit a
+	let db = digit b
+	let dc = digit c
+	let dPropC = digit propC
+	let va = VarT $ mkName "a"
+	let vb = VarT $ mkName "b"
+	let vc = VarT $ mkName "c"
+	let digitSum = TySynInstD sum3Name [da, db, dc] digitSumResult
+	let numberSumResult = number (ConT sum3Name `AppT` va `AppT` vb `AppT` dPropC) ds
+	let numberSum = TySynInstD sum3Name [number va da, number vb db, dc] numberSumResult
+	let add3 a b c = ConT sum3Name `AppT` a `AppT` b `AppT` c
+	let partLeftSumResult
+		| propC == 0 = number va ds
+		| otherwise = number (add3 va (digit 0) (digit 1)) ds
+	let partLeft = TySynInstD sum3Name [number va da, db, dc] partLeftSumResult
+	let partRightSumResult
+		| propC == 0 = number vb ds
+		| otherwise = number (add3 (digit 0) vb (digit 1)) ds
+	let partRight = TySynInstD sum3Name [da, number vb db, dc] partRightSumResult
+	let r = [digitSum, numberSum, partLeft, partRight]
+--	runIO $ mapM (putStrLn . show . ppr) r
+	return r
+ )
+
+type family Plus a b
+type instance Plus a b = Sum3 a b D0
+
+-------------------------------------------------------------------------------
+-- Multiplication.
+
+type family Mul a b
+type instance Mul a b = MulAcc D0 a b
+
+type family Dup a
+type instance Dup a = Plus a a
+
+type family MulAcc acc a b
+type instance MulAcc acc a D0 = acc
+type instance MulAcc acc a D1 = Plus acc a
+type instance MulAcc acc a D2 = Plus acc (Dup a)
+type instance MulAcc acc a D3 = Plus acc (Plus a (Dup a))
+type instance MulAcc acc a D4 = Plus acc (Dup (Dup a))
+type instance MulAcc acc a D5 = Plus acc (Plus (Dup (Dup a)) a)
+type instance MulAcc acc a D6 = Plus acc (Dup (Plus (Dup a) a))
+type instance MulAcc acc a D7 = Plus acc (Plus (Dup (Plus (Dup a) a)) a)
+type instance MulAcc acc a D8 = Plus acc (Dup (Dup (Dup a)))
+type instance MulAcc acc a D9 = Plus acc (Plus (Dup (Dup (Dup a))) a)
+type instance MulAcc acc a (bs :* b) = MulAcc (Mul a bs :* D0) a b
+
+
+-------------------------------------------------------------------------------
+-- Division by 2.
+
+type family Div2 a
+type instance Div2 D0 = D0
+type instance Div2 D1 = D0
+type instance Div2 D2 = D1
+type instance Div2 D3 = D1
+type instance Div2 D4 = D2
+type instance Div2 D5 = D2
+type instance Div2 D6 = D3
+type instance Div2 D7 = D3
+type instance Div2 D8 = D4
+type instance Div2 D9 = D4
+type instance Div2 (D0 :* a) = Div2 a
+type instance Div2 (D1 :* a) = Plus (Div2 a) D5
+type instance Div2 (D2 :* a) = D1 :* Div2 a
+type instance Div2 (D3 :* a) = D1 :* Plus (Div2 a) D5
+type instance Div2 (D4 :* a) = D2 :* Div2 a
+type instance Div2 (D5 :* a) = D2 :* Plus (Div2 a) D5
+type instance Div2 (D6 :* a) = D3 :* Div2 a
+type instance Div2 (D7 :* a) = D3 :* Plus (Div2 a) D5
+type instance Div2 (D8 :* a) = D4 :* Div2 a
+type instance Div2 (D9 :* a) = D4 :* Plus (Div2 a) D5
+type instance Div2 (as :* D0 :* a) = Div2 (as :* D0) :* Div2 a
+type instance Div2 (as :* D1 :* a) = Div2 (as :* D0) :* Plus (Div2 a) D5
+type instance Div2 (as :* D2 :* a) = Div2 (as :* D2) :* Div2 a
+type instance Div2 (as :* D3 :* a) = Div2 (as :* D2) :* Plus (Div2 a) D5
+type instance Div2 (as :* D4 :* a) = Div2 (as :* D4) :* Div2 a
+type instance Div2 (as :* D5 :* a) = Div2 (as :* D4) :* Plus (Div2 a) D5
+type instance Div2 (as :* D6 :* a) = Div2 (as :* D6) :* Div2 a
+type instance Div2 (as :* D7 :* a) = Div2 (as :* D6) :* Plus (Div2 a) D5
+type instance Div2 (as :* D8 :* a) = Div2 (as :* D8) :* Div2 a
+type instance Div2 (as :* D9 :* a) = Div2 (as :* D8) :* Plus (Div2 a) D5
+
+-------------------------------------------------------------------------------
+-- Base 2 logarithm.
+
+type family Log2 a
+type instance Log2 D0 = D0
+type instance Log2 D1 = D0
+type instance Log2 D2 = D1
+type instance Log2 D3 = D2
+type instance Log2 D4 = D2
+type instance Log2 D5 = D3
+type instance Log2 D6 = D3
+type instance Log2 D7 = D3
+type instance Log2 D8 = D3
+type instance Log2 D9 = D4
+type instance Log2 (as :* a) = Inc (Log2 (Div2 (Inc (as :* a))))
+
+type family Inc a
+type instance Inc a = Plus a D1
+
+-------------------------------------------------------------------------------
+-- Conversion to runtime values.
+
+class Nat a where
+	fromNat :: a -> Int
+	natMult :: a -> Int
+	natMult = const 0
+
+instance Nat D0 where { fromNat = const 0; natMult = const 1}
+instance Nat D1 where { fromNat = const 1; natMult = const 1}
+instance Nat D2 where { fromNat = const 2; natMult = const 1}
+instance Nat D3 where { fromNat = const 3; natMult = const 1}
+instance Nat D4 where { fromNat = const 4; natMult = const 1}
+instance Nat D5 where { fromNat = const 5; natMult = const 1}
+instance Nat D6 where { fromNat = const 6; natMult = const 1}
+instance Nat D7 where { fromNat = const 7; natMult = const 1}
+instance Nat D8 where { fromNat = const 8; natMult = const 1}
+instance Nat D9 where { fromNat = const 9; natMult = const 1}
+
+instance (Nat ds, Nat d) => Nat (ds :* d) where
+	fromNat ~(ds :* d) = fromNat d + fromNat ds * 10
+	natMult = const 1
+
+tySizePure :: Int -> Type
+tySizePure n = f $ show n
+	where
+		f [c] = digit c
+		f (c:cs) = AppT (AppT (ConT $ mkName ":*") $ digit c) $ f cs
+		digit c = ConT $ mkName $ ['D',c]
+
+tySize :: Int -> Q Type
+tySize = return . tySizePure