diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -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, diff --git a/src/CLaSH/Core/Type.hs b/src/CLaSH/Core/Type.hs --- a/src/CLaSH/Core/Type.hs +++ b/src/CLaSH/Core/Type.hs @@ -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 diff --git a/src/CLaSH/Core/Util.hs b/src/CLaSH/Core/Util.hs --- a/src/CLaSH/Core/Util.hs +++ b/src/CLaSH/Core/Util.hs @@ -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 diff --git a/src/CLaSH/Netlist/Util.hs b/src/CLaSH/Netlist/Util.hs --- a/src/CLaSH/Netlist/Util.hs +++ b/src/CLaSH/Netlist/Util.hs @@ -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 diff --git a/src/CLaSH/Normalize/PrimitiveReductions.hs b/src/CLaSH/Normalize/PrimitiveReductions.hs --- a/src/CLaSH/Normalize/PrimitiveReductions.hs +++ b/src/CLaSH/Normalize/PrimitiveReductions.hs @@ -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 diff --git a/src/CLaSH/Normalize/Transformations.hs b/src/CLaSH/Normalize/Transformations.hs --- a/src/CLaSH/Normalize/Transformations.hs +++ b/src/CLaSH/Normalize/Transformations.hs @@ -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 -> diff --git a/src/CLaSH/Rewrite/Util.hs b/src/CLaSH/Rewrite/Util.hs --- a/src/CLaSH/Rewrite/Util.hs +++ b/src/CLaSH/Rewrite/Util.hs @@ -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