clash-lib 0.6.20 → 0.6.21

raw patch · 8 files changed

+398/−349 lines, 8 filesdep ~aesondep ~lensPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: aeson, lens

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• clash-lib.cabal +2/−2
• src/CLaSH/Core/Type.hs +111/−59
• src/CLaSH/Core/Util.hs +5/−81
• src/CLaSH/Netlist/Util.hs +5/−7
• src/CLaSH/Normalize/PrimitiveReductions.hs +254/−187
• src/CLaSH/Normalize/Transformations.hs +1/−1
• src/CLaSH/Rewrite/Util.hs +16/−12

@@ -1,5 +1,9 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.6.21 *August 18th 2016*+* Fixes bugs:+  * Type families are not currently being reduced correctly [#167](https://github.com/clash-lang/clash-compiler/issues/167)+ ## 0.6.20 *August 3rd 2016* * Fixes bugs:   * Bug in DEC transformation overwrites case-alternatives

@@ -1,5 +1,5 @@ Name:                 clash-lib-Version:              0.6.20+Version:              0.6.21 Synopsis:             CAES Language for Synchronous Hardware - As a Library Description:   CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -87,7 +87,7 @@                       TupleSections                       ViewPatterns -  Build-depends:      aeson                   >= 0.6.2.0  && < 0.12,+  Build-depends:      aeson                   >= 0.6.2.0  && < 1.1,                       attoparsec              >= 0.10.4.0 && < 0.14,                       base                    >= 4.8      && < 5,                       bytestring              >= 0.10.0.2 && < 0.11,

@@ -27,7 +27,6 @@   , TyVar   , tyView   , coreView-  , transparentTy   , typeKind   , mkTyConTy   , mkFunTy@@ -44,6 +43,7 @@   , applyFunTy   , applyTy   , findFunSubst+  , reduceTypeFamily   , undefinedTy   ) where@@ -53,19 +53,19 @@ import           Control.Monad                           (zipWithM) import           Data.HashMap.Strict                     (HashMap) import qualified Data.HashMap.Strict                     as HashMap-import           Data.Maybe                              (isJust)+import           Data.Maybe                              (isJust, mapMaybe) import           GHC.Generics                            (Generic(..)) import           Unbound.Generics.LocallyNameless        (Alpha(..),Bind,Fresh,                                                           Subst(..),SubstName(..),                                                           acompare,aeq,bind,embed,                                                           gacompare,gaeq,gfvAny,                                                           runFreshM,unbind)-import           Unbound.Generics.LocallyNameless.Name   (Name,name2String,+import           Unbound.Generics.LocallyNameless.Name   (Name (..),name2String,                                                           string2Name) import           Unbound.Generics.LocallyNameless.Extra  ()-import           Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind)  -- Local imports+import           CLaSH.Core.DataCon import           CLaSH.Core.Subst import {-# SOURCE #-} CLaSH.Core.Term import           CLaSH.Core.TyCon@@ -149,32 +149,22 @@ tyView (ConstTy (TyCon tc)) = TyConApp tc [] tyView t = OtherType t --- | A transformation that renders 'Signal' types transparent-transparentTy :: Type -> Type-transparentTy ty@(AppTy (AppTy (ConstTy (TyCon tc)) _) elTy)-  = case name2String tc of-      "CLaSH.Signal.Internal.Signal'" -> transparentTy elTy-      _ -> ty-transparentTy (AppTy ty1 ty2) = AppTy (transparentTy ty1) (transparentTy ty2)-transparentTy (ForAllTy b)    = ForAllTy (uncurry bind $ second transparentTy $ unsafeUnbind b)-transparentTy ty              = ty---- | A view on types in which 'Signal' types and newtypes are transparent, and--- type functions are evaluated when possible.-coreView :: HashMap TyConName TyCon -> Type -> TypeView-coreView tcMap ty =-  let tView = tyView ty-  in case tView of-       TyConApp tc args -> case name2String tc of-         "CLaSH.Signal.Internal.Signal'" -> coreView tcMap (args !! 1)-         _ -> case (tcMap HashMap.! tc) of-                AlgTyCon {algTcRhs = (NewTyCon _ nt)}-                  -> coreView tcMap (newTyConInstRhs nt args)-                FunTyCon {tyConSubst = tcSubst} -> case findFunSubst tcSubst args of-                  Just ty' -> coreView tcMap ty'-                  _ -> tView-                _ -> tView-       _ -> tView+-- | A view on types in which newtypes are transparent, the Signal type is+-- transparent, and type functions are evaluated to WHNF (when possible).+--+-- Only strips away one "layer".+coreView :: HashMap TyConName TyCon -> Type -> Maybe Type+coreView tcMap ty = case tyView ty of+  TyConApp tcNm args+    | name2String tcNm == "CLaSH.Signal.Internal.Signal'"+    , [_,elTy] <- args+    -> Just elTy+    | otherwise+    -> case tcMap HashMap.! tcNm of+         AlgTyCon {algTcRhs = (NewTyCon _ nt)}+           -> Just (newTyConInstRhs nt args)+         _ -> reduceTypeFamily tcMap ty+  _ -> Nothing  -- | Instantiate and Apply the RHS/Original of a NewType with the given -- list of argument types@@ -243,16 +233,18 @@ splitFunTy :: HashMap TyConName TyCon            -> Type            -> Maybe (Type, Type)-splitFunTy m (coreView m -> FunTy arg res) = Just (arg,res)-splitFunTy _ _                             = Nothing+splitFunTy m (coreView m -> Just ty)   = splitFunTy m ty+splitFunTy _ (tyView -> FunTy arg res) = Just (arg,res)+splitFunTy _ _ = Nothing  splitFunTys :: HashMap TyConName TyCon             -> Type             -> ([Type],Type)-splitFunTys m (coreView m -> FunTy arg res) = (arg:args,res')+splitFunTys m ty = go [] ty ty   where-    (args,res') = splitFunTys m res-splitFunTys _ ty = ([],ty)+    go args orig_ty (coreView m -> Just ty')  = go args orig_ty ty'+    go args _       (tyView -> FunTy arg res) = go (arg:args) res res+    go args orig_ty _                         = (reverse args, orig_ty)  -- | Split a poly-function type in a: list of type-binders and argument types, -- and the result type@@ -270,12 +262,13 @@ splitCoreFunForallTy :: HashMap TyConName TyCon                      -> Type                      -> ([Either TyVar Type], Type)-splitCoreFunForallTy tcm = go []+splitCoreFunForallTy tcm ty = go [] ty ty   where-    go args (ForAllTy b) = let (tv, ty) = runFreshM $ unbind b-                           in  go (Left tv:args) ty-    go args (coreView tcm -> FunTy arg res) = go (Right arg:args) res-    go args ty = (reverse args, ty)+    go args orig_ty (coreView tcm -> Just ty') = go args orig_ty ty'+    go args _       (ForAllTy b)               = let (tv,res) = runFreshM $ unbind b+                                                 in  go (Left tv:args) res res+    go args _       (tyView -> FunTy arg res)  = go (Right arg:args) res res+    go args orig_ty _                          = (reverse args,orig_ty)  -- | Is a type a polymorphic or function type? isPolyFunTy :: Type@@ -286,10 +279,11 @@ isPolyFunCoreTy :: HashMap TyConName TyCon                 -> Type                 -> Bool-isPolyFunCoreTy m ty = case coreView m ty of-                         (FunTy _ _) -> True-                         (OtherType (ForAllTy _)) -> True-                         _ -> False+isPolyFunCoreTy m (coreView m -> Just ty) = isPolyFunCoreTy m ty+isPolyFunCoreTy _ ty = case tyView ty of+  FunTy _ _ -> True+  OtherType (ForAllTy _) -> True+  _ -> False  -- | Is a type a function type? isFunTy :: HashMap TyConName TyCon@@ -302,7 +296,8 @@            -> Type            -> Type            -> Type-applyFunTy m (coreView m -> FunTy _ resTy) _ = resTy+applyFunTy m (coreView m -> Just ty)   arg = applyFunTy m ty arg+applyFunTy _ (tyView -> FunTy _ resTy) _   = resTy applyFunTy _ _ _ = error $ $(curLoc) ++ "Report as bug: not a FunTy"  -- | Substitute the type variable of a type ('ForAllTy') with another type@@ -311,7 +306,8 @@         -> Type         -> KindOrType         -> m Type-applyTy tcm (coreView tcm -> OtherType (ForAllTy b)) arg = do+applyTy tcm (coreView tcm -> Just ty) arg = applyTy tcm ty arg+applyTy _   (ForAllTy b) arg = do   (tv,ty) <- unbind b   return (substTy (varName tv) arg ty) applyTy _ ty arg = error ($(curLoc) ++ "applyTy: not a forall type:\n" ++ show ty ++ "\nArg:\n" ++ show arg)@@ -331,33 +327,89 @@  -- Given a set of type functions, and list of argument types, get the first -- type function that matches, and return its substituted RHS type.-findFunSubst :: [([Type],Type)] -> [Type] -> Maybe Type-findFunSubst [] _ = Nothing-findFunSubst (tcSubst:rest) args = case funSubsts tcSubst args of+findFunSubst :: HashMap TyConName TyCon -> [([Type],Type)] -> [Type] -> Maybe Type+findFunSubst _   [] _ = Nothing+findFunSubst tcm (tcSubst:rest) args = case funSubsts tcm tcSubst args of   Just ty -> Just ty-  Nothing -> findFunSubst rest args+  Nothing -> findFunSubst tcm rest args  -- Given a ([LHS match type], RHS type) representing a type function, and -- a set of applied types. Match LHS with args, and when successful, return -- a substituted RHS-funSubsts :: ([Type],Type) -> [Type] -> Maybe Type-funSubsts (tcSubstLhs,tcSubstRhs) args = do-  tySubts <- concat <$> zipWithM funSubst tcSubstLhs args+funSubsts :: HashMap TyConName TyCon -> ([Type],Type) -> [Type] -> Maybe Type+funSubsts tcm (tcSubstLhs,tcSubstRhs) args = do+  tySubts <- concat <$> zipWithM (funSubst tcm) tcSubstLhs args   let tyRhs = substTys tySubts tcSubstRhs   return tyRhs  -- Given a LHS matching type, and a RHS to-match type, check if LHS and RHS -- are a match. If they do match, and the LHS is a variable, return a -- substitution-funSubst :: Type -> Type -> Maybe [(TyName,Type)]-funSubst (VarTy _ nmF) ty = Just [(nmF,ty)]-funSubst tyL@(LitTy _) tyR = if tyL == tyR then Just [] else Nothing-funSubst (tyView -> TyConApp tc argTys) (tyView -> TyConApp tc' argTys')+funSubst :: HashMap TyConName TyCon -> Type -> Type -> Maybe [(TyName,Type)]+funSubst _ (VarTy _ nmF) ty  = Just [(nmF,ty)]+funSubst tcm ty1 (reduceTypeFamily tcm -> Just ty2) = funSubst tcm ty1 ty2 -- See [Note: lazy type families]+funSubst _ tyL@(LitTy _) tyR = if tyL == tyR then Just [] else Nothing+funSubst tcm (tyView -> TyConApp tc argTys) (tyView -> TyConApp tc' argTys')   | tc == tc'   = do-    tySubts <- zipWithM funSubst argTys argTys'+    tySubts <- zipWithM (funSubst tcm) argTys argTys'     return (concat tySubts)-funSubst _ _ = Nothing+funSubst _ _ _ = Nothing++{- [Note: lazy type families]++I don't know whether type families are evaluated strictly or lazily, but this+being Haskell, I assume type families are evaluated lazily.++CLaSH hence follows the Haskell way, and only evaluates type family arguments+to (WH)NF when the formal parameter is _not_ a type variable.+-}++reduceTypeFamily :: HashMap TyConName TyCon -> Type -> Maybe Type+reduceTypeFamily tcm (tyView -> TyConApp tc tys)+  | name2String tc == "GHC.TypeLits.+"+  , [i1, i2] <- mapMaybe (litView tcm) tys+  = Just (LitTy (NumTy (i1 + i2)))++  | name2String tc == "GHC.TypeLits.*"+  , [i1, i2] <- mapMaybe (litView tcm) tys+  = Just (LitTy (NumTy (i1 * i2)))++  | name2String tc == "GHC.TypeLits.^"+  , [i1, i2] <- mapMaybe (litView tcm) tys+  = Just (LitTy (NumTy (i1 ^ i2)))++  | name2String tc == "GHC.TypeLits.-"+  , [i1, i2] <- mapMaybe (litView tcm) tys+  = Just (LitTy (NumTy (i1 - i2)))++  | name2String tc == "GHC.TypeLits.<=?"+  , [i1, i2] <- mapMaybe (litView tcm) tys+  , Just (FunTyCon {tyConKind = tck}) <- HashMap.lookup tc tcm+  , (_,tyView -> TyConApp boolTcNm []) <- splitFunTys tcm tck+  , Just boolTc <- HashMap.lookup boolTcNm tcm+  = let [falseTc,trueTc] = map ((\(Fn s i) -> Fn s i) . dcName) (tyConDataCons boolTc)+    in  if i1 <= i2 then Just (mkTyConApp trueTc [] )+                    else Just (mkTyConApp falseTc [])++  | name2String tc == "GHC.TypeLits.Extra.CLog"+  , [i1, i2] <- mapMaybe (litView tcm) tys+  , Just k <- clogBase i1 i2+  = Just (LitTy (NumTy (toInteger k)))++  | name2String tc == "GHC.TypeLits.Extra.GCD"+  , [i1, i2] <- mapMaybe (litView tcm) tys+  = Just (LitTy (NumTy (i1 `gcd` i2)))++  | Just (FunTyCon {tyConSubst = tcSubst}) <- HashMap.lookup tc tcm+  = findFunSubst tcm tcSubst tys++reduceTypeFamily _ _ = Nothing++litView :: HashMap TyConName TyCon -> Type -> Maybe Integer+litView _ (LitTy (NumTy i))                = Just i+litView m (reduceTypeFamily m -> Just ty') = litView m ty'+litView _ _ = Nothing  -- | The type of GHC.Err.undefined :: forall a . a undefinedTy :: Type

@@ -31,9 +31,8 @@                                                 TmName) import CLaSH.Core.Type                         (Kind, LitTy (..), TyName,                                                 Type (..), TypeView (..), applyTy,-                                                findFunSubst, isFunTy,-                                                isPolyFunCoreTy, mkFunTy,-                                                splitFunTy, tyView)+                                                coreView, isFunTy, isPolyFunCoreTy,+                                                mkFunTy, splitFunTy, tyView) import CLaSH.Core.TyCon                        (TyCon (..), TyConName,                                                 tyConDataCons) import CLaSH.Core.TysPrim                      (typeNatKind)@@ -358,81 +357,6 @@ tyNatSize :: HMS.HashMap TyConName TyCon           -> Type           -> Except String Integer-tyNatSize tcm ty = case go ty of-    Right (Left i) -> return i-    Right _  -> throwE $ $(curLoc) ++ "Cannot reduce an integer: " ++ show ty-    Left msg -> throwE msg-  where-    go :: Type -> Either String (Either Integer Bool)-    go (LitTy (NumTy i)) = return (Left i)--    go (tyView -> TyConApp tc tys)-      | name2String tc == "GHC.TypeLits.+"-      , length tys == 2-      , Right (Left i1) <- go (tys !! 0)-      , Right (Left i2) <- go (tys !! 1)-      = return (Left (i1 + i2))--      | name2String tc == "GHC.TypeLits.*"-      , length tys == 2-      , Right (Left i1) <- go (tys !! 0)-      , Right (Left i2) <- go (tys !! 1)-      = return (Left (i1 * i2))--      | name2String tc == "GHC.TypeLits.^"-      , length tys == 2-      , Right (Left i1) <- go (tys !! 0)-      , Right (Left i2) <- go (tys !! 1)-      = return (Left (i1 ^ i2))--      | name2String tc == "GHC.TypeLits.-"-      , length tys == 2-      , Right (Left i1) <- go (tys !! 0)-      , Right (Left i2) <- go (tys !! 1)-      = return (Left (i1 - i2))--      | name2String tc == "CLaSH.Promoted.Ord.Max"-      , length tys == 2-      , Right (Left i1) <- go (tys !! 0)-      , Right (Left i2) <- go (tys !! 1)-      = return (Left (i1 `max` i2))--      | name2String tc == "CLaSH.Promoted.Ord.Min"-      , length tys == 2-      , Right (Left i1) <- go (tys !! 0)-      , Right (Left i2) <- go (tys !! 1)-      = return (Left (i1 `min` i2))--      | name2String tc == "GHC.TypeLits.Extra.CLog"-      , length tys == 2-      , Right (Left i1) <- go (tys !! 0)-      , Right (Left i2) <- go (tys !! 1)-      , Just k <- clogBase i1 i2-      = return (Left (toInteger k))--      | name2String tc == "GHC.TypeLits.Extra.GCD"-      , length tys == 2-      , Right (Left i1) <- go (tys !! 0)-      , Right (Left i2) <- go (tys !! 1)-      = return (Left (i1 `gcd` i2))--      | name2String tc == "Data.Type.Bool.If"-      , TyConApp tcNat _ <- tyView (tys !! 0)-      , name2String tcNat == "GHC.TypeLits.Nat"-      , Right (Right b) <- go (tys !! 1)-      , Right (Left i1) <- go (tys !! 2)-      , Right (Left i2) <- go (tys !! 3)-      = if b then return (Left i1)-             else return (Left i2)--      | name2String tc == "GHC.TypeLits.<=?"-      , length tys == 2-      , Right (Left i1) <- go (tys !! 0)-      , Right (Left i2) <- go (tys !! 1)-      = return (Right (i1 <= i2))--      | FunTyCon {tyConSubst = tcSubst} <- tcm HMS.! tc-      , Just ty' <- findFunSubst tcSubst tys-      = go ty'--    go t = Left ($(curLoc) ++ "Can't convert tyNat: " ++ show t)+tyNatSize m (coreView m -> Just ty) = tyNatSize m ty+tyNatSize _ (LitTy (NumTy i))       = return i+tyNatSize _ ty = throwE $ $(curLoc) ++ "Cannot reduce an integer: " ++ show ty

@@ -32,7 +32,7 @@ import           CLaSH.Core.Term         (LetBinding, Term (..), TmName) import           CLaSH.Core.TyCon        (TyCon (..), TyConName, tyConDataCons) import           CLaSH.Core.Type         (Type (..), TypeView (..), LitTy (..),-                                          splitTyConAppM, tyView)+                                          coreView, splitTyConAppM, tyView) import           CLaSH.Core.Util         (collectBndrs, termType) import           CLaSH.Core.Var          (Id, Var (..), modifyVarName) import           CLaSH.Netlist.Types     as HW@@ -121,12 +121,10 @@                  -> HashMap TyConName TyCon                  -> Type                  -> Either String HWType-coreTypeToHWType builtInTranslation m ty =-  fromMaybe-    (case tyView ty of-       TyConApp tc args -> mkADT builtInTranslation m (showDoc ty) tc args-       _                -> Left $ "Can't translate non-tycon type: " ++ showDoc ty)-    (builtInTranslation m ty)+coreTypeToHWType builtInTranslation m (builtInTranslation m -> Just hty) = hty+coreTypeToHWType builtInTranslation m (coreView m -> Just ty) = coreTypeToHWType builtInTranslation m ty+coreTypeToHWType builtInTranslation m ty@(tyView -> TyConApp tc args) = mkADT builtInTranslation m (showDoc ty) tc args+coreTypeToHWType _ _ ty = Left $ "Can't translate non-tycon type: " ++ showDoc ty  -- | Converts an algebraic Core type (split into a TyCon and its argument) to a HWType. mkADT :: (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded Type -> HWType translator

@@ -28,6 +28,7 @@  {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE ViewPatterns      #-}  module CLaSH.Normalize.PrimitiveReductions where @@ -41,6 +42,7 @@ import           CLaSH.Core.DataCon               (DataCon, dataConInstArgTys,                                                    dcName, dcType) import           CLaSH.Core.Literal               (Literal (..))+import           CLaSH.Core.Pretty                (showDoc) import           CLaSH.Core.Term                  (Term (..), Pat (..)) import           CLaSH.Core.Type                  (LitTy (..), Type (..),                                                    TypeView (..), coreView,@@ -70,18 +72,23 @@               -> Term -- ^ The 2nd vector argument               -> NormalizeSession Term reduceZipWith n lhsElTy rhsElTy resElTy fun lhsArg rhsArg = do-  tcm <- Lens.view tcCache-  (TyConApp vecTcNm _) <- coreView tcm <$> termType tcm lhsArg-  let (Just vecTc)     = HashMap.lookup vecTcNm tcm-      [nilCon,consCon] = tyConDataCons vecTc-      (varsL,elemsL)   = second concat . unzip-                       $ extractElems consCon lhsElTy 'L' n lhsArg-      (varsR,elemsR)   = second concat . unzip-                       $ extractElems consCon rhsElTy 'R' n rhsArg-      funApps          = zipWith (\l r -> mkApps fun [Left l,Left r]) varsL varsR-      lbody            = mkVec nilCon consCon resElTy n funApps-      lb               = Letrec (bind (rec (init elemsL ++ init elemsR)) lbody)-  changed lb+    tcm <- Lens.view tcCache+    ty  <- termType tcm lhsArg+    go tcm ty+  where+    go tcm (coreView tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc) <- HashMap.lookup vecTcNm tcm+      , [nilCon,consCon] <- tyConDataCons vecTc+      = let (varsL,elemsL)   = second concat . unzip+                             $ extractElems consCon lhsElTy 'L' n lhsArg+            (varsR,elemsR)   = second concat . unzip+                             $ extractElems consCon rhsElTy 'R' n rhsArg+            funApps          = zipWith (\l r -> mkApps fun [Left l,Left r]) varsL varsR+            lbody            = mkVec nilCon consCon resElTy n funApps+            lb               = Letrec (bind (rec (init elemsL ++ init elemsR)) lbody)+        in  changed lb+    go _ ty = error $ $(curLoc) ++ "reduceZipWith: argument does not have a vector type: " ++ showDoc 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@@ -93,16 +100,21 @@           -> Term -- ^ The map'd over vector           -> NormalizeSession Term reduceMap n argElTy resElTy fun arg = do-  tcm <- Lens.view tcCache-  (TyConApp vecTcNm _) <- coreView tcm <$> termType tcm arg-  let (Just vecTc)     = HashMap.lookup vecTcNm tcm-      [nilCon,consCon] = tyConDataCons vecTc-      (vars,elems)     = second concat . unzip-                       $ extractElems consCon argElTy 'A' n arg-      funApps          = map (fun `App`) vars-      lbody            = mkVec nilCon consCon resElTy n funApps-      lb               = Letrec (bind (rec (init elems)) lbody)-  changed lb+    tcm <- Lens.view tcCache+    ty  <- termType tcm arg+    go tcm ty+  where+    go tcm (coreView tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc)     <- HashMap.lookup vecTcNm tcm+      , [nilCon,consCon] <- tyConDataCons vecTc+      = let (vars,elems)     = second concat . unzip+                             $ extractElems consCon argElTy 'A' n arg+            funApps          = map (fun `App`) vars+            lbody            = mkVec nilCon consCon resElTy n funApps+            lb               = Letrec (bind (rec (init elems)) lbody)+        in  changed lb+    go _ ty = error $ $(curLoc) ++ "reduceMap: argument does not have a vector type: " ++ showDoc 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@@ -114,31 +126,37 @@            -> Term -- ^ The imap'd over vector            -> NormalizeSession Term reduceImap n argElTy resElTy fun arg = do-  tcm <- Lens.view tcCache-  (TyConApp vecTcNm _) <- coreView tcm <$> termType tcm arg-  let (Just vecTc)     = HashMap.lookup vecTcNm tcm-      [nilCon,consCon] = tyConDataCons vecTc-      (vars,elems)     = second concat . unzip-                       $ extractElems consCon argElTy 'I' n arg-  (Right idxTy:_,_) <- splitFunForallTy <$> termType tcm fun-  let (TyConApp idxTcNm _) = tyView idxTy-      nTv              = string2Name "n"-      -- fromInteger# :: KnownNat n => Integer -> Index n-      idxFromIntegerTy = ForAllTy (bind (TyVar nTv (embed typeNatKind))-                                   (foldr mkFunTy-                                          (mkTyConApp idxTcNm-                                                      [VarTy typeNatKind nTv])-                                          [integerPrimTy,integerPrimTy]))-      idxFromInteger   = Prim "CLaSH.Sized.Internal.Index.fromInteger#"-                              idxFromIntegerTy-      idxs             = map (App (App (TyApp idxFromInteger (LitTy (NumTy n)))-                                       (Literal (IntegerLiteral (toInteger n))))-                             . Literal . IntegerLiteral . toInteger) [0..(n-1)]+    tcm <- Lens.view tcCache+    ty  <- termType tcm arg+    go tcm ty+  where+    go tcm (coreView tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc)     <- HashMap.lookup vecTcNm tcm+      , [nilCon,consCon] <- tyConDataCons vecTc+      = do+        let (vars,elems)     = second concat . unzip+                             $ extractElems consCon argElTy 'I' n arg+        (Right idxTy:_,_) <- splitFunForallTy <$> termType tcm fun+        let (TyConApp idxTcNm _) = tyView idxTy+            nTv              = string2Name "n"+            -- fromInteger# :: KnownNat n => Integer -> Index n+            idxFromIntegerTy = ForAllTy (bind (TyVar nTv (embed typeNatKind))+                                         (foldr mkFunTy+                                                (mkTyConApp idxTcNm+                                                            [VarTy typeNatKind nTv])+                                                [integerPrimTy,integerPrimTy]))+            idxFromInteger   = Prim "CLaSH.Sized.Internal.Index.fromInteger#"+                                    idxFromIntegerTy+            idxs             = map (App (App (TyApp idxFromInteger (LitTy (NumTy n)))+                                             (Literal (IntegerLiteral (toInteger n))))+                                   . Literal . IntegerLiteral . toInteger) [0..(n-1)] -      funApps          = zipWith (\i v -> App (App fun i) v) idxs vars-      lbody            = mkVec nilCon consCon resElTy n funApps-      lb               = Letrec (bind (rec (init elems)) lbody)-  changed lb+            funApps          = zipWith (\i v -> App (App fun i) v) idxs vars+            lbody            = mkVec nilCon consCon resElTy n funApps+            lb               = Letrec (bind (rec (init elems)) lbody)+        changed lb+    go _ ty = error $ $(curLoc) ++ "reduceImap: argument does not have a vector type: " ++ showDoc ty  -- | Replace an application of the @CLaSH.Sized.Vector.traverse#@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition"@@ -152,65 +170,70 @@                -> Term -- ^ The argument vector                -> NormalizeSession Term reduceTraverse n aTy fTy bTy dict fun arg = do-  tcm <- Lens.view tcCache-  (TyConApp vecTcNm    _) <- coreView tcm <$> termType tcm arg-  (TyConApp apDictTcNm _) <- coreView tcm <$> termType tcm dict-  let (Just apDictTc)    = HashMap.lookup apDictTcNm tcm-      [apDictCon]        = tyConDataCons apDictTc-      (Just apDictIdTys) = dataConInstArgTys apDictCon [fTy]-      apDictIds          = zipWith Id (map string2Name ["functorDict"-                                                       ,"pure"-                                                       ,"ap"-                                                       ,"apConstL"-                                                       ,"apConstR"])-                                      (map embed apDictIdTys)+    tcm <- Lens.view tcCache+    (TyConApp apDictTcNm _) <- tyView <$> termType tcm dict+    ty <- termType tcm arg+    go tcm apDictTcNm ty+  where+    go tcm apDictTcNm (coreView tcm -> Just ty') = go tcm apDictTcNm ty'+    go tcm apDictTcNm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc) <- HashMap.lookup vecTcNm tcm+      , [nilCon,consCon] <- tyConDataCons vecTc+      = let (Just apDictTc)    = HashMap.lookup apDictTcNm tcm+            [apDictCon]        = tyConDataCons apDictTc+            (Just apDictIdTys) = dataConInstArgTys apDictCon [fTy]+            apDictIds          = zipWith Id (map string2Name ["functorDict"+                                                             ,"pure"+                                                             ,"ap"+                                                             ,"apConstL"+                                                             ,"apConstR"])+                                            (map embed apDictIdTys) -      (TyConApp funcDictTcNm _) = coreView tcm (head apDictIdTys)-      (Just funcDictTc) = HashMap.lookup funcDictTcNm tcm-      [funcDictCon] = tyConDataCons funcDictTc-      (Just funcDictIdTys) = dataConInstArgTys funcDictCon [fTy]-      funcDicIds    = zipWith Id (map string2Name ["fmap","fmapConst"])-                                 (map embed funcDictIdTys)+            (TyConApp funcDictTcNm _) = tyView (head apDictIdTys)+            (Just funcDictTc) = HashMap.lookup funcDictTcNm tcm+            [funcDictCon] = tyConDataCons funcDictTc+            (Just funcDictIdTys) = dataConInstArgTys funcDictCon [fTy]+            funcDicIds    = zipWith Id (map string2Name ["fmap","fmapConst"])+                                       (map embed funcDictIdTys) -      apPat    = DataPat (embed apDictCon) (rebind [] apDictIds)-      fnPat    = DataPat (embed funcDictCon) (rebind [] funcDicIds)+            apPat    = DataPat (embed apDictCon) (rebind [] apDictIds)+            fnPat    = DataPat (embed funcDictCon) (rebind [] funcDicIds) -      -- Extract the 'pure' function from the Applicative dictionary-      pureTy = apDictIdTys!!1-      pureTm = Case dict pureTy [bind apPat (Var pureTy (string2Name "pure"))]+            -- Extract the 'pure' function from the Applicative dictionary+            pureTy = apDictIdTys!!1+            pureTm = Case dict pureTy [bind apPat (Var pureTy (string2Name "pure"))] -      -- Extract the '<*>' function from the Applicative dictionary-      apTy   = apDictIdTys!!2-      apTm   = Case dict apTy [bind apPat (Var apTy (string2Name "ap"))]+            -- Extract the '<*>' function from the Applicative dictionary+            apTy   = apDictIdTys!!2+            apTm   = Case dict apTy [bind apPat (Var apTy (string2Name "ap"))] -      -- Extract the Functor dictionary from the Applicative dictionary-      funcTy = (head apDictIdTys)-      funcTm = Case dict funcTy-                         [bind apPat (Var funcTy (string2Name "functorDict"))]+            -- Extract the Functor dictionary from the Applicative dictionary+            funcTy = (head apDictIdTys)+            funcTm = Case dict funcTy+                               [bind apPat (Var funcTy (string2Name "functorDict"))] -      -- Extract the 'fmap' function from the Functor dictionary-      fmapTy = (head funcDictIdTys)-      fmapTm = Case (Var funcTy (string2Name "functorDict")) fmapTy-                    [bind fnPat (Var fmapTy (string2Name "fmap"))]+            -- Extract the 'fmap' function from the Functor dictionary+            fmapTy = (head funcDictIdTys)+            fmapTm = Case (Var funcTy (string2Name "functorDict")) fmapTy+                          [bind fnPat (Var fmapTy (string2Name "fmap"))] -      (Just vecTc)     = HashMap.lookup vecTcNm tcm-      [nilCon,consCon] = tyConDataCons vecTc-      (vars,elems)     = second concat . unzip-                                       $ extractElems consCon aTy 'T' n arg+            (vars,elems) = second concat . unzip+                         $ extractElems consCon aTy 'T' n arg -      funApps = map (fun `App`) vars+            funApps = map (fun `App`) vars -      lbody   = mkTravVec vecTcNm nilCon consCon (idToVar (apDictIds!!1))-                                                 (idToVar (apDictIds!!2))-                                                 (idToVar (funcDicIds!!0))-                                                 bTy n funApps+            lbody   = mkTravVec vecTcNm nilCon consCon (idToVar (apDictIds!!1))+                                                       (idToVar (apDictIds!!2))+                                                       (idToVar (funcDicIds!!0))+                                                       bTy n funApps -      lb      = Letrec (bind (rec ([((apDictIds!!0),embed funcTm)-                                   ,((apDictIds!!1),embed pureTm)-                                   ,((apDictIds!!2),embed apTm)-                                   ,((funcDicIds!!0),embed fmapTm)-                                   ] ++ init elems)) lbody)-  changed lb+            lb      = Letrec (bind (rec ([((apDictIds!!0),embed funcTm)+                                         ,((apDictIds!!1),embed pureTm)+                                         ,((apDictIds!!2),embed apTm)+                                         ,((funcDicIds!!0),embed fmapTm)+                                         ] ++ init elems)) lbody)+          in  changed lb+    go _ _ ty = error $ $(curLoc) ++ "reduceTraverse: argument does not have a vector type: " ++ showDoc ty  -- | Create the traversable vector --@@ -264,21 +287,25 @@ -- of @CLaSH.Sized.Vector.foldr@ reduceFoldr :: Integer  -- ^ Length of the vector             -> Type -- ^ Element type of the argument vector-            -> Type -- ^ Type of the starting element             -> Term -- ^ The function to fold with             -> Term -- ^ The starting value             -> Term -- ^ The argument vector             -> NormalizeSession Term-reduceFoldr n aTy _bTy fun start arg = do-  tcm <- Lens.view tcCache-  (TyConApp vecTcNm _) <- coreView tcm <$> termType tcm arg-  let (Just vecTc)     = HashMap.lookup vecTcNm tcm-      [_,consCon]      = tyConDataCons vecTc-      (vars,elems)     = second concat . unzip-                       $ extractElems consCon aTy 'G' n arg-      lbody            = foldr (\l r -> mkApps fun [Left l,Left r]) start vars-      lb               = Letrec (bind (rec (init elems)) lbody)-  changed lb+reduceFoldr n aTy fun start arg = do+    tcm <- Lens.view tcCache+    ty  <- termType tcm arg+    go tcm ty+  where+    go tcm (coreView tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc) <- HashMap.lookup vecTcNm tcm+      , [_,consCon] <- tyConDataCons vecTc+      = let (vars,elems)     = second concat . unzip+                             $ extractElems consCon aTy 'G' n arg+            lbody            = foldr (\l r -> mkApps fun [Left l,Left r]) start vars+            lb               = Letrec (bind (rec (init elems)) lbody)+        in  changed lb+    go _ ty = error $ $(curLoc) ++ "reduceFoldr: argument does not have a vector type: " ++ showDoc ty  -- | Replace an application of the @CLaSH.Sized.Vector.fold@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition"@@ -290,15 +317,20 @@            -> NormalizeSession Term reduceFold n aTy fun arg = do     tcm <- Lens.view tcCache-    (TyConApp vecTcNm _) <- coreView tcm <$> termType tcm arg-    let (Just vecTc)     = HashMap.lookup vecTcNm tcm-        [_,consCon]      = tyConDataCons vecTc-        (vars,elems)     = second concat . unzip-                         $ extractElems consCon aTy 'F' n arg-        lbody            = foldV vars-        lb               = Letrec (bind (rec (init elems)) lbody)-    changed lb+    ty  <- termType tcm arg+    go tcm ty   where+    go tcm (coreView tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc) <- HashMap.lookup vecTcNm tcm+      , [_,consCon]  <- tyConDataCons vecTc+      = let (vars,elems)     = second concat . unzip+                             $ extractElems consCon aTy 'F' n arg+            lbody            = foldV vars+            lb               = Letrec (bind (rec (init elems)) lbody)+        in  changed lb+    go _ ty = error $ $(curLoc) ++ "reduceFold: argument does not have a vector type: " ++ showDoc ty+     foldV [a] = a     foldV as  = let (l,r) = splitAt (length as `div` 2) as                     lF    = foldV l@@ -316,33 +348,39 @@             -> NormalizeSession Term reduceDFold n aTy fun start arg = do     tcm <- Lens.view tcCache-    (TyConApp vecTcNm _) <- coreView tcm <$> termType tcm arg-    let (Just vecTc)     = HashMap.lookup vecTcNm tcm-        [_,consCon]      = tyConDataCons vecTc-        (vars,elems)     = second concat . unzip-                         $ extractElems consCon aTy 'D' n arg-    (_ltv:Right snTy:_,_) <- splitFunForallTy <$> termType tcm fun-    let (TyConApp snatTcNm _) = coreView tcm snTy-        (Just snatTc)         = HashMap.lookup snatTcNm tcm-        [snatDc]              = tyConDataCons snatTc+    ty  <- termType tcm arg+    go tcm ty+  where+    go tcm (coreView tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc) <- HashMap.lookup vecTcNm tcm+      , [_,consCon]  <- tyConDataCons vecTc+      = do+        let  (vars,elems)     = second concat . unzip+                             $ extractElems consCon aTy 'D' n arg+        (_ltv:Right snTy:_,_) <- splitFunForallTy <$> termType tcm fun+        let (TyConApp snatTcNm _) = tyView snTy+            (Just snatTc)         = HashMap.lookup snatTcNm tcm+            [snatDc]              = tyConDataCons snatTc -        ([_nTv,_kn,Right pTy],_) = splitFunForallTy (dcType snatDc)-        (TyConApp proxyTcNm _)   = coreView tcm pTy-        (Just proxyTc)           = HashMap.lookup proxyTcNm tcm-        [proxyDc]                = tyConDataCons proxyTc+            ([_nTv,_kn,Right pTy],_) = splitFunForallTy (dcType snatDc)+            (TyConApp proxyTcNm _)   = tyView pTy+            (Just proxyTc)           = HashMap.lookup proxyTcNm tcm+            [proxyDc]                = tyConDataCons proxyTc -        buildSNat i = mkApps (Prim (pack (name2String (dcName snatDc)))-                                   (dcType snatDc))-                             [Right (LitTy (NumTy i))-                             ,Left (Literal (IntegerLiteral (toInteger i)))-                             ,Left (mkApps (Data proxyDc)-                                           [Right typeNatKind-                                           ,Right (LitTy (NumTy i))])-                             ]-        lbody = doFold buildSNat (n-1) vars-        lb    = Letrec (bind (rec (init elems)) lbody)-    changed lb-  where+            buildSNat i = mkApps (Prim (pack (name2String (dcName snatDc)))+                                       (dcType snatDc))+                                 [Right (LitTy (NumTy i))+                                 ,Left (Literal (IntegerLiteral (toInteger i)))+                                 ,Left (mkApps (Data proxyDc)+                                               [Right typeNatKind+                                               ,Right (LitTy (NumTy i))])+                                 ]+            lbody = doFold buildSNat (n-1) vars+            lb    = Letrec (bind (rec (init elems)) lbody)+        changed lb+    go _ ty = error $ $(curLoc) ++ "reduceDFold: argument does not have a vector type: " ++ showDoc ty+     doFold _    _ []     = start     doFold snDc k (x:xs) = mkApps fun                                  [Right (LitTy (NumTy k))@@ -359,14 +397,19 @@            -> Term -- ^ The argument vector            -> NormalizeSession Term reduceHead n aTy vArg = do-  tcm <- Lens.view tcCache-  (TyConApp vecTcNm _) <- coreView tcm <$> termType tcm vArg-  let (Just vecTc)  = HashMap.lookup vecTcNm tcm-      [_,consCon]   = tyConDataCons vecTc-      (vars,elems)  = second concat . unzip-                    $ extractElems consCon aTy 'H' n vArg-      lb = Letrec (bind (rec [head elems]) (head vars))-  changed lb+    tcm <- Lens.view tcCache+    ty  <- termType tcm vArg+    go tcm ty+  where+    go tcm (coreView tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc) <- HashMap.lookup vecTcNm tcm+      , [_,consCon]  <- tyConDataCons vecTc+      = let (vars,elems)  = second concat . unzip+                          $ extractElems consCon aTy 'H' n vArg+            lb = Letrec (bind (rec [head elems]) (head vars))+        in  changed lb+    go _ ty = error $ $(curLoc) ++ "reduceHead: argument does not have a vector type: " ++ showDoc ty  -- | Replace an application of the @CLaSH.Sized.Vector.tail@ primitive on -- vectors of a known length @n@, by a projection of the tail of a@@ -376,15 +419,20 @@            -> Term -- ^ The argument vector            -> NormalizeSession Term reduceTail n aTy vArg = do-  tcm <- Lens.view tcCache-  (TyConApp vecTcNm _) <- coreView tcm <$> termType tcm vArg-  let (Just vecTc) = HashMap.lookup vecTcNm tcm-      [_,consCon]  = tyConDataCons vecTc-      (_,elems)    = second concat . unzip-                   $ extractElems consCon aTy 'L' n vArg-      b@(tB,_)     = elems !! 1-      lb           = Letrec (bind (rec [b]) (idToVar tB))-  changed lb+    tcm <- Lens.view tcCache+    ty  <- termType tcm vArg+    go tcm ty+  where+    go tcm (coreView tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc) <- HashMap.lookup vecTcNm tcm+      , [_,consCon]  <- tyConDataCons vecTc+      = let (_,elems)    = second concat . unzip+                         $ extractElems consCon aTy 'L' n vArg+            b@(tB,_)     = elems !! 1+            lb           = Letrec (bind (rec [b]) (idToVar tB))+        in  changed lb+    go _ ty = error $ $(curLoc) ++ "reduceTail: argument does not have a vector type: " ++ showDoc ty  -- | Replace an application of the @CLaSH.Sized.Vector.(++)@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition"@@ -396,15 +444,20 @@              -> Term -- ^ The RHS argument              -> NormalizeSession Term reduceAppend n m aTy lArg rArg = do-  tcm <- Lens.view tcCache-  (TyConApp vecTcNm _) <- coreView tcm <$> termType tcm lArg-  let (Just vecTc) = HashMap.lookup vecTcNm tcm-      [_,consCon]  = tyConDataCons vecTc-      (vars,elems) = second concat . unzip-                   $ extractElems consCon aTy 'C' n lArg-      lbody        = appendToVec consCon aTy rArg (n+m) vars-      lb           = Letrec (bind (rec (init elems)) lbody)-  changed lb+    tcm <- Lens.view tcCache+    ty  <- termType tcm lArg+    go tcm ty+  where+    go tcm (coreView tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc) <- HashMap.lookup vecTcNm tcm+      , [_,consCon]  <- tyConDataCons vecTc+      = let (vars,elems) = second concat . unzip+                         $ extractElems consCon aTy 'C' n lArg+            lbody        = appendToVec consCon aTy rArg (n+m) vars+            lb           = Letrec (bind (rec (init elems)) lbody)+        in  changed lb+    go _ ty = error $ $(curLoc) ++ "reduceAppend: argument does not have a vector type: " ++ showDoc ty  -- | Replace an application of the @CLaSH.Sized.Vector.unconcat@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition"@@ -415,14 +468,19 @@                -> Term -- ^ Argument vector                -> NormalizeSession Term reduceUnconcat n 0 aTy arg = do-  tcm <- Lens.view tcCache-  (TyConApp vecTcNm _) <- coreView tcm <$> termType tcm arg-  let (Just vecTc)     = HashMap.lookup vecTcNm tcm-      [nilCon,consCon] = tyConDataCons vecTc-      nilVec           = mkVec nilCon consCon aTy 0 []-      innerVecTy       = mkTyConApp vecTcNm [LitTy (NumTy 0), aTy]-      retVec           = mkVec nilCon consCon innerVecTy n (replicate (fromInteger n) nilVec)-  changed retVec+    tcm <- Lens.view tcCache+    ty  <- termType tcm arg+    go tcm ty+  where+    go tcm (coreView tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc)     <- HashMap.lookup vecTcNm tcm+      , [nilCon,consCon] <- tyConDataCons vecTc+      = let nilVec           = mkVec nilCon consCon aTy 0 []+            innerVecTy       = mkTyConApp vecTcNm [LitTy (NumTy 0), aTy]+            retVec           = mkVec nilCon consCon innerVecTy n (replicate (fromInteger n) nilVec)+        in  changed retVec+    go _ ty = error $ $(curLoc) ++ "reduceUnconcat: argument does not have a vector type: " ++ showDoc ty  reduceUnconcat _ _ _ _ = error $ $(curLoc) ++ "reduceUnconcat: unimplemented" @@ -435,14 +493,19 @@                 -> Term -- ^ Argument vector                 -> NormalizeSession Term reduceTranspose n 0 aTy arg = do-  tcm <- Lens.view tcCache-  (TyConApp vecTcNm _) <- coreView tcm <$> termType tcm arg-  let (Just vecTc)     = HashMap.lookup vecTcNm tcm-      [nilCon,consCon] = tyConDataCons vecTc-      nilVec           = mkVec nilCon consCon aTy 0 []-      innerVecTy       = mkTyConApp vecTcNm [LitTy (NumTy 0), aTy]-      retVec           = mkVec nilCon consCon innerVecTy n (replicate (fromInteger n) nilVec)-  changed retVec+    tcm <- Lens.view tcCache+    ty  <- termType tcm arg+    go tcm ty+  where+    go tcm (coreView tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc)     <- HashMap.lookup vecTcNm tcm+      , [nilCon,consCon] <- tyConDataCons vecTc+      = let nilVec           = mkVec nilCon consCon aTy 0 []+            innerVecTy       = mkTyConApp vecTcNm [LitTy (NumTy 0), aTy]+            retVec           = mkVec nilCon consCon innerVecTy n (replicate (fromInteger n) nilVec)+        in  changed retVec+    go _ ty = error $ $(curLoc) ++ "reduceTranspose: argument does not have a vector type: " ++ showDoc ty  reduceTranspose _ _ _ _ = error $ $(curLoc) ++ "reduceTranspose: unimplemented" @@ -452,9 +515,13 @@                 -> Term                 -> NormalizeSession Term reduceReplicate n aTy eTy arg = do-  tcm <- Lens.view tcCache-  let (TyConApp vecTcNm _) = coreView tcm eTy-      (Just vecTc) = HashMap.lookup vecTcNm tcm-      [nilCon,consCon] = tyConDataCons vecTc-      retVec = mkVec nilCon consCon aTy n (replicate (fromInteger n) arg)-  changed retVec+    tcm <- Lens.view tcCache+    go tcm eTy+  where+    go tcm (coreView tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc)     <- HashMap.lookup vecTcNm tcm+      , [nilCon,consCon] <- tyConDataCons vecTc+      = let retVec = mkVec nilCon consCon aTy n (replicate (fromInteger n) arg)+        in  changed retVec+    go _ ty = error $ $(curLoc) ++ "reduceReplicate: argument does not have a vector type: " ++ showDoc ty

@@ -1001,7 +1001,7 @@             untranslatableTys <- mapM isUntranslatableType_not_poly [aTy,bTy]             if or untranslatableTys               then let [fun,start,arg] = Either.lefts args-                   in  reduceFoldr n aTy bTy fun start arg+                   in  reduceFoldr n aTy fun start arg               else return e           _ -> return e       "CLaSH.Sized.Vector.dfold" | length args == 8 ->

@@ -8,6 +8,7 @@  {-# LANGUAGE Rank2Types        #-} {-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE ViewPatterns      #-}  module CLaSH.Rewrite.Util where @@ -44,8 +45,8 @@                                               TmName) import           CLaSH.Core.TyCon            (TyCon, TyConName, tyConDataCons) import           CLaSH.Core.Type             (KindOrType, Type (..),-                                              TypeView (..), transparentTy,-                                              typeKind, coreView)+                                              TypeView (..), coreView,+                                              typeKind, tyView) import           CLaSH.Core.Util             (Delta, Gamma, collectArgs,                                               mkAbstraction, mkApps, mkId,                                               mkLams, mkTmApps, mkTyApps,@@ -77,10 +78,10 @@    Monad.when (lvl > DebugNone && hasChanged) $ do     tcm                  <- Lens.view tcCache-    beforeTy             <- fmap transparentTy $ termType tcm expr+    beforeTy             <- termType tcm expr     let beforeFTV        = Lens.setOf termFreeTyVars expr     beforeFV             <- Lens.setOf <$> localFreeIds <*> pure expr-    afterTy              <- fmap transparentTy $ termType tcm expr'+    afterTy              <- termType tcm expr'     let afterFTV         = Lens.setOf termFreeTyVars expr     afterFV              <- Lens.setOf <$> localFreeIds <*> pure expr'     let newFV = Set.size afterFTV > Set.size beforeFTV ||@@ -491,18 +492,19 @@                -> Int -- n'th field                -> m Term mkSelectorCase caller tcm scrut dcI fieldI = do-  scrutTy <- termType tcm scrut-  let cantCreate loc info = error $ loc ++ "Can't create selector " ++ show (caller,dcI,fieldI) ++ " for: (" ++ showDoc scrut ++ " :: " ++ showDoc scrutTy ++ ")\nAdditional info: " ++ info-  case coreView tcm scrutTy of-    TyConApp tc args ->+    scrutTy <- termType tcm scrut+    go scrutTy+  where+    go (coreView tcm -> Just ty')   = go ty'+    go scrutTy@(tyView -> TyConApp tc args) =       case tyConDataCons (tcm HMS.! tc) of-        [] -> cantCreate $(curLoc) ("TyCon has no DataCons: " ++ show tc ++ " " ++ showDoc tc)-        dcs | dcI > length dcs -> cantCreate $(curLoc) "DC index exceeds max"+        [] -> cantCreate $(curLoc) ("TyCon has no DataCons: " ++ show tc ++ " " ++ showDoc tc) scrutTy+        dcs | dcI > length dcs -> cantCreate $(curLoc) "DC index exceeds max" scrutTy             | otherwise -> do           let dc = indexNote ($(curLoc) ++ "No DC with tag: " ++ show (dcI-1)) dcs (dcI-1)           let (Just fieldTys) = dataConInstArgTys dc args           if fieldI >= length fieldTys-            then cantCreate $(curLoc) "Field index exceed max"+            then cantCreate $(curLoc) "Field index exceed max" scrutTy             else do               wildBndrs <- mapM mkWildValBinder fieldTys               let ty = indexNote ($(curLoc) ++ "No DC field#: " ++ show fieldI) fieldTys fieldI@@ -511,7 +513,9 @@                   pat    = DataPat (embed dc) (rebind [] bndrs)                   retVal = Case scrut ty [ bind pat (snd selBndr) ]               return retVal-    _ -> cantCreate $(curLoc) ("Type of subject is not a datatype: " ++ showDoc scrutTy)+    go scrutTy = cantCreate $(curLoc) ("Type of subject is not a datatype: " ++ showDoc scrutTy) scrutTy++    cantCreate loc info scrutTy = error $ loc ++ "Can't create selector " ++ show (caller,dcI,fieldI) ++ " for: (" ++ showDoc scrut ++ " :: " ++ showDoc scrutTy ++ ")\nAdditional info: " ++ info  -- | Specialise an application on its argument specialise :: Lens' extra (Map.Map (TmName, Int, Either Term Type) (TmName,Type)) -- ^ Lens into previous specialisations