clash-lib 1.2.3 → 1.2.4

raw patch · 10 files changed

+272/−658 lines, 10 filesdep +utf8-stringdep ~aesondep ~clash-preludedep ~dlistPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: utf8-string

Dependency ranges changed: aeson, clash-prelude, dlist

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• clash-lib.cabal +5/−4
• src/Clash/Driver.hs +0/−1
• src/Clash/Normalize/PrimitiveReductions.hs +87/−349
• src/Clash/Normalize/Transformations.hs +4/−17
• src/Clash/Primitives/DSL.hs +13/−132
• src/Clash/Primitives/Sized/Vector.hs +0/−46
• src/Clash/Rewrite/Util.hs +6/−1
• src/Data/Aeson/Extra.hs +130/−42
• src/Data/List/Extra.hs +22/−66

@@ -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.

@@ -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

@@ -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)

@@ -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"

@@ -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

@@ -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

@@ -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

@@ -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.

@@ -4,13 +4,23 @@   Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com> -} +{-# 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

@@ -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-