diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Changelog for the Clash project +## 1.2.4 *July 28th 2020* +* Changed: + * Relaxed upper bound versions of `aeson` and `dlist`, in preparation for the new Stack LTS. + * Reverted changes to primitive definitions for 'zipWith', 'map', 'foldr', and 'init' introduced in 1.2.2. They have shown to cause problems in very specific circumstances. + ## 1.2.3 *July 11th 2020* * Changed: * Upgrade to nixos 20.03. Nix and snap users will now use packages present in 20.03. diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-lib -Version: 1.2.3 +Version: 1.2.4 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: Clash is a functional hardware description language that borrows both its @@ -135,19 +135,19 @@ RecordWildCards TemplateHaskell - Build-depends: aeson >= 0.6.2.0 && < 1.5, + Build-depends: aeson >= 0.6.2.0 && < 1.6, ansi-terminal >= 0.8.0.0 && < 0.11, attoparsec >= 0.10.4.0 && < 0.14, base >= 4.11 && < 5, binary >= 0.8.5 && < 0.11, bytestring >= 0.10.0.2 && < 0.11, - clash-prelude == 1.2.3, + clash-prelude == 1.2.4, concurrent-supply >= 0.1.7 && < 0.2, containers >= 0.5.0.0 && < 0.7, data-binary-ieee754 >= 0.4.4 && < 0.6, data-default >= 0.7 && < 0.8, deepseq >= 1.3.0.2 && < 1.5, - dlist >= 0.8 && < 0.9, + dlist >= 0.8 && < 1.1, directory >= 1.2.0.1 && < 1.4, errors >= 1.4.2 && < 2.4, exceptions >= 0.8.3 && < 0.11.0, @@ -176,6 +176,7 @@ time >= 1.4.0.1 && < 1.11, transformers >= 0.5.2.0 && < 0.6, trifecta >= 1.7.1.1 && < 2.2, + utf8-string >= 1.0.1 && < 1.1, vector >= 0.11 && < 1.0, vector-binary-instances >= 0.2.3.5 && < 0.3, unordered-containers >= 0.2.3.3 && < 0.3 diff --git a/src/Clash/Driver.hs b/src/Clash/Driver.hs --- a/src/Clash/Driver.hs +++ b/src/Clash/Driver.hs @@ -540,7 +540,6 @@ , ('P.indexToIntegerVerilog, P.indexToIntegerVerilog) , ('P.indexToIntegerVHDL, P.indexToIntegerVHDL) , ('P.intTF, P.intTF) - , ('P.iterateBBF, P.iterateBBF) , ('P.signedToIntegerVerilog, P.signedToIntegerVerilog) , ('P.signedToIntegerVHDL, P.signedToIntegerVHDL) , ('P.unsignedToIntegerVerilog, P.unsignedToIntegerVerilog) diff --git a/src/Clash/Normalize/PrimitiveReductions.hs b/src/Clash/Normalize/PrimitiveReductions.hs --- a/src/Clash/Normalize/PrimitiveReductions.hs +++ b/src/Clash/Normalize/PrimitiveReductions.hs @@ -33,30 +33,23 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} module Clash.Normalize.PrimitiveReductions where import qualified Control.Lens as Lens -import Control.Lens ((.=)) import Data.List (mapAccumR) import qualified Data.Maybe as Maybe -import TextShow (showt) -import PrelNames - (boolTyConKey, typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, - typeNatSubTyFamNameKey) +import PrelNames (boolTyConKey) import Unique (getKey) -import SrcLoc (wiredInSrcSpan) import Clash.Core.DataCon (DataCon) import Clash.Core.Literal (Literal (..)) -import Clash.Core.Name - (nameOcc, Name(..), NameSort(User), mkUnsafeSystemName) +import Clash.Core.Name (nameOcc) import Clash.Core.Pretty (showPpr) import Clash.Core.Term (CoreContext (..), PrimInfo (..), Term (..), WorkInfo (..), Pat (..), - collectTermIds, mkApps) + collectTermIds, mkApps, idToVar) import Clash.Core.TermInfo import Clash.Core.Type (LitTy (..), Type (..), TypeView (..), coreView1, @@ -64,13 +57,12 @@ splitFunForallTy, tyView) import Clash.Core.TyCon (TyConMap, TyConName, tyConDataCons, tyConName) -import Clash.Core.TysPrim - (integerPrimTy, typeNatKind, liftedTypeKind) +import Clash.Core.TysPrim (integerPrimTy, typeNatKind) import Clash.Core.Util (appendToVec, extractElems, extractTElems, mkRTree, mkUniqInternalId, mkUniqSystemTyVar, mkVec, dataConInstArgTys, primCo, undefinedTm) -import Clash.Core.Var (Var (..), mkTyVar, mkLocalId) +import Clash.Core.Var (Var (..)) import Clash.Core.VarEnv (InScopeSet, extendInScopeSetList) import {-# SOURCE #-} Clash.Normalize.Strategy @@ -79,184 +71,7 @@ import Clash.Rewrite.Util import Clash.Unique import Clash.Util -import qualified Clash.Util.Interpolate as I -typeNatAdd :: TyConName -typeNatAdd = - Name User "GHC.TypeNats.+" (getKey typeNatAddTyFamNameKey) wiredInSrcSpan - -typeNatMul :: TyConName -typeNatMul = - Name User "GHC.TypeNats.*" (getKey typeNatMulTyFamNameKey) wiredInSrcSpan - -typeNatSub :: TyConName -typeNatSub = - Name User "GHC.TypeNats.-" (getKey typeNatSubTyFamNameKey) wiredInSrcSpan - -vecHeadPrim - :: TyConName - -- ^ Vec TyCon name - -> Term -vecHeadPrim vecTcNm = - -- head :: Vec (n+1) a -> a - Prim (PrimInfo "Clash.Sized.Vector.head" (vecHeadTy vecTcNm) WorkNever) - -vecLastPrim - :: TyConName - -- ^ Vec TyCon name - -> Term -vecLastPrim vecTcNm = - -- last :: Vec (n+1) a -> a - -- has the same type signature as head, hence we're reusing its type - -- definition here. - Prim (PrimInfo "Clash.Sized.Vector.last" (vecHeadTy vecTcNm) WorkNever) - -vecHeadTy - :: TyConName - -- ^ Vec TyCon name - -> Type -vecHeadTy vecNm = - ForAllTy nTV $ - ForAllTy aTV $ - mkFunTy - (mkTyConApp vecNm [mkTyConApp typeNatAdd [VarTy nTV, LitTy (NumTy 1)], VarTy aTV]) - (VarTy aTV) - where - aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 0) - nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1) - -vecTailPrim - :: TyConName - -- ^ Vec TyCon name - -> Term -vecTailPrim vecTcNm = - -- tail :: Vec (n + 1) a -> Vec n a - Prim (PrimInfo "Clash.Sized.Vector.tail" (vecTailTy vecTcNm) WorkNever) - -vecInitPrim - :: TyConName - -- ^ Vec TyCon name - -> Term -vecInitPrim vecTcNm = - -- init :: Vec (n + 1) a -> Vec n a - -- has the same type signature as tail, hence we're reusing its type - -- definition here. - Prim (PrimInfo "Clash.Sized.Vector.init" (vecTailTy vecTcNm) WorkNever) - -vecTailTy - :: TyConName - -- ^ Vec TyCon name - -> Type -vecTailTy vecNm = - ForAllTy nTV $ - ForAllTy aTV $ - mkFunTy - (mkTyConApp vecNm [mkTyConApp typeNatAdd [VarTy nTV, LitTy (NumTy 1)], VarTy aTV]) - (mkTyConApp vecNm [VarTy nTV, VarTy aTV]) - where - nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0) - aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 1) - --- | Makes two case statements: the first one extract the _head_ from the given --- vector, the latter the tail. -extractHeadTail - :: DataCon - -- ^ The Cons (:>) constructor - -> Type - -- ^ Element type - -> Integer - -- ^ Length of the vector - -> Term - -- ^ Vector to extract head from - -> (Term, Term) - -- ^ (head of vector, tail of vector) -extractHeadTail consCon elTy n vec = - ( Case vec elTy [(pat, Var el)] - , Case vec restTy [(pat, Var rest)] ) - where - tys = [(LitTy (NumTy n)), elTy, (LitTy (NumTy (n-1)))] - Just [coTy, _elTy, restTy] = dataConInstArgTys consCon tys - - mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0) - co = mkLocalId coTy (mkUnsafeSystemName "_co_" 1) - el = mkLocalId elTy (mkUnsafeSystemName "el" 2) - rest = mkLocalId restTy (mkUnsafeSystemName "res" 3) - - pat = DataPat consCon [mTV] [co, el, rest] - --- Make case statement that projects the _head_ from a given vector -extractHead - :: DataCon - -- ^ The Cons (:>) constructor - -> Type - -- ^ Element type - -> Integer - -- ^ Length of the vector - -> Term - -- ^ Vector to extract head from - -> Term - -- ^ Head of vector -extractHead consCon elTy vLength vec = - fst (extractHeadTail consCon elTy vLength vec) - --- Make case statement that projects the _tail_ from a given vector -extractTail - :: DataCon - -- ^ The Cons (:>) constructor - -> Type - -- ^ Element type - -> Integer - -- ^ Length of the vector - -> Term - -- ^ Vector to extract head from - -> Term - -- ^ Tail of vector -extractTail consCon elTy vLength vec = - snd (extractHeadTail consCon elTy vLength vec) - --- | Create a vector of supplied elements -mkVecCons - :: HasCallStack - => DataCon - -- ^ The Cons (:>) constructor - -> Type - -- ^ Element type - -> Integer - -- ^ Length of the vector - -> Term - -- ^ head of the vector - -> Term - -- ^ tail of the vector - -> Term -mkVecCons consCon resTy n h t - | n <= 0 = error "mkVecCons: n <= 0" - | otherwise = - mkApps (Data consCon) [ Right (LitTy (NumTy n)) - , Right resTy - , Right (LitTy (NumTy (n-1))) - , Left (primCo consCoTy) - , Left h - , Left t ] - - where - args = dataConInstArgTys consCon [LitTy (NumTy n), resTy, LitTy (NumTy (n-1))] - Just (consCoTy : _) = args - --- | Create an empty vector -mkVecNil - :: DataCon - -- ^ The Nil constructor - -> Type - -- ^ The element type - -> Term -mkVecNil nilCon resTy = - mkApps (Data nilCon) [ Right (LitTy (NumTy 0)) - , Right resTy - , Left (primCo nilCoTy) ] - where - args = dataConInstArgTys nilCon [LitTy (NumTy 0), resTy] - Just (nilCoTy : _ ) = args - -- | Replace an application of the @Clash.Sized.Vector.reverse@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.reverse@ @@ -294,89 +109,73 @@ -- of @Clash.Sized.Vector.zipWith@ reduceZipWith :: TransformContext - -> PrimInfo -- ^ zipWith primitive info -> Integer -- ^ Length of the vector(s) - -> Type -- ^ Element type of the lhs of the function - -> Type -- ^ Element type of the rhs of the function - -> Type -- ^ Element type of the result of the function + -> Type -- ^ Type of the lhs of the function + -> Type -- ^ Type of the rhs of the function + -> Type -- ^ Type of the result of the function -> Term -- ^ The zipWith'd functions -> Term -- ^ The 1st vector argument -> Term -- ^ The 2nd vector argument -> NormalizeSession Term -reduceZipWith _ctx zipWithPrimInfo n lhsElTy rhsElTy resElTy fun lhsArg rhsArg = do - tcm <- Lens.view tcCache - changed (go tcm (termType tcm lhsArg)) - where - go tcm (coreView1 tcm -> Just ty) = go tcm ty - go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm - , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" - , [nilCon, consCon] <- tyConDataCons vecTc - = if n == 0 then - mkVecNil nilCon resElTy - else - let - (a, as) = extractHeadTail consCon lhsElTy n lhsArg - (b, bs) = extractHeadTail consCon rhsElTy n rhsArg - c = mkApps fun [Left a, Left b] - cs = mkApps (Prim zipWithPrimInfo) [ Right lhsElTy - , Right rhsElTy - , Right resElTy - , Right (LitTy (NumTy (n - 1))) - , Left fun - , Left as - , Left bs ] - in - mkVecCons consCon resElTy n c cs - go _ ty = - error $ $(curLoc) ++ [I.i| - reduceZipWith: argument does not have a vector type: - - #{showPpr ty} - |] +reduceZipWith (TransformContext is0 ctx) n lhsElTy rhsElTy resElTy fun lhsArg rhsArg = do + tcm <- Lens.view tcCache + let ty = termType tcm lhsArg + go tcm ty + where + go tcm (coreView1 tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- lookupUniqMap vecTcNm tcm + , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" + , [nilCon,consCon] <- tyConDataCons vecTc + = do + uniqs0 <- Lens.use uniqSupply + fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun + let is1 = extendInScopeSetList is0 (collectTermIds fun1) + (uniqs1,(varsL,elemsL)) = second (second concat . unzip) + $ extractElems uniqs0 is1 consCon lhsElTy 'L' n lhsArg + is2 = extendInScopeSetList is0 (map fst elemsL) + (uniqs2,(varsR,elemsR)) = second (second concat . unzip) + $ extractElems uniqs1 is2 consCon rhsElTy 'R' n rhsArg + funApps = zipWith (\l r -> mkApps fun1 [Left l,Left r]) varsL varsR + lbody = mkVec nilCon consCon resElTy n funApps + lb = Letrec (init elemsL ++ init elemsR) lbody + uniqSupply Lens..= uniqs2 + changed lb + go _ ty = error $ $(curLoc) ++ "reduceZipWith: argument does not have a vector type: " ++ showPpr ty -- | Replace an application of the @Clash.Sized.Vector.map@ primitive on vectors -- of a known length @n@, by the fully unrolled recursive "definition" of -- @Clash.Sized.Vector.map@ reduceMap :: TransformContext - -> PrimInfo -- ^ map primitive info -> Integer -- ^ Length of the vector -> Type -- ^ Argument type of the function -> Type -- ^ Result type of the function -> Term -- ^ The map'd function -> Term -- ^ The map'd over vector -> NormalizeSession Term -reduceMap _ctx mapPrimInfo n argElTy resElTy fun arg = do +reduceMap (TransformContext is0 ctx) n argElTy resElTy fun arg = do tcm <- Lens.view tcCache let ty = termType tcm arg - changed (go tcm ty) + go tcm ty where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) | (Just vecTc) <- lookupUniqMap vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [nilCon,consCon] <- tyConDataCons vecTc - = if n == 0 then - mkVecNil nilCon argElTy - else - let - nPredTy = Right (LitTy (NumTy (n - 1))) - (a, as) = extractHeadTail consCon argElTy n arg - b = mkApps fun [Left a] - bs = mkApps (Prim mapPrimInfo) [ Right argElTy - , Right resElTy - , nPredTy - , Left fun - , Left as ] - in - mkVecCons consCon resElTy n b bs - go _ ty = - error $ $(curLoc) ++ [I.i| - reduceMap: argument does not have a vector type: - - #{showPpr ty} - |] + = do + uniqs0 <- Lens.use uniqSupply + fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun + let is1 = extendInScopeSetList is0 (collectTermIds fun1) + (uniqs1,(vars,elems)) = second (second concat . unzip) + $ extractElems uniqs0 is1 consCon argElTy 'A' n arg + funApps = map (fun1 `App`) vars + lbody = mkVec nilCon consCon resElTy n funApps + lb = Letrec (init elems) lbody + uniqSupply Lens..= uniqs1 + changed lb + go _ ty = error $ $(curLoc) ++ "reduceMap: argument does not have a vector type: " ++ showPpr ty -- | Replace an application of the @Clash.Sized.Vector.imap@ primitive on vectors -- of a known length @n@, by the fully unrolled recursive "definition" of @@ -425,56 +224,6 @@ changed lb go _ ty = error $ $(curLoc) ++ "reduceImap: argument does not have a vector type: " ++ showPpr ty --- | Replace an application of the @Clash.Sized.Vector.iterateI@ primitive on --- vectors of a known length @n@, by the fully unrolled recursive "definition" --- of @Clash.Sized.Vector.iterateI@ -reduceIterateI - :: TransformContext - -> Integer - -- ^ Length of vector - -> Type - -- ^ Vector's element type - -> Type - -- ^ Vector's type - -> Term - -- ^ iterateI's HO-function argument - -> Term - -- ^ iterateI's start value - -> RewriteMonad NormalizeState Term - -- ^ Fully unrolled definition -reduceIterateI (TransformContext is0 ctx) n aTy vTy f0 a = do - tcm <- Lens.view tcCache - f1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) f0 - - -- Generate uniq ids for element assignments. - uniqs0 <- Lens.use uniqSupply - let - is1 = extendInScopeSetList is0 (collectTermIds f1) - ((uniqs1, _is2), elementIds) = - mapAccumR - mkUniqInternalId - (uniqs0, is1) - (zip (map (("el" <>) . showt) [1..n-1]) (repeat aTy)) - uniqSupply .= uniqs1 - - let - TyConApp vecTcNm _ = tyView vTy - Just vecTc = lookupUniqMap vecTcNm tcm - [nilCon, consCon] = tyConDataCons vecTc - elems = map (App f1) (a:map Var elementIds) - vec = mkVec nilCon consCon aTy n (take (fromInteger n) (a:map Var elementIds)) - - -- Result: - -- let - -- el1 = f a - -- el2 = f el1 - -- el3 = f el2 - -- .. - -- in - -- (a :> el1 :> el2 :> el3 :> ..) - -- - pure (Letrec (zip elementIds elems) vec) - -- | Replace an application of the @Clash.Sized.Vector.traverse#@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.traverse#@ @@ -611,8 +360,6 @@ -- of @Clash.Sized.Vector.foldr@ reduceFoldr :: TransformContext - -> PrimInfo - -- ^ Primitive info for foldr blackbox -> Integer -- ^ Length of the vector -> Type @@ -624,34 +371,28 @@ -> Term -- ^ The argument vector -> NormalizeSession Term -reduceFoldr _ _ 0 _ _ start _ = changed start -reduceFoldr _ctx foldrPrimInfo n aTy fun start arg = do +reduceFoldr _ 0 _ _ start _ = changed start +reduceFoldr (TransformContext is0 ctx) n aTy fun start arg = do tcm <- Lens.view tcCache let ty = termType tcm arg - changed (go tcm ty) + go tcm ty where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) - | nameOcc vecTcNm == "Clash.Sized.Vector.Vec" - , Just vecTc <- lookupUniqMap vecTcNm tcm - , [_nilCon, consCon] <- tyConDataCons vecTc - = let - (a, as) = extractHeadTail consCon aTy n arg - b = mkApps (Prim foldrPrimInfo) [ Right aTy - , Right (termType tcm start) - , Right (LitTy (NumTy (n - 1))) - , Left fun - , Left start - , Left as ] - in - mkApps fun [Left a, Left b] - - go _ ty = - error $ $(curLoc) ++ [I.i| - reduceFoldr: argument does not have a vector type: - - #{showPpr ty} - |] + | (Just vecTc) <- lookupUniqMap vecTcNm tcm + , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" + , [_,consCon] <- tyConDataCons vecTc + = do + uniqs0 <- Lens.use uniqSupply + fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun + let is1 = extendInScopeSetList is0 (collectTermIds fun1) + (uniqs1,(vars,elems)) = second (second concat . unzip) + $ extractElems uniqs0 is1 consCon aTy 'G' n arg + lbody = foldr (\l r -> mkApps fun1 [Left l,Left r]) start vars + lb = Letrec (init elems) lbody + uniqSupply Lens..= uniqs1 + changed lb + go _ ty = error $ $(curLoc) ++ "reduceFoldr: argument does not have a vector type: " ++ showPpr ty -- | Replace an application of the @Clash.Sized.Vector.fold@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" @@ -839,37 +580,34 @@ -- vector. reduceInit :: InScopeSet - -> PrimInfo -- ^ Primitive info for 'init' -> Integer -- ^ Length of the vector -> Type -- ^ Element type of the vector -> Term -- ^ The argument vector -> NormalizeSession Term -reduceInit _inScope initPrimInfo n aTy vArg = do - tcm <- Lens.view tcCache - let ty = termType tcm vArg - changed (go tcm ty) - where - go tcm (coreView1 tcm -> Just ty') = go tcm ty' - go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm - , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" - , [nilCon, consCon] <- tyConDataCons vecTc - = if n == 0 then - mkVecNil nilCon aTy - else - let - nPredTy = Right (LitTy (NumTy (n - 1))) - (a, as0) = extractHeadTail consCon aTy (n+1) vArg - as1 = mkApps (Prim initPrimInfo) [nPredTy, Right aTy, Left as0] - in - mkVecCons consCon aTy n a as1 - - go _ ty = - error $ $(curLoc) ++ [I.i| - reduceInit: argument does not have a vector type: +reduceInit inScope n aTy vArg = do + tcm <- Lens.view tcCache + let ty = termType tcm vArg + go tcm ty + where + go tcm (coreView1 tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- lookupUniqMap vecTcNm tcm + , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" + , [nilCon,consCon] <- tyConDataCons vecTc + = do + uniqs0 <- Lens.use uniqSupply + let (uniqs1,(_,elems)) = second unzip + $ extractElems uniqs0 inScope consCon aTy 'L' n vArg + uniqSupply Lens..= uniqs1 + case n of + 0 -> changed (undefinedTm aTy) + 1 -> changed (mkVec nilCon consCon aTy 0 []) + _ -> let el = init elems + iv = mkVec nilCon consCon aTy (n-1) (map (idToVar . fst . head) el) + lb = init (concat el) + in changed (Letrec lb iv) - #{showPpr ty} - |] + go _ ty = error $ $(curLoc) ++ "reduceInit: argument does not have a vector type: " ++ showPpr ty -- | Replace an application of the @Clash.Sized.Vector.(++)@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" diff --git a/src/Clash/Normalize/Transformations.hs b/src/Clash/Normalize/Transformations.hs --- a/src/Clash/Normalize/Transformations.hs +++ b/src/Clash/Normalize/Transformations.hs @@ -2079,7 +2079,7 @@ if shouldReduce1 then let [fun,lhsArg,rhsArg] = Either.lefts args in (`mkTicks` ticks) <$> - reduceZipWith c p n lhsElTy rhsElty resElTy fun lhsArg rhsArg + reduceZipWith c n lhsElTy rhsElty resElTy fun lhsArg rhsArg else return e _ -> return e "Clash.Sized.Vector.map" | argLen == 5 -> do @@ -2092,7 +2092,7 @@ [argElTy,resElTy] ] if shouldReduce1 then let [fun,arg] = Either.lefts args - in (`mkTicks` ticks) <$> reduceMap c p n argElTy resElTy fun arg + in (`mkTicks` ticks) <$> reduceMap c n argElTy resElTy fun arg else return e _ -> return e "Clash.Sized.Vector.traverse#" | argLen == 7 -> @@ -2123,7 +2123,7 @@ , List.anyM isUntranslatableType_not_poly [aTy,bTy] ] if shouldReduce1 then let [fun,start,arg] = Either.lefts args - in (`mkTicks` ticks) <$> reduceFoldr c p n aTy fun start arg + in (`mkTicks` ticks) <$> reduceFoldr c n aTy fun start arg else return e _ -> return e "Clash.Sized.Vector.dfold" | argLen == 8 -> @@ -2187,7 +2187,7 @@ shouldReduce1 <- List.orM [ shouldReduce ctx , isUntranslatableType_not_poly aTy ] if shouldReduce1 - then (`mkTicks` ticks) <$> reduceInit is0 p n aTy vArg + then (`mkTicks` ticks) <$> reduceInit is0 (n+1) aTy vArg else return e _ -> return e "Clash.Sized.Vector.unconcat" | argLen == 6 -> do @@ -2248,19 +2248,6 @@ then let [_,fun,arg] = Either.lefts args in (`mkTicks` ticks) <$> reduceImap c n argElTy resElTy fun arg else return e - _ -> return e - "Clash.Sized.Vector.iterateI" | argLen == 5 -> do - let ([_kn,f,a],[nTy,aTy]) = Either.partitionEithers args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - shouldReduce1 <- List.orM [ - pure (ultra || n < 2) - , shouldReduce ctx - , isUntranslatableType_not_poly aTy ] - - if shouldReduce1 - then (`mkTicks` ticks) <$> reduceIterateI c n aTy eTy f a - else return e _ -> return e "Clash.Sized.Vector.dtfold" | argLen == 8 -> let ([_kn,_motive,lrFun,brFun,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args diff --git a/src/Clash/Primitives/DSL.hs b/src/Clash/Primitives/DSL.hs --- a/src/Clash/Primitives/DSL.hs +++ b/src/Clash/Primitives/DSL.hs @@ -26,9 +26,7 @@ , BlockState (..) , TExpr , declaration - , declarationReturn , instDecl - , instHO , viaAnnotatedSignal -- ** Literals @@ -74,8 +72,6 @@ import Clash.Util (HasCallStack, clogBase) import Control.Lens hiding (Indexed, assign) import Control.Monad.State -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap import Data.List (intersperse) import Data.Maybe (fromMaybe) import Data.Semigroup hiding (Product) @@ -83,7 +79,6 @@ import Data.String import Data.Text (Text) import qualified Data.Text as Text -import qualified Data.Text.Lazy as LText import Data.Text.Prettyprint.Doc.Extra import TextShow (showt) @@ -91,11 +86,9 @@ import Clash.Backend hiding (fromBV, toBV) import Clash.Backend.VHDL (VHDLState) import Clash.Core.Var (Attr') -import Clash.Netlist.BlackBox.Util (exprToString, renderElem) -import Clash.Netlist.BlackBox.Types - (BlackBoxTemplate, Element(Component, Text), Decl(..)) +import Clash.Netlist.BlackBox.Util (exprToString) import Clash.Netlist.Id -import Clash.Netlist.Types hiding (Component, toBit) +import Clash.Netlist.Types hiding (toBit) import Clash.Netlist.Util hiding (mkUniqueIdentifier) import qualified Data.String.Interpolate as I import Data.String.Interpolate.Util (unindent) @@ -132,40 +125,17 @@ -- backend state. data BlockState backend = BlockState { _bsDeclarations :: [Declaration] - -- ^ Declarations store - , _bsHigherOrderCalls :: IntMap Int - -- ^ Tracks how many times a higher order function has been instantiated. - -- Needed to fill in the second field of "Clash.Netlist.BlackBox.Types.Decl" - , _bsBackend :: backend - -- ^ Backend state + , _bsBackend :: backend } -makeLenses ''BlockState -- | A typed expression. data TExpr = TExpr { ety :: HWType , eex :: Expr } deriving Show -makeLenses ''TExpr --- | Run a block declaration. Assign the result of the block builder to the --- result variable in the given blackbox context. -declarationReturn - :: Backend backend - => BlackBoxContext - -> Text.Text - -- ^ block name - -> State (BlockState backend) TExpr - -- ^ block builder yielding an expression that should be assigned to the - -- result variable in the blackbox context - -> State backend Doc - -- ^ pretty printed block -declarationReturn bbCtx blockName blockBuilder = - declaration blockName $ do - res <- blockBuilder - let (Identifier resultNm Nothing, _) = bbResult bbCtx - addDeclaration (Assignment resultNm (eex res)) - pure () +makeLenses ''BlockState +makeLenses ''TExpr -- | Run a block declaration. declaration @@ -178,8 +148,8 @@ -- ^ pretty printed block declaration blockName s = do backend0 <- get - let initState = BlockState [] IntMap.empty backend0 - BlockState decs _hoCalls backend1 = execState s initState + let initState = BlockState [] backend0 + BlockState decs backend1 = execState s initState put backend1 blockNameUnique <- mkUniqueIdentifier Basic blockName getMon $ blockDecl blockNameUnique (reverse decs) @@ -193,34 +163,10 @@ newName nm = zoom bsBackend $ mkUniqueIdentifier Basic nm -- | Declare a new signal with the given name and type. -declare' - :: Backend backend - => Identifier - -- ^ Name hint - -> WireOrReg - -- ^ Should signal be declared as a wire or a reg - -> HWType - -- ^ Type of new signal - -> State (BlockState backend) Identifier - -- ^ Expression pointing the the new signal -declare' decName wireOrReg ty = do +declare :: Backend backend => Identifier -> HWType -> State (BlockState backend) TExpr +declare decName ty = do uniqueName <- newName decName - addDeclaration (NetDecl' Nothing wireOrReg uniqueName (Right ty) Nothing) - pure uniqueName - --- | Declare a new signal with the given name and type. -declare - :: Backend backend - => Identifier - -- ^ Name hint - -> WireOrReg - -- ^ Should signal be declared as a wire or a reg - -> HWType - -- ^ Type of new signal - -> State (BlockState backend) TExpr - -- ^ Expression pointing the the new signal -declare decName wireOrReg ty = do - uniqueName <- declare' decName wireOrReg ty + addDeclaration (NetDecl Nothing uniqueName ty) pure (TExpr ty (Identifier uniqueName Nothing)) -- | Assign an expression to an identifier, returns the new typed @@ -234,7 +180,7 @@ -> State (BlockState backend) TExpr -- ^ the identifier of the expression that actually got assigned assign aName (TExpr ty aExpr) = do - texp@(~(TExpr _ (Identifier uniqueName Nothing))) <- declare aName Wire ty + texp@(~(TExpr _ (Identifier uniqueName Nothing))) <- declare aName ty addDeclaration (Assignment uniqueName aExpr) pure texp @@ -266,7 +212,7 @@ -- ^ Name hints for element assignments -> State (BlockState backend) [TExpr] untuple (TExpr ty@(Product _ _ tys) (Identifier resName _)) vals = do - newNames <- zipWithM (flip declare Wire) vals tys + newNames <- zipWithM declare vals tys addDeclaration $ Assignment resName $ DataCon ty (DC (ty, 0)) (fmap eex newNames) pure newNames untuple e i = error $ "untuple: " <> show e <> " " <> show i @@ -314,7 +260,7 @@ T -> pure High F -> pure Low TExpr Bool boolExpr -> do - texp@(~(TExpr _ (Identifier uniqueBitName Nothing))) <- declare bitName Wire Bit + texp@(~(TExpr _ (Identifier uniqueBitName Nothing))) <- declare bitName Bit addDeclaration $ CondAssignment uniqueBitName Bit boolExpr Bool [ (Just (BoolLit True), Literal Nothing (BitLit H)) @@ -531,71 +477,6 @@ instance IsString LitHDL where fromString = S - --- | Instantiate/call a higher-order function. -instHO - :: Backend backend - => BlackBoxContext - -- ^ BlackBoxContext, used for rendering higher-order function and error - -- reporting - -> Int - -- ^ Position of HO-argument. For example: - -- - -- fold :: forall n a . (a -> a -> a) -> Vec (n + 1) a -> a - -- - -- would have its HO-argument at position 0, while - -- - -- iterateI :: forall n a. KnownNat n => (a -> a) -> a -> Vec n a - -- - -- would have it at position 1. - -> (HWType, BlackBoxTemplate) - -- ^ Result type of HO function - -> [(TExpr, BlackBoxTemplate)] - -- ^ Arguments and their types - -> State (BlockState backend) TExpr - -- ^ Result of the function -instHO bbCtx fPos (resTy, bbResTy) argsWithTypes = do - let (args0, argTypes) = unzip argsWithTypes - fSubPos <- fromMaybe 0 . IntMap.lookup fPos <$> use bsHigherOrderCalls - bsHigherOrderCalls %= IntMap.insert fPos (succ fSubPos) - - -- Create argument identifiers, example: fold_ho3_0_arg0 - let - ctxName = last (Text.split (=='.') (bbName bbCtx)) - baseArgName = ctxName <> "_" <> "ho" <> showt fPos <> "_" <> showt fSubPos - argName n = baseArgName <> "_arg" <> showt n - args1 <- zipWithM (\argN -> toIdentifier' (argName argN)) [(0 :: Int)..] args0 - let - args2 = map (pure . Text . LText.fromStrict) args1 - args3 = zip args2 argTypes - - -- Create result identifier - -- See https://github.com/clash-lang/clash-compiler/issues/919 for info on - -- logic of 'resWireOrReg' - resWireOrReg = - case IntMap.lookup fPos (bbFunctions bbCtx) of - Just ((_,rw,_,_,_,_):_) -> rw - _ -> error "internal error" - resName <- declare' (ctxName <> "_" <> "ho" <> showt fPos <> "_" - <> showt fSubPos <> "_res") resWireOrReg resTy - let res = ([Text (LText.fromStrict resName)], bbResTy) - - -- Render HO argument to plain text - let component = Component (Decl fPos fSubPos (res:args3)) - rendered0 <- - zoom bsBackend (string =<< (renderElem bbCtx component <*> pure 0)) - - let - layout = LayoutOptions (AvailablePerLine 120 0.4) - rendered1 = renderLazy (layoutPretty layout rendered0) - - addDeclaration $ - BlackBoxD - ("__INST_" <> bbName bbCtx <> "_BB_INTERNAL__") [] [] [] - (BBTemplate [Text rendered1]) - (emptyBBContext ("__INST_" <> bbName bbCtx <> "_BB_INTERNAL__")) - - pure (TExpr resTy (Identifier resName Nothing)) -- | Instantiate a component/entity in a block state. instDecl diff --git a/src/Clash/Primitives/Sized/Vector.hs b/src/Clash/Primitives/Sized/Vector.hs --- a/src/Clash/Primitives/Sized/Vector.hs +++ b/src/Clash/Primitives/Sized/Vector.hs @@ -16,8 +16,6 @@ import qualified Control.Lens as Lens import Data.Either (rights) import qualified Data.IntMap as IntMap -import Data.List.Extra (iterateNM) -import Data.Maybe (fromMaybe) import Data.Semigroup.Monad (getMon) import qualified Data.Text as Text import qualified Data.Text.Lazy as LText @@ -47,52 +45,9 @@ bbFunctions) import Clash.Netlist.Id (IdType(Basic)) import Clash.Netlist.Util (typeSize) -import qualified Clash.Primitives.DSL as Prim -import Clash.Primitives.DSL - (declarationReturn, instHO, tInputs, tExprToInteger) import Clash.Util (HasCallStack, curLoc) --- | Blackbox function for 'Clash.Sized.Vector.iterateI' -iterateBBF :: HasCallStack => BlackBoxFunction -iterateBBF _isD _primName args _resTy = do - tcm <- Lens.use tcCache - pure (Right (meta tcm, bb)) - where - bb = BBFunction "Clash.Primitives.Sized.Vector.iterateBBF" 0 iterateTF - vecLength tcm = - case coreView tcm (head (rights args)) of - (LitTy (NumTy 0)) -> error "Unexpected empty vector in 'iterateBBF'" - (LitTy (NumTy n)) -> fromInteger (n - 1) - vl -> error $ "Unexpected vector length: " ++ show vl - meta tcm = emptyBlackBoxMeta { - bbKind=TDecl - , bbFunctionPlurality=[(1, vecLength tcm)] - } - --- | Type signature of function we're generating netlist for: --- --- iterateI :: KnownNat n => (a -> a) -> a -> Vec n a --- -iterateTF :: TemplateFunction -iterateTF = TemplateFunction [] (const True) iterateTF' - -iterateTF' - :: forall s - . (HasCallStack, Backend s) - => BlackBoxContext - -> State s Doc -iterateTF' bbCtx - | [ (fromMaybe (error "n") . tExprToInteger -> n, _) - , _hoFunction - , (a, aType) - ] <- tInputs bbCtx - , let aTemplateType = [TypElem (Typ (Just 2))] - , let inst arg = instHO bbCtx 1 (aType, aTemplateType) [(arg, aTemplateType)] - = declarationReturn bbCtx "iterateI" (Prim.vec =<< iterateNM (fromInteger n) inst a) - | otherwise - = error $ "Unexpected number of arguments: " ++ show (length (bbInputs bbCtx)) - data FCall = FCall Identifier -- left @@ -110,7 +65,6 @@ let (d, r) = n `divMod` 2 in 1 + foldFunctionPlurality d + foldFunctionPlurality (d+r) --- | Blackbox function for 'Clash.Sized.Vector.fold' foldBBF :: HasCallStack => BlackBoxFunction foldBBF _isD _primName args _resTy = do tcm <- Lens.use tcCache diff --git a/src/Clash/Rewrite/Util.hs b/src/Clash/Rewrite/Util.hs --- a/src/Clash/Rewrite/Util.hs +++ b/src/Clash/Rewrite/Util.hs @@ -1186,7 +1186,12 @@ ty = termType tcm term nm = mkLocalId ty (mkUnsafeSystemName "x" uniq) -- See [Note: Name re-creation] - inlineTest _ (_, stripTicks -> e_) = isWorkFree e_ + inlineTest _ (i, stripTicks -> e_) = + if isLocalVar e_ then + -- Don't inline `let x = x in x`, it throws us in an infinite loop + pure (i `localIdDoesNotOccurIn` e_) + else + isWorkFree e_ -- | Remove unused binders in given let-binding. Returns /Nothing/ if no unused -- binders were found. diff --git a/src/Data/Aeson/Extra.hs b/src/Data/Aeson/Extra.hs --- a/src/Data/Aeson/Extra.hs +++ b/src/Data/Aeson/Extra.hs @@ -4,13 +4,23 @@ Maintainer : Christiaan Baaij -} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + module Data.Aeson.Extra where import Control.Exception (throw) +import qualified Data.IntMap as IntMap +import Data.IntMap (IntMap) import qualified Data.Ix as Ix import qualified Data.Text as T import Data.Text (Text,pack,unpack) +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import Data.Text.Encoding.Error (UnicodeException(..)) import Data.List (intercalate) +import Data.List.Extra (groupOn) +import Data.Tuple.Extra (second, first) import Data.Aeson (FromJSON, Result (..), fromJSON, json) import Data.Attoparsec.Lazy (Result (..), parse) import Data.ByteString.Lazy (ByteString) @@ -18,34 +28,100 @@ import qualified Data.ByteString.Lazy.Char8 as BSChar import System.FilePath () +import qualified Clash.Util.Interpolate as I import Clash.Util (ClashException(..)) import SrcLoc (mkGeneralSrcSpan) import FastString (mkFastString) import GHC.Stack (HasCallStack) --- Quick and dirty way of replacing fake escapes in naively converted bytestring -replaceCommonEscapes :: Text -> Text -replaceCommonEscapes = ( T.replace (pack "\\n") (pack "\n") ) . - ( T.replace (pack "\\\\") (pack "\\") ) . - ( T.replace (pack "\\\"") (pack "\"") ) +-- | See 'toSpecNewlines'. A line map maps "virtual" lines to a range of +-- "real" lines. E.g., a map of {0: (0, 3), 1: (4, 5)} would mean that line +-- 0 in the virtual JSON (i.e., the one with newlines replaced) file map to +-- lines 0 up to and including 3 in the original user-supplied one. +type LineMap = IntMap (Int, Int) -genLineErr' :: [Text] -> (Int, Int) -> Int -> Text -genLineErr' allLines range errorLineN = T.unlines [ T.concat [ if i == errorLineN then pack ">> " else pack " " - , pack $ show i - , pack ". " - , allLines !! i - ] | i <- Ix.range range] +-- | Aeson versions <1.5.0 accept unescaped newlines in JSON strings. This is in +-- violation of RFC 7159. Aeson 1.5.0 fixes this bug. Unfortunately, "Clash +-- JSON" files rely on the old behavior. This function replaces newlines (in +-- stings) with their escaped variants. +toSpecNewlines + :: ByteString + -> Either UnicodeException (LineMap, ByteString) +toSpecNewlines bs = do + s0 <- LT.unpack <$> LT.decodeUtf8' bs + Right ( toLineMap (go2 0 False s0) + , LT.encodeUtf8 (LT.pack (go False s0))) + where + -- replace newlines with escaped ones + go :: Bool -> String -> String + go _ [] = [] + go True ('\n':rest) = '\\' : 'n' : go True rest + go True ('\r':rest) = '\\' : 'r' : go True rest + go True ('\t':rest) = '\\' : 't' : go True rest + go inString ('\\':r:rest) = '\\' : r : go inString rest + go inString ('"':rest) = '"' : go (not inString) rest + go inString (r:rest) = r : go inString rest + -- Calculate real:virtual mapping + go2 + -- virtual line counter. + :: Int + -- Processing a JSON string? + -> Bool + -- String left to process + -> String + -- Virtual line numbers. [0, 1, 1, 2, 2, ..] would mean: + -- + -- real | virtual + -- -------------- + -- 0 | 0 + -- 1 | 1 + -- 2 | 1 + -- 3 | 2 + -- 4 | 2 + -- ... | ... + -- + -> [Int] + go2 n _ [] = [n] + go2 n True ('\n':rest) = n : go2 n True rest + go2 n False ('\n':rest) = n : go2 (succ n) False rest + go2 n inString ('\\':_:rest) = go2 n inString rest + go2 n inString ('"':rest) = go2 n (not inString) rest + go2 n inString (_:rest) = go2 n inString rest + + toLineMap :: [Int] -> LineMap + toLineMap virtuals = + IntMap.fromList + $ map (second (\reals -> (minimum reals, maximum reals))) + $ map (first head . unzip) + $ groupOn fst + $ zip virtuals [(0::Int)..] + +genLineErr' :: [Text] -> (Int, Int) -> [Int] -> Text +genLineErr' allLines range errorLines = + T.unlines [ T.concat [ if elem i errorLines then pack ">> " else pack " " + , pack $ show (i + 1) + , pack ". " + , allLines !! i + ] | i <- Ix.range range] + -- | Pretty print part of json file related to error -genLineErr :: ByteString -> ByteString -> Text -genLineErr full part = genLineErr' allLines interval errorLineN +genLineErr :: LineMap -> ByteString -> ByteString -> ByteString -> Text +genLineErr lineMap fullOrig full part = + genLineErr' allLinesOrig interval [errorLineMin..errorLineMax] where - -- Determine interval, and pass to helper function - nLastLines = 1 + (length $ T.lines $ replaceCommonEscapes $ pack $ show part) - errorLineN = length allLines - nLastLines + 1 - allLines = T.lines $ replaceCommonEscapes $ pack $ show full - interval = (max 0 (errorLineN - 5), min (max 0 $ length allLines - 1) (errorLineN + 5)) + -- Determine error line in "virtual" json file + nLastLines = 1 + (length $ LT.lines $ LT.decodeUtf8 part) + errorLineN = min (length allLines - 1) (length allLines - nLastLines + 1) + allLines = T.lines $ LT.toStrict $ LT.decodeUtf8 full + -- Convert to error lines in actual json file, and calculate interval + -- to display to user. + allLinesOrig = T.lines $ LT.toStrict $ LT.decodeUtf8 fullOrig + (errorLineMin, errorLineMax) = lineMap IntMap.! errorLineN + interval = ( max 0 (errorLineMin - 5) + , min (max 0 $ length allLinesOrig - 1) (errorLineMax + 5) ) + -- | Parse a ByteString according to the given JSON template. Throws exception -- if it fails. decodeOrErr @@ -55,31 +131,43 @@ -> ByteString -- ^ Bytestring to parse -> a -decodeOrErr path contents = - case parse json contents of - Done leftover v -> - case fromJSON v of - Success _ | BS.any notWhitespace leftover -> - clashError ("After parsing " ++ show path - ++ ", found unparsed trailing garbage:\n" - ++ BSChar.unpack leftover) - Success a -> - a - Error msg -> - clashError - ( "Could not deduce valid scheme for json in " - ++ show path ++ ". Error was: \n\n" ++ msg ) +decodeOrErr path contents0 = + case toSpecNewlines contents0 of + Left (DecodeError err _) -> clashError [I.i| + Failed to decode JSON file as UTF8: - -- JSON parse error: - Fail bytes cntxs msg -> - clashError - ( "Could not read or parse json in " ++ show path ++ ". " - ++ (if null cntxs then "" else "Context was:\n " ++ intercalate "\n " cntxs) - ++ "\n\nError reported by Attoparsec was:\n " - ++ msg - ++ "\n\nApproximate location of error:\n\n" - -- HACK: Replace with proper parser/fail logic in future. Or don't. It's not important. - ++ (unpack $ genLineErr contents bytes) ) + #{path} + + Decoder reported: + + #{err} + |] + Left _ -> error "unreachable" + Right (!lineMap, !contents1) -> + case parse json contents1 of + Done leftover v -> + case fromJSON v of + Success _ | BS.any notWhitespace leftover -> + clashError ("After parsing " ++ show path + ++ ", found unparsed trailing garbage:\n" + ++ BSChar.unpack leftover) + Success a -> + a + Error msg -> + clashError + ( "Could not deduce valid scheme for json in " + ++ show path ++ ". Error was: \n\n" ++ msg ) + + -- JSON parse error: + Fail bytes cntxs msg -> + clashError + ( "Could not read or parse json in " ++ show path ++ ". " + ++ (if null cntxs then "" else "Context was:\n " ++ intercalate "\n " cntxs) + ++ "\n\nError reported by Attoparsec was:\n " + ++ msg + ++ "\n\nApproximate location of error:\n\n" + -- HACK: Replace with proper parser/fail logic in future. Or don't. It's not important. + ++ (unpack $ genLineErr lineMap contents0 contents1 bytes) ) where loc = mkGeneralSrcSpan $ mkFastString path clashError msg = throw $ ClashException loc msg Nothing diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs --- a/src/Data/List/Extra.hs +++ b/src/Data/List/Extra.hs @@ -1,17 +1,30 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} -module Data.List.Extra where +module Data.List.Extra + ( partitionM + , mapAccumLM + , (<:>) + , indexMaybe + , splitAtList + , equalLength + , countEq + , zipEqual -import Control.Applicative (liftA2) + -- * From Control.Monad.Extra + , anyM + , allM + , orM --- | Monadic version of 'Data.List.partition' -partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a]) -partitionM _ [] = return ([], []) -partitionM p (x:xs) = do - test <- p x - (ys, ys') <- partitionM p xs - return $ if test then (x:ys, ys') else (ys, x:ys') + -- * From "extra" + , module NeilsExtra + ) where +import "extra" Data.List.Extra as NeilsExtra +import "extra" Control.Monad.Extra (anyM, allM, orM, partitionM) + +import Control.Applicative (liftA2) + -- | Monadic version of 'Data.List.mapAccumL' mapAccumLM :: (Monad m) @@ -25,26 +38,6 @@ (acc'',ys) <- mapAccumLM f acc' xs return (acc'',y:ys) --- | Monadic version of 'iterate'. A carbon copy ('iterateM') would not --- terminate, hence the first argument. -iterateNM - :: Monad m - => Word - -- ^ Only iterate /n/ times. Note that /n/ is the length of the resulting - -- list, _not_ the number of times the iteration function has been invoked - -> (a -> m a) - -- ^ Iteration function - -> a - -- ^ Start value - -> m [a] -iterateNM 0 _f _a = pure [] -iterateNM limit f a = fmap (a:) (go (limit - 1) a) - where - go 0 _a0 = pure [] - go n a0 = do - a1 <- f a0 - fmap (a1:) (go (n - 1) a1) - infixr 5 <:> -- | Applicative version of 'GHC.Types.(:)' (<:>) :: Applicative f => f a -> f [a] -> f [a] @@ -91,40 +84,3 @@ zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs zipEqual _ _ = error "zipEqual" #endif - --- | Short-circuiting monadic version of 'any' -anyM - :: (Monad m) - => (a -> m Bool) - -> [a] - -> m Bool -anyM _ [] = return False -anyM p (x:xs) = do - q <- p x - if q then - return True - else - anyM p xs - -allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool -allM _ [] = return True -allM p (x:xs) = do - q <- p x - if q then - allM p xs - else - return False - --- | short-circuiting monadic version of 'or' -orM - :: (Monad m) - => [m Bool] - -> m Bool -orM [] = pure False -orM (x:xs) = do - p <- x - if p then - pure True - else - orM xs -