diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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)! diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/clash-prelude.cabal b/clash-prelude.cabal --- a/clash-prelude.cabal +++ b/clash-prelude.cabal @@ -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 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 diff --git a/src/CLaSH/Class/BitPack.hs b/src/CLaSH/Class/BitPack.hs --- a/src/CLaSH/Class/BitPack.hs +++ b/src/CLaSH/Class/BitPack.hs @@ -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 diff --git a/src/CLaSH/Prelude.hs b/src/CLaSH/Prelude.hs --- a/src/CLaSH/Prelude.hs +++ b/src/CLaSH/Prelude.hs @@ -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 diff --git a/src/CLaSH/Prelude/BitIndex.hs b/src/CLaSH/Prelude/BitIndex.hs --- a/src/CLaSH/Prelude/BitIndex.hs +++ b/src/CLaSH/Prelude/BitIndex.hs @@ -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 --- --- 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 +-- +-- :... +-- 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 --- :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 +-- +-- :... +-- 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) diff --git a/src/CLaSH/Prelude/BitReduction.hs b/src/CLaSH/Prelude/BitReduction.hs --- a/src/CLaSH/Prelude/BitReduction.hs +++ b/src/CLaSH/Prelude/BitReduction.hs @@ -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'? -- diff --git a/src/CLaSH/Prelude/BlockRam.hs b/src/CLaSH/Prelude/BlockRam.hs --- a/src/CLaSH/Prelude/BlockRam.hs +++ b/src/CLaSH/Prelude/BlockRam.hs @@ -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 +-} module CLaSH.Prelude.BlockRam where import GHC.TypeLits (KnownNat, type (^)) diff --git a/src/CLaSH/Prelude/DataFlow.hs b/src/CLaSH/Prelude/DataFlow.hs --- a/src/CLaSH/Prelude/DataFlow.hs +++ b/src/CLaSH/Prelude/DataFlow.hs @@ -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 @@ -- -- <> 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 @@ -- -- <> 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 @@ -- -- <> 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. -- -- <> 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 @@ -- -- <> 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 diff --git a/src/CLaSH/Prelude/Explicit.hs b/src/CLaSH/Prelude/Explicit.hs --- a/src/CLaSH/Prelude/Explicit.hs +++ b/src/CLaSH/Prelude/Explicit.hs @@ -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 diff --git a/src/CLaSH/Prelude/Mealy.hs b/src/CLaSH/Prelude/Mealy.hs --- a/src/CLaSH/Prelude/Mealy.hs +++ b/src/CLaSH/Prelude/Mealy.hs @@ -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: diff --git a/src/CLaSH/Prelude/Testbench.hs b/src/CLaSH/Prelude/Testbench.hs --- a/src/CLaSH/Prelude/Testbench.hs +++ b/src/CLaSH/Prelude/Testbench.hs @@ -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 diff --git a/src/CLaSH/Promoted/Nat.hs b/src/CLaSH/Promoted/Nat.hs --- a/src/CLaSH/Promoted/Nat.hs +++ b/src/CLaSH/Promoted/Nat.hs @@ -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) diff --git a/src/CLaSH/Promoted/Nat/TH.hs b/src/CLaSH/Promoted/Nat/TH.hs --- a/src/CLaSH/Promoted/Nat/TH.hs +++ b/src/CLaSH/Promoted/Nat/TH.hs @@ -7,18 +7,31 @@ License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij -} -module CLaSH.Promoted.Nat.TH where +module CLaSH.Promoted.Nat.TH + ( -- * Declare a single @d\@ literal + decLiteralD + -- * Declare ranges of @d\@ 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] diff --git a/src/CLaSH/Promoted/Symbol.hs b/src/CLaSH/Promoted/Symbol.hs --- a/src/CLaSH/Promoted/Symbol.hs +++ b/src/CLaSH/Promoted/Symbol.hs @@ -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 diff --git a/src/CLaSH/Signal.hs b/src/CLaSH/Signal.hs --- a/src/CLaSH/Signal.hs +++ b/src/CLaSH/Signal.hs @@ -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] diff --git a/src/CLaSH/Signal/Bundle.hs b/src/CLaSH/Signal/Bundle.hs --- a/src/CLaSH/Signal/Bundle.hs +++ b/src/CLaSH/Signal/Bundle.hs @@ -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) diff --git a/src/CLaSH/Signal/Delayed.hs b/src/CLaSH/Signal/Delayed.hs --- a/src/CLaSH/Signal/Delayed.hs +++ b/src/CLaSH/Signal/Delayed.hs @@ -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: -- -- @ diff --git a/src/CLaSH/Signal/Explicit.hs b/src/CLaSH/Signal/Explicit.hs --- a/src/CLaSH/Signal/Explicit.hs +++ b/src/CLaSH/Signal/Explicit.hs @@ -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) diff --git a/src/CLaSH/Signal/Internal.hs b/src/CLaSH/Signal/Internal.hs --- a/src/CLaSH/Signal/Internal.hs +++ b/src/CLaSH/Signal/Internal.hs @@ -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] diff --git a/src/CLaSH/Sized/Fixed.hs b/src/CLaSH/Sized/Fixed.hs --- a/src/CLaSH/Sized/Fixed.hs +++ b/src/CLaSH/Sized/Fixed.hs @@ -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 diff --git a/src/CLaSH/Sized/Internal/BitVector.hs b/src/CLaSH/Sized/Internal/BitVector.hs --- a/src/CLaSH/Sized/Internal/BitVector.hs +++ b/src/CLaSH/Sized/Internal/BitVector.hs @@ -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 diff --git a/src/CLaSH/Sized/Internal/Index.hs b/src/CLaSH/Sized/Internal/Index.hs --- a/src/CLaSH/Sized/Internal/Index.hs +++ b/src/CLaSH/Sized/Internal/Index.hs @@ -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# diff --git a/src/CLaSH/Sized/Internal/Signed.hs b/src/CLaSH/Sized/Internal/Signed.hs --- a/src/CLaSH/Sized/Internal/Signed.hs +++ b/src/CLaSH/Sized/Internal/Signed.hs @@ -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 diff --git a/src/CLaSH/Sized/Internal/Unsigned.hs b/src/CLaSH/Sized/Internal/Unsigned.hs --- a/src/CLaSH/Sized/Internal/Unsigned.hs +++ b/src/CLaSH/Sized/Internal/Unsigned.hs @@ -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 diff --git a/src/CLaSH/Sized/Vector.hs b/src/CLaSH/Sized/Vector.hs --- a/src/CLaSH/Sized/Vector.hs +++ b/src/CLaSH/Sized/Vector.hs @@ -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 --- --- 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 +-- +-- :... +-- 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 --- --- 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 +-- +-- :... +-- 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 --- --- 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 +-- +-- :... +-- 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 --- --- 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 +-- +-- :... +-- 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) --- --- 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) +-- +-- :... +-- 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) --- --- 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 +-- +-- :... +-- 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) --- :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 +-- +-- :... +-- 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 diff --git a/src/CLaSH/Tutorial.hs b/src/CLaSH/Tutorial.hs --- a/src/CLaSH/Tutorial.hs +++ b/src/CLaSH/Tutorial.hs @@ -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 - Haskell compiler version 7.8.* and up. + 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 . Unix user can use @./configure prefix=\@ 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 * 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 * 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) diff --git a/tests/doctests.hsc b/tests/doctests.hsc new file mode 100644 --- /dev/null +++ b/tests/doctests.hsc @@ -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