clash-prelude 0.7.1 → 0.7.2

raw patch · 29 files changed

+606/−245 lines, 29 filesdep +directorydep +doctestdep +filepathdep ~basebuild-type:Customsetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: directory, doctest, filepath, ghc-typelits-natnormalise

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• README.md +2/−0
• Setup.hs +51/−2
• clash-prelude.cabal +39/−13
• src/CLaSH/Class/BitPack.hs +4/−0
• src/CLaSH/Prelude.hs +23/−6
• src/CLaSH/Prelude/BitIndex.hs +24/−18
• src/CLaSH/Prelude/BitReduction.hs +4/−0
• src/CLaSH/Prelude/BlockRam.hs +6/−0
• src/CLaSH/Prelude/DataFlow.hs +15/−17
• src/CLaSH/Prelude/Explicit.hs +23/−15
• src/CLaSH/Prelude/Mealy.hs +28/−9
• src/CLaSH/Prelude/Testbench.hs +27/−13
• src/CLaSH/Promoted/Nat.hs +5/−3
• src/CLaSH/Promoted/Nat/TH.hs +19/−5
• src/CLaSH/Promoted/Symbol.hs +2/−0
• src/CLaSH/Signal.hs +3/−1
• src/CLaSH/Signal/Bundle.hs +1/−2
• src/CLaSH/Signal/Delayed.hs +18/−4
• src/CLaSH/Signal/Explicit.hs +23/−15
• src/CLaSH/Signal/Internal.hs +17/−9
• src/CLaSH/Sized/Fixed.hs +8/−0
• src/CLaSH/Sized/Internal/BitVector.hs +13/−5
• src/CLaSH/Sized/Internal/Index.hs +0/−3
• src/CLaSH/Sized/Internal/Signed.hs +0/−3
• src/CLaSH/Sized/Internal/Unsigned.hs +0/−3
• src/CLaSH/Sized/Vector.hs +135/−88
• src/CLaSH/Tutorial.hs +52/−11
• tests/doctests.hsc +59/−0

@@ -1,5 +1,10 @@ # Changelog for [`clash-prelude` package](http://hackage.haskell.org/package/clash-prelude) +## 0.7.2+* New features:+  * Support for GHC 7.10 => only works with GHC 7.10 and higher+  * Use http://hackage.haskell.org/package/ghc-typelits-natnormalise typechecker plugin for better type-level natural number handling+ ## 0.7.1 *March 25th 2015* * Fixes bugs:   * Fix laziness bug in Vector.(!!) and Vector.replace

@@ -1,2 +1,4 @@+[![Build Status](https://travis-ci.org/clash-lang/clash-prelude.svg?branch=master)](https://travis-ci.org/clash-lang/clash-prelude)+ = WARNING = Only works with GHC-7.8.* (http://www.haskell.org/ghc/download_ghc_7_8_3)!

@@ -1,2 +1,51 @@-import Distribution.Simple-main = defaultMain+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )+import Distribution.Text ( display )+import Distribution.Verbosity ( Verbosity, normal )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+     buildHook simpleUserHooks pkg lbi hooks flags+  , postHaddock = \args flags pkg lbi -> do+     copyFiles normal (haddockOutputDir flags pkg) []+     postHaddock simpleUserHooks args flags pkg lbi+  }++haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath+haddockOutputDir flags pkg = destDir where+  baseDir = case haddockDistPref flags of+    NoFlag -> "."+    Flag x -> x+  destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+  let dir = autogenModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir+  withLibLBI pkg lbi $ \_ libcfg -> do+    withTestLBI pkg lbi $ \suite suitecfg -> do+      rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines+        [ "module Build_" ++ testName suite ++ " where"+        , "deps :: [String]"+        , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+        ]+  where+    formatdeps = map (formatone . snd)+    formatone p = case packageName p of+      PackageName n -> n ++ "-" ++ showVersion (packageVersion p)++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys

@@ -1,5 +1,5 @@ Name:                 clash-prelude-Version:              0.7.1+Version:              0.7.2 Synopsis:             CAES Language for Synchronous Hardware - Prelude library Description:   CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -22,15 +22,15 @@   .   A preliminary version of a tutorial can be found in "CLaSH.Tutorial", for a   general overview of the library you should however check out "CLaSH.Prelude".-Homepage:             http://christiaanb.github.io/clash2/-bug-reports:          http://github.com/christiaanb/clash-prelude/issues+Homepage:             http://www.clash-lang.org/+bug-reports:          http://github.com/clash-lang/clash-prelude/issues License:              BSD2 License-file:         LICENSE Author:               Christiaan Baaij Maintainer:           Christiaan Baaij <christiaan.baaij@gmail.com> Copyright:            Copyright © 2013-2014 University of Twente Category:             Hardware-Build-type:           Simple+Build-type:           Custom  Extra-source-files:   README.md                       CHANGELOG.md@@ -43,11 +43,17 @@   type: git   location: https://github.com/clash-lang/clash-prelude.git +flag doctests+  description:+    You can disable testing with doctests using `-f-doctests`.+  default: True+  manual: True+ Library   HS-Source-Dirs:     src    default-language:   Haskell2010-  ghc-options:        -Wall -fwarn-tabs -fexpose-all-unfoldings+  ghc-options:        -Wall -fexpose-all-unfoldings    Exposed-modules:    CLaSH.Class.BitPack                       CLaSH.Class.Num@@ -88,7 +94,9 @@                        CLaSH.Tutorial -  other-extensions:   DataKinds+  other-extensions:   BangPatterns+                      DataKinds+                      ConstraintKinds                       DefaultSignatures                       DeriveDataTypeable                       FlexibleContexts@@ -97,6 +105,7 @@                       KindSignatures                       MagicHash                       MultiParamTypeClasses+                      Rank2Types                       ScopedTypeVariables                       StandaloneDeriving                       TemplateHaskell@@ -105,10 +114,27 @@                       TypeOperators                       UndecidableInstances -  Build-depends:      base                 >= 4.7.0.0 && < 5,-                      data-default         >= 0.5.3,-                      integer-gmp          >= 0.5.1.0,-                      ghc-prim             >= 0.3.1.0,-                      singletons           >= 1.0,-                      template-haskell     >= 2.9.0.0,-                      th-lift              >= 0.5.6+  Build-depends:      base                      >= 4.8.0.0 && < 5,+                      data-default              >= 0.5.3,+                      integer-gmp               >= 0.5.1.0,+                      ghc-prim                  >= 0.3.1.0,+                      ghc-typelits-natnormalise >= 0.1.1,+                      singletons                >= 1.0,+                      template-haskell          >= 2.9.0.0,+                      th-lift                   >= 0.5.6++test-suite doctests+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  main-is:          doctests.hs+  ghc-options:      -Wall+  hs-source-dirs:   tests++  if !flag(doctests)+    buildable: False+  else+    build-depends:+      base      >= 4     && < 5,+      directory >= 1.0,+      doctest   >= 0.9.1 && < 0.10,+      filepath

@@ -24,6 +24,10 @@ import CLaSH.Sized.BitVector          (BitVector, (++#), high, low) import CLaSH.Sized.Internal.BitVector (split#) +-- $setup+-- >>> :set -XDataKinds+-- >>> import CLaSH.Prelude+ -- | Convert to and from a 'BitVector' class BitPack a where   -- | Number of 'CLaSH.Sized.BitVector.Bit's needed to represents elements

@@ -85,6 +85,7 @@   , module Data.Bits   , module Data.Default     -- ** Haskell Prelude+    -- $hiding   , module Prelude   ) where@@ -126,14 +127,30 @@ import CLaSH.Signal.Delayed import CLaSH.Signal.Explicit       (systemClock) +-- $setup+-- >>> :set -XDataKinds+-- >>> let window4 = window :: Signal Int -> Vec 4 (Signal Int)+-- >>> let windowD3 = windowD :: Signal Int -> Vec 3 (Signal Int)+-- >>> let rP = registerB (8,8)++{- $hiding+"CLaSH.Prelude" re-exports most of the Haskell "Prelude" with the exception of+the following: (++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head,+init, iterate, last, length, map, repeat, replicate, reverse, scanl, scanr,+splitAt, tail, take, unzip, zip, zipWith.++It instead exports the identically named functions defined in terms of+'CLaSH.Sized.Vector.Vec' at "CLaSH.Sized.Vector".+-}+ {-# INLINE window #-} -- | Give a window over a 'Signal' -- -- > window4 :: Signal Int -> Vec 4 (Signal Int) -- > window4 = window ----- >>> simulateB window4 [1,2,3,4,5,...--- [<1,0,0,0>, <2,1,0,0>, <3,2,1,0>, <4,3,2,1>, <5,4,3,2>,...+-- >>> simulateB window4 [1::Int,2,3,4,5] :: [Vec 4 Int]+-- [<1,0,0,0>,<2,1,0,0>,<3,2,1,0>,<4,3,2,1>,<5,4,3,2>... window :: (KnownNat n, Default a)        => Signal a                -- ^ Signal to create a window over        -> Vec (n + 1) (Signal a)  -- ^ Window of at least size 1@@ -145,8 +162,8 @@ -- > windowD3 :: Signal Int -> Vec 3 (Signal Int) -- > windowD3 = windowD ----- >>> simulateB windowD3 [1,2,3,4,...--- [<0,0,0>, <1,0,0>, <2,1,0>, <3,2,1>, <4,3,2>,...+-- >>> simulateB windowD3 [1::Int,2,3,4] :: [Vec 3 Int]+-- [<0,0,0>,<1,0,0>,<2,1,0>,<3,2,1>,<4,3,2>... windowD :: (KnownNat (n + 1), Default a)         => Signal a               -- ^ Signal to create a window over         -> Vec (n + 1) (Signal a) -- ^ Window of at least size 1@@ -158,8 +175,8 @@ -- > rP :: (Signal Int,Signal Int) -> (Signal Int, Signal Int) -- > rP = registerB (8,8) ----- >>> simulateB rP [(1,1),(2,2),(3,3),...--- [(8,8),(1,1),(2,2),(3,3),...+-- >>> simulateB rP [(1,1),(2,2),(3,3)] :: [(Int,Int)]+-- [(8,8),(1,1),(2,2),(3,3)... registerB :: Bundle a => a -> Unbundled a -> Unbundled a registerB = registerB' systemClock 

@@ -1,8 +1,8 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds        #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MagicHash        #-}+{-# LANGUAGE TypeOperators    #-}+{-# LANGUAGE TypeFamilies     #-}  {-# OPTIONS_HADDOCK show-extensions #-} @@ -20,6 +20,10 @@ import CLaSH.Sized.Internal.BitVector (BitVector, Bit, index#, lsb#, msb#,                                        replaceBit#, setSlice#, slice#, split#) +-- $setup+-- >>> :set -XDataKinds+-- >>> import CLaSH.Prelude+ {-# INLINE (!) #-} -- | Get the bit at the specified bit index. --@@ -46,13 +50,14 @@ -- >>> slice (7 :: Unsigned 6) d4 d2 -- 001 -- >>> slice (7 :: Unsigned 6) d6 d4---   <interactive>---       Couldn't match type ‘7 + i0’ with ‘6’---       The type variable ‘i0’ is ambiguous---       Expected type: (6 + 1) + i0---         Actual type: BitSize (Unsigned 6)---       In the expression: slice (7 :: Unsigned 6) d6 d4---       In an equation for ‘it’: it = slice (7 :: Unsigned 6) d6 d4+-- <BLANKLINE>+-- <interactive>:...+--     Couldn't match type ‘7 + i0’ with ‘6’+--     The type variable ‘i0’ is ambiguous+--     Expected type: (6 + 1) + i0+--       Actual type: BitSize (Unsigned 6)+--     In the expression: slice (7 :: Unsigned 6) d6 d4+--     In an equation for ‘it’: it = slice (7 :: Unsigned 6) d6 d4 slice :: (BitPack a, BitSize a ~ ((m + 1) + i)) => a -> SNat m -> SNat n       -> BitVector (m + 1 - n) slice v m n = slice# (pack v) m n@@ -102,13 +107,14 @@ -- >>> pack (-29 :: Signed 6) -- 100011 -- >>> setSlice (-5 :: Signed 6) d6 d5 0---   <interactive>:25:1:---       Couldn't match type ‘7 + i0’ with ‘6’---       The type variable ‘i0’ is ambiguous---       Expected type: (6 + 1) + i0---         Actual type: BitSize (Signed 6)---       In the expression: setSlice (- 5 :: Signed 6) d6 d5 0---       In an equation for ‘it’: it = setSlice (- 5 :: Signed 6) d6 d5 0+-- <BLANKLINE>+-- <interactive>:...+--     Couldn't match type ‘7 + i0’ with ‘6’+--     The type variable ‘i0’ is ambiguous+--     Expected type: (6 + 1) + i0+--       Actual type: BitSize (Signed 6)+--     In the expression: setSlice (- 5 :: Signed 6) d6 d5 0+--     In an equation for ‘it’: it = setSlice (- 5 :: Signed 6) d6 d5 0 setSlice :: (BitPack a, BitSize a ~ ((m + 1) + i)) => a -> SNat m -> SNat n          -> BitVector (m + 1 - n) -> a setSlice v m n w = unpack (setSlice# (pack v) m n w)

@@ -15,6 +15,10 @@ import CLaSH.Class.BitPack            (BitPack (..)) import CLaSH.Sized.Internal.BitVector (Bit, reduceAnd#, reduceOr#, reduceXor#) +-- $setup+-- >>> :set -XDataKinds+-- >>> import CLaSH.Prelude+ {-# INLINE reduceAnd #-} -- | Are all bits set to '1'? --

@@ -1,6 +1,12 @@ {-# LANGUAGE DataKinds        #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators    #-}++{-|+Copyright  :  (C) 2013-2015, University of Twente+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+-} module CLaSH.Prelude.BlockRam where  import GHC.TypeLits           (KnownNat, type (^))

@@ -34,8 +34,6 @@   ) where -import Data.Functor          ((<$>))-import Control.Applicative   (Applicative (..)) import GHC.TypeLits          (KnownNat, KnownSymbol)  import CLaSH.Signal          ((.&&.), regEn, unbundle)@@ -152,8 +150,8 @@ -- -- <<doc/firstDF.svg>> firstDF :: (KnownSymbol nm, KnownNat rate)-        => DataFlow' (Clk nm rate) aEn bEn a b-        -> DataFlow' (Clk nm rate) (aEn,cEn) (bEn,cEn) (a,c) (b,c)+        => DataFlow' ('Clk nm rate) aEn bEn a b+        -> DataFlow' ('Clk nm rate) (aEn,cEn) (bEn,cEn) (a,c) (b,c) firstDF (DF f) = DF (\ac acV bcR -> let clk       = sclock                                         (a,c)     = unbundle' clk ac                                         (aV,cV)   = unbundle' clk acV@@ -169,7 +167,7 @@ -- -- <<doc/swapDF.svg>> swapDF :: (KnownSymbol nm, KnownNat rate)-       => DataFlow' (Clk nm rate) (aEn,bEn) (bEn,aEn) (a,b) (b,a)+       => DataFlow' ('Clk nm rate) (aEn,bEn) (bEn,aEn) (a,b) (b,a) swapDF = DF (\ab abV baR -> (swap <$> ab, swap <$> abV, swap <$> baR))   where     swap ~(a,b) = (b,a)@@ -179,17 +177,17 @@ -- -- <<doc/secondDF.svg>> secondDF :: (KnownSymbol nm, KnownNat rate)-         => DataFlow' (Clk nm rate) aEn bEn a b-         -> DataFlow' (Clk nm rate) (cEn,aEn) (cEn,bEn) (c,a) (c,b)+         => DataFlow' ('Clk nm rate) aEn bEn a b+         -> DataFlow' ('Clk nm rate) (cEn,aEn) (cEn,bEn) (c,a) (c,b) secondDF f = swapDF `seqDF` firstDF f `seqDF` swapDF  -- | Compose two 'DataFlow' circuits in parallel. -- -- <<doc/parDF.svg>> parDF :: (KnownSymbol nm, KnownNat rate)-      => DataFlow' (Clk nm rate) aEn bEn a b-      -> DataFlow' (Clk nm rate) cEn dEn c d-      -> DataFlow' (Clk nm rate) (aEn,cEn) (bEn,dEn) (a,c) (b,d)+      => DataFlow' ('Clk nm rate) aEn bEn a b+      -> DataFlow' ('Clk nm rate) cEn dEn c d+      -> DataFlow' ('Clk nm rate) (aEn,cEn) (bEn,dEn) (a,c) (b,d) f `parDF` g = firstDF f `seqDF` secondDF g  -- | Feed back the second halve of the communication channel.@@ -208,15 +206,15 @@ -- -- <<doc/loopDF.svg>> loopDF :: forall nm rate a b d . (KnownSymbol nm, KnownNat rate)-       => DataFlow' (Clk nm rate) Bool Bool (a,d) (b,d)-       -> DataFlow' (Clk nm rate) Bool Bool a     b+       => DataFlow' ('Clk nm rate) Bool Bool (a,d) (b,d)+       -> DataFlow' ('Clk nm rate) Bool Bool a     b loopDF f = loopDF' h   where-    h :: DataFlow' (Clk nm rate) (Bool,Bool) (Bool,Bool) (a,d) (b,d)+    h :: DataFlow' ('Clk nm rate) (Bool,Bool) (Bool,Bool) (a,d) (b,d)     h = lockStep `seqDF` f `seqDF` stepLock -    loopDF' :: DataFlow' (Clk nm rate) (Bool,Bool) (Bool,Bool) (a,d) (b,d)-            -> DataFlow' (Clk nm rate) Bool Bool   a           b+    loopDF' :: DataFlow' ('Clk nm rate) (Bool,Bool) (Bool,Bool) (a,d) (b,d)+            -> DataFlow' ('Clk nm rate) Bool Bool   a           b     loopDF' (DF f') = DF (\a aV bR -> let clk          = sclock                                           (bd,bdV,adR) = f' ad adV bdR                                           (b,d)        = unbundle' clk bd@@ -285,7 +283,7 @@   --   -- Does the right thing.   lockStep :: (KnownNat rate,KnownSymbol nm)-           => DataFlow' (Clk nm rate) a Bool b b+           => DataFlow' ('Clk nm rate) a Bool b b    -- | Extend the synchronisation granularity from a single 'Bool'ean value.   --@@ -342,7 +340,7 @@   --   -- Does the right thing.   stepLock :: (KnownNat rate,KnownSymbol nm)-           => DataFlow' (Clk nm rate) Bool a b b+           => DataFlow' ('Clk nm rate) Bool a b b  instance LockStep Bool c where   lockStep = idDF

@@ -50,6 +50,14 @@ import CLaSH.Signal.Explicit import CLaSH.Sized.Vector      (Vec (..), (+>>), asNatProxy, repeat) +-- $setup+-- >>> :set -XDataKinds+-- >>> type ClkA = Clk "A" 100+-- >>> let clkA = sclock :: SClock ClkA+-- >>> let rP = registerB' clkA (8::Int,8::Int)+-- >>> let window4 = window' clkA :: Signal' ClkA Int -> Vec 4 (Signal' ClkA Int)+-- >>> let windowD3 = windowD' clkA :: Signal' ClkA Int -> Vec 3 (Signal' ClkA Int)+ {-# INLINE registerB' #-} -- | Create a 'register' function for product-type like signals (e.g. -- @('Signal' a, 'Signal' b)@)@@ -57,15 +65,15 @@ -- @ -- type ClkA = 'Clk' \"A\" 100 ----- clkA100 :: 'SClock' ClkA--- clkA100 = 'sclock'+-- clkA :: 'SClock' ClkA+-- clkA = 'sclock' -- -- rP :: ('Signal'' ClkA Int, 'Signal'' ClkA Int) -> ('Signal'' ClkA Int, 'Signal'' ClkA Int)--- rP = 'registerB'' clkA100 (8,8)+-- rP = 'registerB'' clkA (8,8) -- @ ----- >>> simulateB' rP [(1,1),(2,2),(3,3),...--- [(8,8),(1,1),(2,2),(3,3),...+-- >>> simulateB' clkA clkA rP [(1,1),(2,2),(3,3)] :: [(Int,Int)]+-- [(8,8),(1,1),(2,2),(3,3)... registerB' :: Bundle a => SClock clk -> a -> Unbundled' clk a -> Unbundled' clk a registerB' clk i = unbundle' clk Prelude.. register' clk i Prelude.. bundle' clk @@ -75,15 +83,15 @@ -- @ -- type ClkA = 'Clk' \"A\" 100 ----- clkA100 :: 'SClock' ClkA--- clkA100 = 'sclock'+-- clkA :: 'SClock' ClkA+-- clkA = 'sclock' -- -- window4 :: 'Signal'' ClkA Int -> 'Vec' 4 ('Signal'' ClkA Int)--- window4 = 'window'' clkA100+-- window4 = 'window'' clkA -- @ ----- >>> simulateB' clkA100 clkA100 window4 [1,2,3,4,5,...--- [<1,0,0,0>, <2,1,0,0>, <3,2,1,0>, <4,3,2,1>, <5,4,3,2>,...+-- >>> simulateB' clkA clkA window4 [1::Int,2,3,4,5] :: [Vec 4 Int]+-- [<1,0,0,0>,<2,1,0,0>,<3,2,1,0>,<4,3,2,1>,<5,4,3,2>... window' :: (KnownNat n, Default a)         => SClock clk                  -- ^ Clock to which the incoming                                        -- signal is synchronized@@ -103,15 +111,15 @@ -- @ -- type ClkA = 'Clk' \"A\" 100 ----- clkA100 :: 'SClock' ClkA--- clkA100 = 'sclock'+-- clkA :: 'SClock' ClkA+-- clkA = 'sclock' -- -- windowD3 :: 'Signal'' ClkA Int -> 'Vec' 3 ('Signal'' ClkA Int)--- windowD3 = 'windowD'+-- windowD3 = 'windowD'' clkA -- @ ----- >>> simulateB' clkA100 clkA100 windowD3 [1,2,3,4,...--- [<0,0,0>, <1,0,0>, <2,1,0>, <3,2,1>, <4,3,2>,...+-- >>> simulateB' clkA clkA windowD3 [1::Int,2,3,4] :: [Vec 3 Int]+-- [<0,0,0>,<1,0,0>,<2,1,0>,<3,2,1>,<4,3,2>... windowD' :: (KnownNat (n + 1), Default a)          => SClock clk                   -- ^ Clock to which the incoming signal                                          -- is synchronized

@@ -14,12 +14,31 @@   ) where -import Control.Applicative   ((<$>), (<*>))- import CLaSH.Signal          (Signal, Unbundled) import CLaSH.Signal.Explicit (Signal', SClock, register', systemClock) import CLaSH.Signal.Bundle   (Bundle (..), Unbundled') +-- $setup+-- >>> :set -XDataKinds+-- >>> import CLaSH.Prelude+-- >>> :{+-- let mac s (x,y) = (s',s)+--       where+--         s' = x * y + s+--     topEntity = mealy mac 0+-- :}+--+-- >>> import CLaSH.Prelude.Explicit+-- >>> type ClkA = Clk "A" 100+-- >>> let clkA = sclock :: SClock ClkA+-- >>> :{+-- let mac s (x,y) = (s',s)+--       where+--         s' = x * y + s+-- :}+--+-- >>> let topEntity = mealy' clkA mac 0+ {-# INLINE mealy #-} -- | Create a synchronous function from a combinational function describing -- a mealy machine@@ -36,8 +55,8 @@ -- topEntity = 'mealy' mac 0 -- @ ----- >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4),...--- [0,1,5,14,30,...+-- >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)]+-- [0,1,5,14... -- -- Synchronous sequential functions can be composed just like their -- combinational counterpart:@@ -120,15 +139,15 @@ -- -- type ClkA = 'CLaSH.Signal.Explicit.Clk' \"A\" 100 ----- clkA100 :: 'SClock' ClkA--- clkA100 = 'CLaSH.Signal.Explicit.sclock'+-- clkA :: 'SClock' ClkA+-- clkA = 'CLaSH.Signal.Explicit.sclock' -- -- topEntity :: 'Signal'' ClkA (Int, Int) -> 'Signal'' ClkA Int--- topEntity = 'mealy'' clkA100 mac 0+-- topEntity = 'mealy'' clkA mac 0 -- @ ----- >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4),...--- [0,1,5,14,30,...+-- >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)]+-- [0,1,5,14... -- -- Synchronous sequential functions can be composed just like their -- combinational counterpart:

@@ -18,7 +18,7 @@   ) where -import Control.Applicative   ((<$>), liftA3)+import Control.Applicative   (liftA3) import Debug.Trace           (trace) import GHC.TypeLits          (KnownNat) import Prelude               hiding ((!!))@@ -29,6 +29,18 @@ import CLaSH.Sized.Index     (Index) import CLaSH.Sized.Vector    (Vec, (!!), maxIndex) +-- $setup+-- >>> :set -XTemplateHaskell+-- >>> :set -XDataKinds+-- >>> import CLaSH.Prelude+-- >>> let testInput = stimuliGenerator $(v [(1::Int),3..21])+-- >>> let expectedOutput = outputVerifier $(v ([70,99,2,3,4,5,7,8,9,10]::[Int]))+-- >>> import CLaSH.Prelude.Explicit+-- >>> type ClkA = Clk "A" 100+-- >>> let clkA = sclock :: SClock ClkA+-- >>> let testInput' = stimuliGenerator' clkA $(v [(1::Int),3..21])+-- >>> let expectedOutput' = outputVerifier' clkA $(v ([70,99,2,3,4,5,7,8,9,10]::[Int]))+ {-# INLINE stimuliGenerator #-} -- | To be used as a one of the functions to create the \"magical\" 'testInput' -- value, which the CλaSH compilers looks for to create the stimulus generator@@ -41,8 +53,8 @@ -- testInput = 'stimuliGenerator' $('CLaSH.Sized.Vector.v' [(1::Int),3..21]) -- @ ----- >>> sample testInput--- [1,3,5,7,9,11,13,15,17,19,21,21,21,...+-- >>> sampleN 13 testInput+-- [1,3,5,7,9,11,13,15,17,19,21,21,21] stimuliGenerator :: forall l a . KnownNat l                  => Vec l a  -- ^ Samples to generate                  -> Signal a -- ^ Signal of given samples@@ -60,7 +72,8 @@ -- expectedOutput = 'outputVerifier' $('CLaSH.Sized.Vector.v' ([70,99,2,3,4,5,7,8,9,10]::[Int])) -- @ ----- >>> sample (expectedOutput (fromList ([0..10] ++ [10,10,10])))+-- >>> import qualified Data.List as List+-- >>> sampleN 12 (expectedOutput (fromList ([0..10] List.++ [10,10,10]))) -- [ -- expected value: 70, not equal to actual value: 0 -- False,@@ -73,7 +86,7 @@ -- expected value: 9, not equal to actual value: 8 -- False, -- expected value: 10, not equal to actual value: 9--- False,True,True,...+-- False,True,True] outputVerifier :: forall l a . (KnownNat l, Eq a, Show a)                => Vec l a     -- ^ Samples to compare with                -> Signal a    -- ^ Signal to verify@@ -114,12 +127,12 @@ -- clkA :: 'SClock' ClkA -- clkA = 'CLaSH.Signal.Explicit.sclock' ----- testInput :: 'Signal'' clkA Int--- testInput = 'stimuliGenerator'' clkA $('CLaSH.Sized.Vector.v' [(1::Int),3..21])+-- testInput' :: 'Signal'' clkA Int+-- testInput' = 'stimuliGenerator'' clkA $('CLaSH.Sized.Vector.v' [(1::Int),3..21]) -- @ ----- >>> sample testInput--- [1,3,5,7,9,11,13,15,17,19,21,21,21,...+-- >>> sampleN 13 testInput'+-- [1,3,5,7,9,11,13,15,17,19,21,21,21] stimuliGenerator' :: forall l clk a . KnownNat l                   => SClock clk     -- ^ Clock to which to synchronize the                                     -- output signal@@ -151,11 +164,12 @@ -- clkA :: 'SClock' ClkA -- clkA = 'CLaSH.Signal.Explicit.sclock' ----- expectedOutput :: 'Signal'' ClkA Int -> 'Signal'' ClkA Bool--- expectedOutput = 'outputVerifier'' clkA $('CLaSH.Sized.Vector.v' ([70,99,2,3,4,5,7,8,9,10]::[Int]))+-- expectedOutput' :: 'Signal'' ClkA Int -> 'Signal'' ClkA Bool+-- expectedOutput' = 'outputVerifier'' clkA $('CLaSH.Sized.Vector.v' ([70,99,2,3,4,5,7,8,9,10]::[Int])) -- @ ----- >>> sample (expectedOutput (fromList ([0..10] ++ [10,10,10])))+-- >>> import qualified Data.List as List+-- >>> sampleN 12 (expectedOutput' (fromList ([0..10] List.++ [10,10,10]))) -- [ -- expected value: 70, not equal to actual value: 0 -- False,@@ -168,7 +182,7 @@ -- expected value: 9, not equal to actual value: 8 -- False, -- expected value: 10, not equal to actual value: 9--- False,True,True,...+-- False,True,True] outputVerifier' :: forall l clk a . (KnownNat l, Eq a, Show a)                 => SClock clk       -- ^ Clock to which the input signal is                                     -- synchronized to

@@ -4,6 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators       #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} {-# OPTIONS_HADDOCK show-extensions #-}  {-|@@ -42,6 +43,7 @@ withSNat f = f (SNat Proxy)  {-# INLINE snatToInteger #-}+-- | Reify the type-level 'Nat' @n@ to it's term-level 'Integer' representation. snatToInteger :: SNat n -> Integer snatToInteger (SNat p) = natVal p @@ -68,7 +70,7 @@ addUNat :: UNat n -> UNat m -> UNat (n + m) addUNat UZero     y     = y addUNat x         UZero = x-addUNat (USucc x) y     = unsafeCoerce (USucc (addUNat x y))+addUNat (USucc x) y     = USucc (addUNat x y)  -- | Multiply two singleton natural numbers --@@ -76,11 +78,11 @@ multUNat :: UNat n -> UNat m -> UNat (n * m) multUNat UZero      _     = UZero multUNat _          UZero = UZero-multUNat (USucc x) y      = unsafeCoerce (addUNat y (multUNat x y))+multUNat (USucc x) y      = addUNat y (multUNat x y)  -- | Exponential of two singleton natural numbers -- -- __NB__: Not synthesisable powUNat :: UNat n -> UNat m -> UNat (n ^ m) powUNat _ UZero     = USucc UZero-powUNat x (USucc y) = unsafeCoerce (multUNat x (powUNat x y))+powUNat x (USucc y) = multUNat x (powUNat x y)

@@ -7,18 +7,31 @@ License    :  BSD2 (see the file LICENSE) Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> -}-module CLaSH.Promoted.Nat.TH where+module CLaSH.Promoted.Nat.TH+  ( -- * Declare a single @d\<N\>@ literal+    decLiteralD+    -- * Declare ranges of @d\<N\>@ literals+  , decLiteralsD+  )+where  import Language.Haskell.TH- import CLaSH.Promoted.Nat +-- $setup+-- >>> :set -XDataKinds+-- >>> let d1111 = snat :: SNat 1111+-- >>> let d1200 = snat :: SNat 1200+-- >>> let d1201 = snat :: SNat 1201+-- >>> let d1202 = snat :: SNat 1202+ -- | Create an 'SNat' literal ----- > $(decLiteralD 1200)+-- > $(decLiteralD 1111) ----- >>> :t d1200--- d1200 :: SNat 1200+-- >>> :t d1111+-- d1111 :: SNat 1111+-- decLiteralD :: Integer             -> Q [Dec] decLiteralD n = do@@ -38,6 +51,7 @@ -- d1201 :: SNat 1201 -- >>> :t d1202 -- d1202 :: SNat 1202+-- decLiteralsD :: Integer              -> Integer              -> Q [Dec]

@@ -26,5 +26,7 @@ ssymbol = SSymbol Proxy  {-# INLINE ssymbolToString #-}+-- | Reify the type-level 'Symbol' @s@ to it's term-level 'String'+-- representation. ssymbolToString :: SSymbol s -> String ssymbolToString (SSymbol s) = symbolVal s

@@ -96,8 +96,10 @@ -- -- We get: --+-- >>> let oscillate = register False (not1 oscillate) -- >>> sampleN 8 oscillate -- [False,True,False,True,False,True,False,True]+-- >>> let count = regEn 0 oscillate (count + 1) -- >>> sampleN 8 count -- [0,0,1,1,2,2,3,3] regEn :: a -> Signal Bool -> Signal a -> Signal a@@ -143,7 +145,7 @@ -- samples of type @a@ -- -- >>> simulateB (unbundle . register (8,8) . bundle) [(1,1), (2,2), (3,3)] :: [(Int,Int)]--- [(8,8), (1,1), (2,2), (3,3),*** Exception: finite list+-- [(8,8),(1,1),(2,2),(3,3)... -- -- __NB__: This function is not synthesisable simulateB :: (Bundle a, Bundle b) => (Unbundled a -> Unbundled b) -> [a] -> [b]

@@ -18,8 +18,7 @@   ) where -import Control.Applicative   ((<$>), (<*>), liftA2)-import Data.Traversable      (sequenceA)+import Control.Applicative   (liftA2) import GHC.TypeLits          (KnownNat) import Prelude               hiding (head, map, tail) 

@@ -9,6 +9,7 @@ {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE TypeOperators              #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} {-# OPTIONS_HADDOCK show-extensions #-}  {-|@@ -36,9 +37,7 @@ import Data.Bits                  (Bits, FiniteBits) import Data.Coerce                (coerce) import Data.Default               (Default(..))-import Data.Foldable              (Foldable)-import Data.Traversable           (Traversable)-import Control.Applicative        (Applicative (..), liftA2)+import Control.Applicative        (liftA2) import GHC.TypeLits               (KnownNat, Nat, type (-)) import Language.Haskell.TH.Syntax (Lift) import Prelude                    hiding (head, length, repeat)@@ -49,6 +48,20 @@                                    singleton) import CLaSH.Signal               (Signal, fromList, register, bundle, unbundle) +-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XTypeOperators+-- >>> import CLaSH.Prelude+-- >>> let delay3 = delay (0 :> 0 :> 0 :> Nil)+-- >>> let delay2 = delayI :: DSignal (n - 2) Int -> DSignal n Int+-- >>> :{+-- let mac x y = acc+--       where+--         acc' = (x * y) + antiDelay d1 acc+--         acc  = delay (singleton 0) acc'+-- :}+--+ -- | A synchronized signal with samples of type @a@, synchronized to \"system\" -- clock (period 1000), that has accumulated @delay@ amount of samples delay -- along its path.@@ -108,13 +121,14 @@ -- delay2 = 'delayI' -- @ ----- >>> sampleN 6 (delay2 (dfromList [1..])+-- >>> sampleN 6 (delay2 (dfromList [1..])) -- [0,0,1,2,3,4] delayI :: (Default a, KnownNat m)        => DSignal (n - m) a        -> DSignal n a delayI = delay (repeat def) +{-# WARNING feedback "This function does not work in GHC 7.10.1, use 'antiDelay' instead" #-} -- | Feed the delayed result of a function back to its input: -- -- @

@@ -41,6 +41,20 @@                                regEn#, simulate) import CLaSH.Signal.Bundle    (Bundle (..), Unbundled') +-- $setup+-- >>> :set -XDataKinds+-- >>> import CLaSH.Prelude+-- >>> type Clk2 = Clk "clk2" 2+-- >>> type Clk7 = Clk "clk7" 7+-- >>> let clk2 = sclock :: SClock Clk2+-- >>> let clk7 = sclock :: SClock Clk7+-- >>> let oversampling = register' clk2 99 . unsafeSynchronizer clk7 clk2 . register' clk7 50+-- >>> let almostId = register' clk7 70 . unsafeSynchronizer clk2 clk7 . register' clk2 99 . unsafeSynchronizer clk7 clk2 . register' clk7 50+-- >>> type ClkA = Clk "A" 100+-- >>> let clkA = sclock :: SClock ClkA+-- >>> let oscillate = register' clkA False (CLaSH.Signal.not1 oscillate)+-- >>> let count = regEn' clkA 0 oscillate (count + 1)+ {- $relativeclocks #relativeclocks# CλaSH supports explicitly clocked 'CLaSH.Signal's in the form of: @@ -103,17 +117,18 @@ -- clkA = 'sclock' -- @ sclock :: (KnownSymbol name, KnownNat period)-       => SClock (Clk name period)+       => SClock ('Clk name period) sclock = SClock ssymbol snat  {-# INLINE withSClock #-}+-- | Supply a function with a singleton clock @clk@ according to the context withSClock :: (KnownSymbol name, KnownNat period)-           => (SClock (Clk name period) -> a)+           => (SClock ('Clk name period) -> a)            -> a withSClock f = f (SClock ssymbol snat)  -- | The standard system clock with a period of 1000-type SystemClock = Clk "system" 1000+type SystemClock = 'Clk "system" 1000  {-# INLINE systemClock #-} -- | The singleton clock for 'SystemClock'@@ -178,10 +193,10 @@ --              . 'register'' clk7 50 -- @ ----- >>> sample (oversampling (fromList [1..10]))--- [99, 50,1,1,1,2,2,2,2, 3,3,3,4,4,4,4, 5,5,5,6,6,6,6, 7,7,7,8,8,8,8, 9,9,9,10,10,10,10, ...--- >>> sample (almostId (fromList [1..10]))--- [70, 99,1,2,3,4,5,6,7,8,9,10,...+-- >>> sampleN 37 (oversampling (fromList [1..10]))+-- [99,50,1,1,1,2,2,2,2,3,3,3,4,4,4,4,5,5,5,6,6,6,6,7,7,7,8,8,8,8,9,9,9,10,10,10,10]+-- >>> sampleN 12 (almostId (fromList [1..10]))+-- [70,99,1,2,3,4,5,6,7,8,9,10] unsafeSynchronizer :: SClock clk1 -- ^ 'Clock' of the incoming signal                    -> SClock clk2 -- ^ 'Clock' of the outgoing signal                    -> Signal' clk1 a@@ -273,15 +288,8 @@ -- | Simulate a (@'Unbundled'' clk1 a -> 'Unbundled'' clk2 b@) function given a -- list of samples of type @a@ ----- @--- type ClkA = 'Clk' \"A\" 100------ clkA :: 'SClock' ClkA--- clkA = 'sclock'--- @--- -- >>> simulateB' clkA clkA (unbundle' clkA . register' clkA (8,8) . bundle' clkA) [(1,1), (2,2), (3,3)] :: [(Int,Int)]--- [(8,8), (1,1), (2,2), (3,3), *** Exception: finite list+-- [(8,8),(1,1),(2,2),(3,3)... -- -- __NB__: This function is not synthesisable simulateB' :: (Bundle a, Bundle b)

@@ -68,11 +68,9 @@   ) where -import Control.Applicative        (Applicative (..), (<$>), liftA2, liftA3)+import Control.Applicative        (liftA2, liftA3) import Data.Bits                  (Bits (..), FiniteBits (..)) import Data.Default               (Default (..))-import Data.Foldable              as F (Foldable (..))-import Data.Traversable           (Traversable (..)) import GHC.TypeLits               (Nat, Symbol) import Language.Haskell.TH.Syntax (Lift (..)) @@ -80,13 +78,22 @@ import CLaSH.Promoted.Nat         (SNat) import CLaSH.Promoted.Symbol      (SSymbol) +-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XMagicHash+-- >>> import CLaSH.Promoted.Nat+-- >>> import CLaSH.Promoted.Symbol+-- >>> type SystemClock = Clk "System" 1000+-- >>> type Signal a = Signal' SystemClock a+-- >>> let register = register# (SClock ssymbol snat :: SClock SystemClock)+ -- | A clock with a name ('Symbol') and period ('Nat') data Clock = Clk Symbol Nat  -- | Singleton value for a type-level 'Clock' with the given @name@ and @period@ data SClock (clk :: Clock)   where-    SClock :: SSymbol name -> SNat period -> SClock (Clk name period)+    SClock :: SSymbol name -> SNat period -> SClock ('Clk name period)  infixr 5 :- -- | A synchronized signal with samples of type @a@, explicitly synchronized to@@ -216,8 +223,9 @@ -- -- Create a constant 'CLaSH.Signal.Signal' from a combinational value ----- >>> sample (signal 4)--- [4, 4, 4, 4, ...+-- >>> import qualified Data.List as List+-- >>> List.take 5 (sample (signal 4 :: Signal Int))+-- [4,4,4,4,4] signal :: Applicative f => a -> f a signal = pure @@ -556,7 +564,7 @@ -- -- __NB__: This function is not synthesisable sample :: Foldable f => f a -> [a]-sample = F.foldr (:) []+sample = foldr (:) []  -- | The above type is a generalisation for: --@@ -592,8 +600,8 @@ -- | Simulate a (@'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' b@) function -- given a list of samples of type @a@ ----- >>> simulate (register 8) [1, 2, 3, ...--- [8, 1, 2, 3, ...+-- >>> simulate (register 8) [1, 2, 3]+-- [8,1,2,3... -- -- __NB__: This function is not synthesisable simulate :: (Signal' clk1 a -> Signal' clk2 b) -> [a] -> [b]

@@ -84,6 +84,12 @@ import CLaSH.Sized.Signed         (Signed) import CLaSH.Sized.Unsigned       (Unsigned) +-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XTemplateHaskell+-- >>> import CLaSH.Prelude+-- >>> let n = $$(fLit pi) :: SFixed 4 4+ -- | 'Fixed'-point number -- -- Where:@@ -202,10 +208,12 @@ unUF (Fixed fRep) = fRep  {-# INLINE asRepProxy #-}+-- | 'Fixed' as a 'Proxy' for it's representation type @rep@ asRepProxy :: Fixed rep int frac -> Proxy rep asRepProxy _ = Proxy  {-# INLINE asIntProxy #-}+-- | 'Fixed' as a 'Proxy' for the number of integer bits @int@ asIntProxy :: Fixed rep int frac -> Proxy int asIntProxy _ = Proxy 

@@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DeriveDataTypeable    #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE KindSignatures        #-} {-# LANGUAGE MagicHash             #-}@@ -94,7 +93,6 @@ import Data.Char                  (digitToInt) import Data.Default               (Default (..)) import Data.Maybe                 (listToMaybe)-import Data.Typeable              (Typeable) import GHC.Integer                (smallInteger) import GHC.Prim                   (dataToTag#) import GHC.TypeLits               (KnownNat, Nat, type (+), type (-), natVal)@@ -108,6 +106,10 @@ import CLaSH.Promoted.Nat         (SNat, snatToInteger) import CLaSH.Promoted.Ord         (Max) +-- $setup+-- >>> :set -XTemplateHaskell+-- >>> :set -XBinaryLiterals+ -- * Type definitions  -- | A vector of bits.@@ -118,8 +120,8 @@     -- | The constructor, 'BV', and  the field, 'unsafeToInteger', are not     -- synthesisable.     BV { unsafeToInteger :: Integer}-  deriving Typeable +-- | 'Bit': a 'BitVector' of length 1 type Bit = BitVector 1  -- * Instances@@ -139,11 +141,17 @@ -- >>> $$(bLit "1001") :: BitVector 3 -- 001 ----- __NB__: Will be removed once GHC 7.10 is released which has support for--- binary literals. Once GHC 7.10 is released you can just write:+-- __NB__: You can also just write: -- -- >>> 0b1001 :: BitVector 4 -- 1001+--+-- The advantage of 'bLit' is that you can use computations to create the+-- string literal:+--+-- >>> import qualified Data.List as List+-- >>> $$(bLit (List.replicate 4 '1')) :: BitVector 4+-- 1111 bLit :: KnownNat n => String -> Q (TExp (BitVector n)) bLit s = [|| fromInteger# i' ||]   where

@@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DeriveDataTypeable    #-} {-# LANGUAGE KindSignatures        #-} {-# LANGUAGE MagicHash             #-} {-# LANGUAGE TemplateHaskell       #-}@@ -45,7 +44,6 @@ where  import Data.Default               (Default (..))-import Data.Typeable              (Typeable) import Language.Haskell.TH        (TypeQ, appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift(..)) import GHC.TypeLits               (KnownNat, Nat, natVal)@@ -57,7 +55,6 @@     -- | The constructor, 'I', and the field, 'unsafeToInteger', are not     -- synthesisable.     I { unsafeToInteger :: Integer }-  deriving Typeable  instance Eq (Index n) where   (==) = eq#

@@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DeriveDataTypeable    #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE KindSignatures        #-} {-# LANGUAGE MagicHash             #-}@@ -79,7 +78,6 @@  import Data.Bits                      (Bits (..), FiniteBits (..)) import Data.Default                   (Default (..))-import Data.Typeable                  (Typeable) import GHC.TypeLits                   (KnownNat, Nat, type (+), natVal) import Language.Haskell.TH            (TypeQ, appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax     (Lift(..))@@ -106,7 +104,6 @@     -- | The constructor, 'S', and the field, 'unsafeToInteger', are not     -- synthesisable.     S { unsafeToInteger :: Integer}-  deriving Typeable  {-# NOINLINE size# #-} size# :: KnownNat n => Signed n -> Int

@@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE MagicHash                  #-} {-# LANGUAGE MultiParamTypeClasses      #-}@@ -73,7 +72,6 @@  import Data.Bits                      (Bits (..), FiniteBits (..)) import Data.Default                   (Default (..))-import Data.Typeable                  (Typeable) import GHC.TypeLits                   (KnownNat, Nat, type (+), natVal) import Language.Haskell.TH            (TypeQ, appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax     (Lift(..))@@ -98,7 +96,6 @@     -- | The constructor, 'U', and the field, 'unsafeToBitVector', are not     -- synthesisable.     U { unsafeToBitVector :: Integer }-  deriving Typeable  {-# NOINLINE size# #-} size# :: KnownNat n => Unsigned n -> Int

@@ -12,6 +12,7 @@ {-# LANGUAGE TypeOperators        #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} {-# OPTIONS_HADDOCK show-extensions #-} @@ -51,12 +52,10 @@   ) where -import Control.Applicative        (Applicative (..), (<$>)) import Data.Default               (Default (..)) import qualified Data.Foldable    as F import Data.Proxy                 (Proxy (..)) import Data.Singletons.Prelude    (TyFun,Apply,type ($))-import Data.Traversable           (Traversable (..)) import GHC.TypeLits               (CmpNat, KnownNat, Nat, type (+), type (*),                                    natVal) import GHC.Base                   (Int(I#),Int#,isTrue#)@@ -77,6 +76,48 @@  import CLaSH.Class.BitPack (BitPack (..)) +-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XTypeFamilies+-- >>> :set -XTypeOperators+-- >>> :set -XTemplateHaskell+-- >>> :set -XFlexibleContexts+-- >>> :set -fplugin GHC.TypeLits.Normalise+-- >>> import CLaSH.Prelude+-- >>> let compareSwapL a b = if a < b then (a,b) else (b,a)+-- >>> :{+-- let sortV xs = map fst sorted <: (snd (last sorted))+--       where+--         lefts  = head xs :> map snd (init sorted)+--         rights = tail xs+--         sorted = zipWith compareSwapL lefts rights+-- :}+--+-- >>> :{+-- let sortVL :: (Ord a, KnownNat (n+1)) => Vec (n + 2)  a -> Vec (n + 2) a+--     sortVL xs = map fst sorted <: (snd (last sorted))+--       where+--         lefts  = head xs :> map snd (init sorted)+--         rights = tail xs+--         sorted = zipWith compareSwapL (lazyV lefts) rights+-- :}+--+-- >>> :{+-- let sortV_flip xs = map fst sorted <: (snd (last sorted))+--       where+--         lefts  = head xs :> map snd (init sorted)+--         rights = tail xs+--         sorted = zipWith (flip compareSwapL) rights lefts+-- :}+--+-- >>> import Data.Singletons.Prelude+-- >>> data Append (m :: Nat) (a :: *) (f :: TyFun Nat *) :: *+-- >>> type instance Apply (Append m a) l = Vec (l + m) a+-- >>> let append' xs ys = dfold (Proxy :: Proxy (Append m a)) (const (:>)) ys xs+-- >>> let cs a b     = if a > b then (a,b) else (b,a)+-- >>> let csRow y xs = let (y',xs') = mapAccumL cs y xs in xs' <: y'+-- >>> let csSort     = vfold csRow+ -- | Fixed size vectors -- -- * Lists with their length encoded in their type@@ -86,7 +127,7 @@ -- >>> (3:>4:>5:>Nil) -- <3,4,5> -- >>> :t (3:>4:>5:>Nil)--- (3:>4:>5:>Nil) :: Num a => Vec 3 a+-- (3:>4:>5:>Nil) :: Num a => Vec (2 + 1) a data Vec :: Nat -> * -> * where   Nil  :: Vec 0 a   (:>) :: a -> Vec n a -> Vec (n + 1) a@@ -155,12 +196,13 @@ -- >>> head (1:>2:>3:>Nil) -- 1 -- >>> head Nil---   <interactive>---       Couldn't match type ‘1’ with ‘0’---       Expected type: Vec (0 + 1) a---         Actual type: Vec 0 a---       In the first argument of ‘vhead’, namely ‘Nil’---       In the expression: vhead Nil+-- <BLANKLINE>+-- <interactive>:...+--     Couldn't match type ‘1’ with ‘0’+--     Expected type: Vec (0 + 1) a+--       Actual type: Vec 0 a+--     In the first argument of ‘head’, namely ‘Nil’+--     In the expression: head Nil head :: Vec (n + 1) a -> a head (x :> _) = x @@ -170,14 +212,15 @@ -- >>> tail (1:>2:>3:>Nil) -- <2,3> -- >>> tail Nil---   <interactive>---       Couldn't match type ‘1’ with ‘0’---       Expected type: Vec (0 + 1) a---         Actual type: Vec 0 a---       In the first argument of ‘vtail’, namely ‘Nil’---       In the expression: vtail Nil+-- <BLANKLINE>+-- <interactive>:...+--     Couldn't match type ‘1’ with ‘0’+--     Expected type: Vec (0 + 1) a+--       Actual type: Vec 0 a+--     In the first argument of ‘tail’, namely ‘Nil’+--     In the expression: tail Nil tail :: Vec (n + 1) a -> Vec n a-tail (_ :> xs) = unsafeCoerce xs+tail (_ :> xs) = xs  {-# NOINLINE last #-} -- | Extract the last element of a vector@@ -185,12 +228,13 @@ -- >>> last (1:>2:>3:>Nil) -- 3 -- >>> last Nil---   <interactive>---       Couldn't match type ‘1’ with ‘0’---       Expected type: Vec (0 + 1) a---         Actual type: Vec 0 a---       In the first argument of ‘vlast’, namely ‘Nil’---       In the expression: vlast Nil+-- <BLANKLINE>+-- <interactive>:...+--     Couldn't match type ‘1’ with ‘0’+--     Expected type: Vec (0 + 1) a+--       Actual type: Vec 0 a+--     In the first argument of ‘last’, namely ‘Nil’+--     In the expression: last Nil last :: Vec (n + 1) a -> a last (x :> Nil)     = x last (_ :> y :> ys) = last (y :> ys)@@ -201,15 +245,16 @@ -- >>> init (1:>2:>3:>Nil) -- <1,2> -- >>> init Nil---   <interactive>---       Couldn't match type ‘1’ with ‘0’---       Expected type: Vec (0 + 1) a---         Actual type: Vec 0 a---       In the first argument of ‘vinit’, namely ‘Nil’---       In the expression: vinit Nil+-- <BLANKLINE>+-- <interactive>:...+--     Couldn't match type ‘1’ with ‘0’+--     Expected type: Vec (0 + 1) a+--       Actual type: Vec 0 a+--     In the first argument of ‘init’, namely ‘Nil’+--     In the expression: init Nil init :: Vec (n + 1) a -> Vec n a-init (_ :> Nil)     = unsafeCoerce Nil-init (x :> y :> ys) = unsafeCoerce (x :> init (y :> ys))+init (_ :> Nil)     = Nil+init (x :> y :> ys) = x :> init (y :> ys)  {-# INLINE shiftInAt0 #-} -- | Shift in elements to the head of a vector, bumping out elements at the@@ -219,14 +264,14 @@ -- * The shifted out elements -- -- >>> shiftInAt0 (1 :> 2 :> 3 :> 4 :> Nil) ((-1) :> 0 :> Nil)--- (<-1,0,1,2,>,<3,4>)+-- (<-1,0,1,2>,<3,4>) -- >>> shiftInAt0 (1 :> Nil) ((-1) :> 0 :> Nil) -- (<-1>,<0,1>) shiftInAt0 :: KnownNat n            => Vec n a -- ^ The old vector            -> Vec m a -- ^ The elements to shift in at the head            -> (Vec n a, Vec m a) -- ^ (The new vector, shifted out elements)-shiftInAt0 xs ys = splitAtI (unsafeCoerce zs)+shiftInAt0 xs ys = splitAtI zs   where     zs = ys ++ xs @@ -248,7 +293,7 @@ shiftInAtN xs ys = (zsR, zsL)   where     zs        = xs ++ ys-    (zsL,zsR) = splitAtI (unsafeCoerce zs)+    (zsL,zsR) = splitAtI zs  infixl 5 <: {-# INLINE (<:) #-}@@ -257,7 +302,7 @@ -- >>> (3:>4:>5:>Nil) <: 1 -- <3,4,5,1> -- >>> :t (3:>4:>5:>Nil) <: 1--- (3:>4:>5:>Nil) <: 1 :: Num a => Vec 4 a+-- (3:>4:>5:>Nil) <: 1 :: Num a => Vec (3 + 1) a (<:) :: Vec n a -> a -> Vec (n + 1) a xs <: x = xs ++ singleton x @@ -325,21 +370,21 @@ -- <1,2,3,7,8> (++) :: Vec n a -> Vec m a -> Vec (n + m) a Nil       ++ ys = ys-(x :> xs) ++ ys = unsafeCoerce (x :> (xs ++ ys))+(x :> xs) ++ ys = x :> xs ++ ys  {-# NOINLINE splitAt #-} -- | Split a vector into two vectors at the given point -- -- >>> splitAt (snat :: SNat 3) (1:>2:>3:>7:>8:>Nil)--- (<1,2,3>, <7,8>)+-- (<1,2,3>,<7,8>) -- >>> splitAt d3 (1:>2:>3:>7:>8:>Nil)--- (<1,2,3>, <7,8>)+-- (<1,2,3>,<7,8>) splitAt :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a) splitAt n xs = splitAtU (toUNat n) xs  splitAtU :: UNat m -> Vec (m + n) a -> (Vec m a, Vec n a) splitAtU UZero     ys        = (Nil,ys)-splitAtU (USucc s) (y :> ys) = let (as,bs) = splitAtU s (unsafeCoerce ys)+splitAtU (USucc s) (y :> ys) = let (as,bs) = splitAtU s ys                                in  (y :> as, bs)  {-# INLINE splitAtI #-}@@ -358,7 +403,7 @@ -- <1,2,3,4,5,6,7,8,9,10,11,12> concat :: Vec n (Vec m a) -> Vec (n * m) a concat Nil       = Nil-concat (x :> xs) = unsafeCoerce (x ++ (concat xs))+concat (x :> xs) = x ++ concat xs  {-# NOINLINE unconcat #-} -- | Split a vector of (n * m) elements into a vector of vectors with length m,@@ -371,7 +416,7 @@  unconcatU :: UNat n -> UNat m -> Vec (n * m) a -> Vec n (Vec m a) unconcatU UZero      _ _  = Nil-unconcatU (USucc n') m ys = let (as,bs) = splitAtU m (unsafeCoerce ys)+unconcatU (USucc n') m ys = let (as,bs) = splitAtU m ys                             in  as :> unconcatU n' m bs  {-# INLINE unconcatI #-}@@ -390,8 +435,7 @@ -- <1,5,2,6,3,7,4,8> merge :: Vec n a -> Vec n a -> Vec (n + n) a merge Nil       Nil       = Nil-merge (x :> xs) (y :> ys) = unsafeCoerce-                              (x :> y :> (merge xs (unsafeCoerce ys)))+merge (x :> xs) (y :> ys) = x :> y :> merge xs ys  {-# NOINLINE reverse #-} -- | Returns the elements in a vector in reverse order@@ -717,14 +761,15 @@ -- >>> take d0               (1:>2:>Nil) -- <> -- >>> take d4               (1:>2:>Nil)---   <interactive>---       Couldn't match type ‘4 + n0’ with ‘2’---       The type variable ‘n0’ is ambiguous---       Expected type: Vec (4 + n0) a---         Actual type: Vec (1 + 1) a---       In the second argument of ‘vtake’, namely ‘(1 :> 2 :> Nil)’---       In the expression: vtake d4 (1 :> 2 :> Nil)---       In an equation for ‘it’: it = vtake d4 (1 :> 2 :> Nil)+-- <BLANKLINE>+-- <interactive>:...+--     Couldn't match type ‘4 + n0’ with ‘2’+--     The type variable ‘n0’ is ambiguous+--     Expected type: Vec (4 + n0) a+--       Actual type: Vec (1 + 1) a+--     In the second argument of ‘take’, namely ‘(1 :> 2 :> Nil)’+--     In the expression: take d4 (1 :> 2 :> Nil)+--     In an equation for ‘it’: it = take d4 (1 :> 2 :> Nil) take :: SNat m -> Vec (m + n) a -> Vec m a take n = fst . splitAt n @@ -746,11 +791,12 @@ -- >>> drop d0               (1:>2:>Nil) -- <1,2> -- >>> drop d4               (1:>2:>Nil)---   <interactive>---       Couldn't match expected type ‘2’ with actual type ‘4 + n0’---       The type variable ‘n0’ is ambiguous---       In the first argument of ‘print’, namely ‘it’---       In a stmt of an interactive GHCi command: print it+-- <BLANKLINE>+-- <interactive>:...+--     Couldn't match expected type ‘2’ with actual type ‘4 + n0’+--     The type variable ‘n0’ is ambiguous+--     In the first argument of ‘print’, namely ‘it’+--     In a stmt of an interactive GHCi command: print it drop :: SNat m -> Vec (m + n) a -> Vec n a drop n = snd . splitAt n @@ -768,9 +814,9 @@ -- __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and -- ending at 'maxIndex'. ----- >>> at (snat :: SNat 1) (1:>2:>3:>4:>5:>Nil)+-- >>> at (snat :: SNat 1) ((1:>2:>3:>4:>5:>Nil) :: Vec 5 Int) -- 2--- >>> at d1               (1:>2:>3:>4:>5:>Nil)+-- >>> at d1               ((1:>2:>3:>4:>5:>Nil) :: Vec 5 Int) -- 2 at :: SNat m -> Vec (m + (n + 1)) a -> a at n xs = head $ snd $ splitAt n xs@@ -783,7 +829,7 @@ -- <2,4,6> -- >>> select d1 d2 d3 (1:>2:>3:>4:>5:>6:>7:>8:>Nil) -- <2,4,6>-select :: (CmpNat (i + s) (s * n) ~ GT)+select :: (CmpNat (i + s) (s * n) ~ 'GT)        => SNat f        -> SNat s        -> SNat n@@ -801,7 +847,7 @@ -- -- >>> selectI d1 d2 (1:>2:>3:>4:>5:>6:>7:>8:>Nil) :: Vec 2 Int -- <2,4>-selectI :: (CmpNat (i + s) (s * n) ~ GT, KnownNat n)+selectI :: (CmpNat (i + s) (s * n) ~ 'GT, KnownNat n)         => SNat f         -> SNat s         -> Vec (f + i) a@@ -932,6 +978,7 @@ -- In this case, adding 'lazyV' on 'zipWith's second argument: -- -- @+-- sortVL :: (Ord a, KnownNat (n+1)) => Vec (n + 2)  a -> Vec (n + 2) a -- sortVL xs = 'map' fst sorted '<:' (snd ('last' sorted)) --  where --    lefts  = 'head' xs :> map snd ('init' sorted)@@ -971,41 +1018,38 @@ -- --  __NB__: Not synthesisable ----- Using lists, we can define append ('Prelude.++') using 'Prelude.foldr':------ @--- xs ++ ys = 'Prelude.foldr' (':') ys xs--- @+-- Using lists, we can define @append@ ('Prelude.++') using 'Prelude.foldr': ----- >>> [1,2] ++ [3,4]+-- >>> import qualified Prelude+-- >>> let append xs ys = Prelude.foldr (:) ys xs+-- >>> append [1,2] [3,4] -- [1,2,3,4] -- -- However, when we try to do the same for 'Vec': -- -- @--- xs ++ ys = 'foldr' (:>) ys xs+-- append xs ys = 'foldr' (:>) ys xs -- @ ----- We get a function with a very strange type:------ >>> :t (++)--- (++) :: (m + 1) ~ m => Vec n a -> Vec m a -> Vec m a------ Which has an insoluble constraint @(m + 1) ~ m@. This becomes obvious when--- we try to use it:+-- We get a type error ----- >>> (1 :> 2 :> Nil) ++ (3 :> 4 :> Nil)--- <interactive>:7:1:---     Couldn't match type ‘2’ with ‘1’---     Expected type: 1---       Actual type: 1 + 1---     In the expression: (1 :> 2 :> Nil) ++ (3 :> 4 :> Nil)---     In an equation for ‘it’: it = (1 :> 2 :> Nil) ++ (3 :> 4 :> Nil)+-- >>> let append' xs ys = foldr (:>) ys xs+-- <BLANKLINE>+-- <interactive>:...+--     Occurs check: cannot construct the infinite type: n1 ~ n1 + 1+--     Expected type: a -> Vec n1 a -> Vec n1 a+--       Actual type: a -> Vec n1 a -> Vec (n1 + 1) a+--     Relevant bindings include+--       ys :: Vec n1 a (bound at ...)+--       append' :: Vec n a -> Vec n1 a -> Vec n1 a+--         (bound at ...)+--     In the first argument of ‘foldr’, namely ‘(:>)’+--     In the expression: foldr (:>) ys xs -- -- The reason is that the type of 'foldr' is: -- -- >>> :t foldr--- (a -> b -> b) -> b -> Vec n a -> b+-- foldr :: (a -> b -> b) -> b -> Vec n a -> b -- -- While the type of (':>') is: --@@ -1019,20 +1063,23 @@ -- now correctly define ('++'): -- -- @+-- import Data.Singletons.Prelude+-- import Data.Proxy+-- -- data Append (m :: Nat) (a :: *) (f :: 'TyFun' Nat *) :: * -- type instance 'Apply' (Append m a) l = 'Vec' (l + m) a ----- xs ++ ys = dfold (Proxy :: Proxy (Append m a)) (const (':>')) ys xs+-- append' xs ys = 'dfold' (Proxy :: Proxy (Append m a)) (const (':>')) ys xs -- @ ----- We now see that ('++') has the appropriate type:+-- We now see that @append@ has the appropriate type: ----- >>> :t (++)--- (++) :: Vec k a -> Vec m a -> Vec (k + m) a+-- >>> :t append'+-- append' :: Vec k a -> Vec m a -> Vec (k + m) a -- -- And that it works: ----- >>> (1 :> 2 :> Nil) ++ (3 :> 4 :> Nil)+-- >>> append' (1 :> 2 :> Nil) (3 :> 4 :> Nil) -- <1,2,3,4> dfold :: Proxy (p :: TyFun Nat * -> *) -- ^ The /motive/       -> (forall l . Proxy l -> a -> p $ l -> p $ (l + 1)) -- ^ Function to fold@@ -1079,7 +1126,7 @@                  => Vec n (BitVector m)                  -> BitVector (n * m) concatBitVector# Nil       = 0-concatBitVector# (x :> xs) = unsafeCoerce (concatBitVector# xs ++# x)+concatBitVector# (x :> xs) = concatBitVector# xs ++# x  {-# NOINLINE unconcatBitVector# #-} unconcatBitVector# :: (KnownNat n, KnownNat m)@@ -1091,7 +1138,7 @@ ucBV :: forall n m . KnownNat m      => UNat n -> BitVector (n * m) -> Vec n (BitVector m) ucBV UZero     _  = Nil-ucBV (USucc n) bv = let (bv',x :: BitVector m) = split# (unsafeCoerce bv)+ucBV (USucc n) bv = let (bv',x :: BitVector m) = split# bv                     in  x :> ucBV n bv'  instance Lift a => Lift (Vec n a) where

@@ -1,3 +1,4 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-}  {-|@@ -64,6 +65,44 @@ import Data.Int import GHC.Word +-- $setup+-- >>> :set -XTemplateHaskell+-- >>> :set -XDataKinds+-- >>> let ma acc (x,y) = acc + x * y+-- >>> :{+-- let macT acc (x,y) = (acc',o)+--        where+--          acc' = ma acc (x,y)+--          o    = acc+-- :}+--+-- >>> :set -XFlexibleContexts+-- >>> :set -fplugin GHC.TypeLits.Normalise+-- >>> let compareSwapL a b = if a < b then (a,b) else (b,a)+-- >>> :{+-- let sortV xs = map fst sorted <: (snd (last sorted))+--       where+--         lefts  = head xs :> map snd (init sorted)+--         rights = tail xs+--         sorted = zipWith compareSwapL lefts rights+-- :}+--+-- >>> :set -XMonoLocalBinds+-- >>> :set -XTypeOperators+-- >>> :set -XDataKinds+-- >>> :{+-- let sortVL :: (Ord a, KnownNat (n+1)) => Vec (n + 2) a -> Vec (n + 2) a+--     sortVL xs = map fst sorted <: (snd (last sorted))+--       where+--         lefts  = head xs :> map snd (init sorted)+--         rights = tail xs+--         sorted = zipWith compareSwapL (lazyV lefts) rights+-- :}+--+-- >>> let mac = mealy macT 0+-- >>> let topEntity = mac :: Signal (Signed 9, Signed 9) -> Signal (Signed 9)+-- >>> let testInput = stimuliGenerator $(v [(1,1) :: (Signed 9,Signed 9),(2,2),(3,3),(4,4)])+-- >>> let expectedOutput = outputVerifier $(v [0 :: Signed 9,1,5,14])  {- $introduction CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -111,9 +150,9 @@  {- $installation The CλaSH compiler and Prelude library for circuit design only work with the-<http://haskell.org/ghc GHC> Haskell compiler version 7.8.* and up.+<http://haskell.org/ghc GHC> Haskell compiler version 7.10.* and up. -  (1) Install __GHC (version 7.8.* or higher)__+  (1) Install __GHC (version 7.10.* or higher)__        * Download and install <http://www.haskell.org/ghc/download GHC for your platform>.         Unix user can use @./configure prefix=\<LOCATION\>@ to set the installation@@ -121,15 +160,19 @@        * Make sure that the @bin@ directory of __GHC__ is in your @PATH@. -  (2) Install __Cabal__+  (2) Install __Cabal (version 1.22.* or higher)__ -      * Windows and OS X Mavericks:+      * Binary, when available:            * Download the binary for <http://www.haskell.org/cabal/download.html cabal-install>           * Put the binary in a location mentioned in your @PATH@+          * Add @cabal@'s @bin@ directory to your @PATH@: -      * Other Unix systems:+              * Windows: @%appdata%\\cabal\\bin@+              * Unix: @\$HOME\/.cabal\/bin@ +      * Source:+           * Download the sources for <http://hackage.haskell.org/package/cabal-install cabal-install>           * Unpack (@tar xf@) the archive and @cd@ to the directory           * Run @sh bootstrap.sh@@@ -139,11 +182,8 @@    (2) Install __CλaSH__ -      * Run @cabal install clash-ghc@-      * Add @cabal@'s @bin@ directory to our @PATH@:--          * Windows: @%appdata%\\cabal\\bin@-          * Unix: @\$HOME\/.cabal\/bin@+      * Run @cabal install clash-ghc --enable-documentation --enable-profiling@+      * /This is going to take awhile, so have a refreshment/    (4) Verify that everything is working by: @@ -455,7 +495,7 @@ compares against the results we got from our earlier simulation. We can even simulate the behaviour of the /testbench/: ->>> sampleN 7 $ expectedOutput (topEntity $ unpack testInput)+>>> sampleN 7 $ expectedOutput (topEntity testInput) [False,False,False,False, expected value: 14, not equal to actual value: 30 True,@@ -1076,6 +1116,7 @@     In this case, adding 'lazyV' on 'zipWith's second argument:      @+    sortVL :: (Ord a, KnownNat (n+1)) => Vec (n + 2)  a -> Vec (n + 2) a     sortVL xs = 'map' fst sorted '<:' (snd ('last' sorted))      where        lefts  = 'head' xs :> map snd ('init' sorted)

@@ -0,0 +1,59 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Main where++import Build_doctests (deps)+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++##if defined(mingw32_HOST_OS)+##if defined(i386_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##elif defined(x86_64_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##endif+##endif++-- | Run in a modified codepage where we can print UTF-8 values on Windows.+withUnicode :: IO a -> IO a+##ifdef USE_CP+withUnicode m = do+  cp <- c_GetConsoleCP+  (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp+##else+withUnicode m = m+##endif++main :: IO ()+main = withUnicode $ getSources >>= \sources -> doctest $+    "-isrc"+  : "-idist/build/autogen"+  : "-optP-include"+  : "-optPdist/build/autogen/cabal_macros.h"+  : "-hide-all-packages"+  : map ("-package="++) deps ++ sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+  where+    go dir = do+      (dirs, files) <- getFilesAndDirectories dir+      (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c