{-|
  Copyright  :  (C) 2012-2016, University of Twente,
                    2016-2017, Myrtle Software Ltd,
                    2017-2018, Google Inc.,
                    2021-2026, QBayLogic B.V.
  License    :  BSD2 (see the file LICENSE)
  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>

  Transformations for compile-time reduction of expressions / primitives.
-}

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Clash.Normalize.Transformations.Reduce
  ( reduceBinders
  , reduceConst
  , reduceConstWorker
  , reducePrim
  , reducePrimWorker
  ) where

import qualified Control.Lens as Lens
import Control.Monad.Trans.Except (runExcept)
import qualified Data.Either as Either
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List.Extra as List
import qualified Data.Maybe as Maybe
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Text (Text)
import GHC.Stack (HasCallStack)

import Clash.Core.FreeVars (typeFreeVars)
import Clash.Core.HasType
import Clash.Core.Name (nameOcc)
import Clash.Core.Pretty (showPpr)
import Clash.Core.Subst (Subst, extendIdSubst, substTm)
import Clash.Core.Term
  ( CoreContext(..), LetBinding, PrimInfo(..), Term(..), TickInfo(..)
  , WorkInfo(..), collectArgs, collectArgsTicks, mkApps, mkTicks, mkTmApps)
import Clash.Core.TyCon (TyCon(..), TyConMap, tyConDataCons)
import Clash.Core.Type
  (Type, TypeView(..), mkTyConApp, splitFunForallTy, tyView, coreView, normalizeType)
import Clash.Core.Util (mkVec, shouldSplit, tyNatSize, mkInternalVar)
import Clash.Core.VarEnv (extendInScopeSet)
import qualified Clash.Data.UniqMap as UniqMap
import Clash.Normalize.PrimitiveReductions
import Clash.Normalize.Transformations.Specialize (zeroWidthTypeElem)
import Clash.Normalize.Types (NormalizeSession)
import Clash.Normalize.Util (shouldReduce)
import Clash.Rewrite.StrategyDSL (Transformation, onApp, toTransformation)
import Clash.Rewrite.Types (TransformContext(..), tcCache, normalizeUltra)
import Clash.Rewrite.Util (changed, isUntranslatableType, setChanged, whnfRW)
import qualified Clash.Sized.Internal.BitVector
import qualified Clash.Sized.RTree
import qualified Clash.Sized.Vector
import Clash.Util (textNameLit)

-- | XXX: is given inverse topologically sorted binders, but returns
-- topologically sorted binders
--
-- TODO: check further speed improvements:
--
-- 1. Store the processed binders in a `Map Expr LetBinding`:
--    * Trades O(1) `cons` and O(n)*aeqTerm `find` for:
--    * O(log n)*aeqTerm `insert` and O(log n)*aeqTerm `lookup`
-- 2. Store the processed binders in a `AEQTrie Expr LetBinding`
--    * Trades O(1) `cons` and O(n)*aeqTerm `find` for:
--    * O(e) `insert` and O(e) `lookup`
reduceBinders
  :: Subst
  -> [LetBinding]
  -> [LetBinding]
  -> NormalizeSession (Subst, [LetBinding])
reduceBinders :: Subst
-> [LetBinding]
-> [LetBinding]
-> NormalizeSession (Subst, [LetBinding])
reduceBinders !Subst
subst [LetBinding]
processed [] = (Subst, [LetBinding]) -> NormalizeSession (Subst, [LetBinding])
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Subst
subst,[LetBinding]
processed)
reduceBinders !Subst
subst [LetBinding]
processed ((Id
i,HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"reduceBinders" Subst
subst -> Term
e):[LetBinding]
rest)
  | (Term
_,[Either Term Type]
_,[TickInfo]
ticks) <- Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks Term
e
  , TickInfo
NoDeDup TickInfo -> [TickInfo] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`notElem` [TickInfo]
ticks
  , Just (Id
i1,Term
_) <- (LetBinding -> Bool) -> [LetBinding] -> Maybe LetBinding
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
List.find ((Term -> Term -> Bool
forall a. Eq a => a -> a -> Bool
== Term
e) (Term -> Bool) -> (LetBinding -> Term) -> LetBinding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Term
forall a b. (a, b) -> b
snd) [LetBinding]
processed
  = do
    let subst1 :: Subst
subst1 = Subst -> Id -> Term -> Subst
extendIdSubst Subst
subst Id
i (Id -> Term
Var Id
i1)
    RewriteMonad NormalizeState ()
forall extra. RewriteMonad extra ()
setChanged
    Subst
-> [LetBinding]
-> [LetBinding]
-> NormalizeSession (Subst, [LetBinding])
reduceBinders Subst
subst1 [LetBinding]
processed [LetBinding]
rest
  | Bool
otherwise
  = Subst
-> [LetBinding]
-> [LetBinding]
-> NormalizeSession (Subst, [LetBinding])
reduceBinders Subst
subst ((Id
i,Term
e)LetBinding -> [LetBinding] -> [LetBinding]
forall a. a -> [a] -> [a]
:[LetBinding]
processed) [LetBinding]
rest
{-# SCC reduceBinders #-}

reduceConst :: Transformation
reduceConst :: Transformation
reduceConst = [Char] -> [TransformationWorker] -> Transformation
toTransformation [Char]
"reduceConst" (Name -> [TransformationWorker]
onApp 'reduceConstWorker)

-- | The 'App' handler of 'reduceConst'.
reduceConstWorker
  :: HasCallStack
  => TransformContext -> Term -> Term -> Term -> NormalizeSession Term
-- An 'App' in an 'AppFun' context is an inner node of an application spine,
-- e.g. the @f a@ inside @f a b c@. Only evaluate at the root (@f a b c@):
-- an under-applied primitive cannot fold, and if @f@ is itself an application
-- (@(g x) a b c@) the evaluator reduces the whole thing to WHNF anyway, so it
-- folds @g x@ as part of folding the root. Skip the evaluator call here.
reduceConstWorker :: HasCallStack =>
TransformContext -> Term -> Term -> Term -> NormalizeSession Term
reduceConstWorker (TransformContext InScopeSet
_ (CoreContext
AppFun:[CoreContext]
_)) Term
e Term
_appFunction Term
_appArgument = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
reduceConstWorker TransformContext
ctx Term
e Term
_appFunction Term
_appArgument
  | (Prim PrimInfo
p0, [Either Term Type]
_) <- Term -> (Term, [Either Term Type])
collectArgs Term
e
  = Bool
-> TransformContext
-> Term
-> Rewrite NormalizeState
-> NormalizeSession Term
forall extra.
Bool
-> TransformContext
-> Term
-> Rewrite extra
-> RewriteMonad extra Term
whnfRW Bool
False TransformContext
ctx Term
e (Rewrite NormalizeState -> NormalizeSession Term)
-> Rewrite NormalizeState -> NormalizeSession Term
forall a b. (a -> b) -> a -> b
$ \TransformContext
_ctx1 Term
e1 -> case Term
e1 of
      (Term -> (Term, [Either Term Type])
collectArgs -> (Prim PrimInfo
p1, [Either Term Type]
_)) | PrimInfo -> Text
primName PrimInfo
p0 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== PrimInfo -> Text
primName PrimInfo
p1 -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Term
_ -> Term -> NormalizeSession Term
forall a extra. a -> RewriteMonad extra a
changed Term
e1

reduceConstWorker TransformContext
_ Term
e Term
_ Term
_ = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
{-# SCC reduceConstWorker #-}

-- | Replace primitives by their "definition" if they would lead to let-bindings
-- with a non-representable type when a function is in ANF. This happens for
-- example when Clash.Size.Vector.map consumes or produces a vector of
-- non-representable elements.
--
-- This transformation used to be called @reduceNonRepPrim@, but nowadays it
-- also replaces primitives for other reasons: e.g., because they are applied
-- to short vectors, because they occur in a context that should be reduced
-- (see 'shouldReduce'), or because @-fclash-ultra@ is enabled. The conditions
-- differ per primitive, see the handlers in 'reducePrimImpls'.
--
-- Basically what this transformation does is replace a primitive the completely
-- unrolled recursive definition that it represents. e.g.
--
-- > zipWith ($) (xs :: Vec 2 (Int -> Int)) (ys :: Vec 2 Int)
--
-- is replaced by:
--
-- > let (x0  :: (Int -> Int))       = case xs  of (:>) _ x xr -> x
-- >     (xr0 :: Vec 1 (Int -> Int)) = case xs  of (:>) _ x xr -> xr
-- >     (x1  :: (Int -> Int)(       = case xr0 of (:>) _ x xr -> x
-- >     (y0  :: Int)                = case ys  of (:>) _ y yr -> y
-- >     (yr0 :: Vec 1 Int)          = case ys  of (:>) _ y yr -> xr
-- >     (y1  :: Int                 = case yr0 of (:>) _ y yr -> y
-- > in  (($) x0 y0 :> ($) x1 y1 :> Nil)
--
-- Currently, it only handles the functions in 'reducePrimImpls'.
--
-- Note [Unroll shouldSplit types]
-- 1. Certain higher-order functions over Vec, such as map, have specialized
-- code-paths to turn them into generate-for loops in HDL, instead of having to
-- having to unroll/inline their recursive definitions, e.g. Clash.Sized.Vector.map
--
-- 2. Clash, in general, translates Haskell product types to VHDL records. This
-- mostly works out fine, there is however one exception: certain synthesis
-- tools, and some HDL simulation tools (like verilator), do not like it when
-- the clock (and certain other global control signals) is contained in a
-- record type; they want them to be separate inputs to the entity/module.
-- And Clash actually does some transformations to try to ensure that values of
-- type Clock do not end up in a VHDL record type.
--
-- The problem is that the transformations in 2. never took into account the
-- specialized code-paths in 1. Making the code-paths in 1. aware of the
-- transformations in 2. is really not worth the effort for such a niche case.
-- It's easier to just unroll the recursive definitions.
--
-- See https://github.com/clash-lang/clash-compiler/issues/1606
reducePrim :: Transformation
reducePrim :: Transformation
reducePrim =
  [Char] -> [TransformationWorker] -> Transformation
toTransformation [Char]
"reducePrim" (Name -> [TransformationWorker]
onApp 'reducePrimWorker)

-- | The 'Clash.Core.Term.App' handler of 'reducePrim'.
reducePrimWorker
  :: HasCallStack
  => TransformContext -> Term -> Term -> Term -> NormalizeSession Term
-- Only consider the root of an application spine (see 'reduceConst'): the root
-- sees all arguments, and the @Vec 0@-to-@Nil@ rewrite below is only
-- type-correct at the root, where no more arguments follow.
reducePrimWorker :: HasCallStack =>
TransformContext -> Term -> Term -> Term -> NormalizeSession Term
reducePrimWorker (TransformContext InScopeSet
_ (CoreContext
AppFun:[CoreContext]
_)) Term
e Term
_appFunction Term
_appArgument = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
reducePrimWorker TransformContext
c Term
e Term
_appFunction Term
_appArgument
  | (Prim PrimInfo
p, [Either Term Type]
args, [TickInfo]
ticks) <- Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks Term
e
  = do
    TyConMap
tcm <- Getting TyConMap RewriteEnv TyConMap
-> RewriteMonad NormalizeState TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap RewriteEnv TyConMap
Getter RewriteEnv TyConMap
tcCache
    let handlerM :: Maybe ReducePrimHandler
handlerM = Text -> HashMap Text ReducePrimHandler -> Maybe ReducePrimHandler
forall k v. Hashable k => k -> HashMap k v -> Maybe v
HashMap.lookup (PrimInfo -> Text
primName PrimInfo
p) HashMap Text ReducePrimHandler
reducePrimImpls
    -- Every primitive whose result type is @Vec 0 a@ reduces to @Nil@, not
    -- just the ones with a handler. That takes the type of the applied
    -- primitive, which is expensive to infer, so for a primitive without a
    -- handler it is only inferred when the primitive's declared type shows a
    -- @Vec@ result is possible at all. That rules out the vast majority of
    -- them.
    if Maybe ReducePrimHandler -> Bool
forall a. Maybe a -> Bool
Maybe.isNothing Maybe ReducePrimHandler
handlerM Bool -> Bool -> Bool
&& Bool -> Bool
not (TyConMap -> Type -> Bool
mayReturnVec TyConMap
tcm (PrimInfo -> Type
primType PrimInfo
p))
    then Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
    else do
      let eTy :: Type
eTy = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
e
      let ([Either TyVar Type]
remainingArgTys, Type
resTy) = Type -> ([Either TyVar Type], Type)
splitFunForallTy Type
eTy
      let tv :: TypeView
tv = Type -> TypeView
tyView (TyConMap -> Type -> Type
coreView TyConMap
tcm Type
resTy)
      case TyConMap -> TypeView -> Maybe Term
zeroLengthVecTerm TyConMap
tcm TypeView
tv of
        -- Only replace the whole application by @Nil@ if the primitive is
        -- fully applied (a partially applied primitive has a function type,
        -- so replacing it by @Nil@ would change its arity) and if it does
        -- not always perform work (e.g. blackboxes like an VIO must be
        -- rendered even if their result is zero-width).
        Just Term
nilE
          | [Either TyVar Type] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Either TyVar Type]
remainingArgTys
          , PrimInfo -> WorkInfo
primWorkInfo PrimInfo
p WorkInfo -> WorkInfo -> Bool
forall a. Eq a => a -> a -> Bool
/= WorkInfo
WorkAlways
          -> Term -> NormalizeSession Term
forall a extra. a -> RewriteMonad extra a
changed (Term -> [TickInfo] -> Term
mkTicks Term
nilE [TickInfo]
ticks)
        Maybe Term
_ -> case Maybe ReducePrimHandler
handlerM of
          Maybe ReducePrimHandler
Nothing -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          Just ReducePrimHandler
handler -> do
            Bool
ultraArg <- Getting Bool RewriteEnv Bool -> RewriteMonad NormalizeState Bool
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting Bool RewriteEnv Bool
Getter RewriteEnv Bool
normalizeUltra
            ReducePrimHandler
handler ReducePrimContext
              { transformContext :: TransformContext
transformContext = TransformContext
c
              , originalTerm :: Term
originalTerm = Term
e
              , primInfo :: PrimInfo
primInfo = PrimInfo
p
              , primArguments :: [Either Term Type]
primArguments = [Either Term Type]
args
              , primTicks :: [TickInfo]
primTicks = [TickInfo]
ticks
              , tyConMap :: TyConMap
tyConMap = TyConMap
tcm
              , ultra :: Bool
ultra = Bool
ultraArg
              , termType :: Type
termType = Type
eTy
              , resultType :: Type
resultType = Type
resTy
              , resultTypeView :: TypeView
resultTypeView = TypeView
tv
              }

reducePrimWorker TransformContext
_ Term
e Term
_ Term
_ = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
{-# SCC reducePrimWorker #-}

-- | The name of the 'Clash.Sized.Vector.Vec' type constructor.
vecTcName :: Text
vecTcName :: Text
vecTcName = $(textNameLit ''Clash.Sized.Vector.Vec)

-- | If the given type view is @Vec 0 a@, return the corresponding @Nil@ term.
zeroLengthVecTerm :: TyConMap -> TypeView -> Maybe Term
zeroLengthVecTerm :: TyConMap -> TypeView -> Maybe Term
zeroLengthVecTerm TyConMap
tcm TypeView
tv
  | TyConApp TyConName
vecTcNm [Type
nTy, Type
aTy] <- TypeView
tv
  , TyConName -> Text
forall a. Name a -> Text
nameOcc TyConName
vecTcNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
vecTcName
  , Right Integer
0 <- Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tcm Type
nTy)
  = Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term) -> Term -> Maybe Term
forall a b. (a -> b) -> a -> b
$ Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Term
forall a. HasCallStack => [Char] -> a
error [Char]
"reducePrim: unable to create Vec DCs") (Maybe Term -> Term) -> Maybe Term -> Term
forall a b. (a -> b) -> a -> b
$ do
      TyCon
vecTc <- TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
UniqMap.lookup TyConName
vecTcNm TyConMap
tcm
      [DataCon
nilCon,DataCon
consCon] <- [DataCon] -> Maybe [DataCon]
forall a. a -> Maybe a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TyCon -> [DataCon]
tyConDataCons TyCon
vecTc)
      Term -> Maybe Term
forall a. a -> Maybe a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (DataCon -> DataCon -> Type -> Integer -> [Term] -> Term
mkVec DataCon
nilCon DataCon
consCon Type
aTy Integer
0 [])
  | Bool
otherwise
  = Maybe Term
forall a. Maybe a
Nothing

-- | Can applying the primitive produce a value whose type has
-- 'Clash.Sized.Vector.Vec' at its head? This is decided from the primitive's
-- declared type, which is readily available, rather than from the type of the
-- applied primitive, which has to be inferred.
--
-- A result headed by a concrete type constructor other than @Vec@ can never
-- instantiate to a @Vec@. Everything else -- type variables, type families,
-- type constructors we know nothing about -- might, and yields 'True'.
-- Over-approximating is sound: a 'True' only makes 'reducePrim' infer
-- the type of the applied primitive and ask 'zeroLengthVecTerm' for a verdict.
mayReturnVec :: TyConMap -> Type -> Bool
mayReturnVec :: TyConMap -> Type -> Bool
mayReturnVec TyConMap
tcm Type
ty = case Type -> TypeView
tyView (([Either TyVar Type], Type) -> Type
forall a b. (a, b) -> b
snd (Type -> ([Either TyVar Type], Type)
splitFunForallTy Type
ty)) of
  TyConApp TyConName
tcNm [Type]
_
    | TyConName -> Text
forall a. Name a -> Text
nameOcc TyConName
tcNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
vecTcName -> Bool
True
    | Bool
otherwise -> case TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
UniqMap.lookup TyConName
tcNm TyConMap
tcm of
        -- Type families might reduce to a 'Vec'
        Just FunTyCon{} -> Bool
True
        Just TyCon
_ -> Bool
False
        Maybe TyCon
Nothing -> Bool
True
  TypeView
_ -> Bool
True

-- | Everything the handlers in 'reducePrimImpls' receive from the
-- dispatch site in 'reducePrim'.
data ReducePrimContext = ReducePrimContext
  { ReducePrimContext -> TransformContext
transformContext :: TransformContext
  , ReducePrimContext -> Term
originalTerm :: Term
    -- ^ The primitive applied to its arguments
  , ReducePrimContext -> PrimInfo
primInfo :: PrimInfo
  , ReducePrimContext -> [Either Term Type]
primArguments :: [Either Term Type]
  , ReducePrimContext -> [TickInfo]
primTicks :: [TickInfo]
  , ReducePrimContext -> TyConMap
tyConMap :: TyConMap
  , ReducePrimContext -> Bool
ultra :: Bool
    -- ^ Whether @-fclash-ultra@ is enabled
  , ReducePrimContext -> Type
termType :: Type
    -- ^ The type of 'originalTerm'
  , ReducePrimContext -> Type
resultType :: Type
    -- ^ 'termType' stripped of its quantifiers and function arguments
  , ReducePrimContext -> TypeView
resultTypeView :: TypeView
    -- ^ 'tyView' of 'resultType'
  }

-- | A handler for a specific primitive in 'reducePrimImpls'.
type ReducePrimHandler
  = ReducePrimContext -> NormalizeSession Term

-- | The primitives 'reducePrim' can reduce, keyed on primitive
-- name. The handlers are the arms of the @case@ expression this map replaced;
-- a handler whose guards do not apply returns 'originalTerm' unchanged, like
-- the fall-through of the @case@ did.
reducePrimImpls :: HashMap Text ReducePrimHandler
reducePrimImpls :: HashMap Text ReducePrimHandler
reducePrimImpls = [(Text, ReducePrimHandler)] -> HashMap Text ReducePrimHandler
forall k v. Hashable k => [(k, v)] -> HashMap k v
HashMap.fromList
  [ ($(textNameLit 'Clash.Sized.Vector.zipWith), ReducePrimHandler
reduceZipWithHandler)
  , ($(textNameLit 'Clash.Sized.Vector.map), ReducePrimHandler
reduceMapHandler)
  , ($(textNameLit 'Clash.Sized.Vector.traverse#), ReducePrimHandler
reduceTraverseHandler)
  , ($(textNameLit 'Clash.Sized.Vector.fold), ReducePrimHandler
reduceFoldHandler)
  , ($(textNameLit 'Clash.Sized.Vector.foldr), ReducePrimHandler
reduceFoldrHandler)
  , ($(textNameLit 'Clash.Sized.Vector.dfold), ReducePrimHandler
reduceDFoldHandler)
  , ($(textNameLit '(Clash.Sized.Vector.++)), ReducePrimHandler
reduceAppendHandler)
  , ($(textNameLit 'Clash.Sized.Vector.head), ReducePrimHandler
reduceHeadHandler)
  , ($(textNameLit 'Clash.Sized.Vector.tail), ReducePrimHandler
reduceTailHandler)
  , ($(textNameLit 'Clash.Sized.Vector.last), ReducePrimHandler
reduceLastHandler)
  , ($(textNameLit 'Clash.Sized.Vector.init), ReducePrimHandler
reduceInitHandler)
  , ($(textNameLit 'Clash.Sized.Vector.unconcat), ReducePrimHandler
reduceUnconcatHandler)
  , ($(textNameLit 'Clash.Sized.Vector.transpose), ReducePrimHandler
reduceTransposeHandler)
  , ($(textNameLit 'Clash.Sized.Vector.replicate), ReducePrimHandler
reduceReplicateHandler)
  -- replace_int and index_int are not exported from Clash.Sized.Vector, so
  -- their names cannot be quoted
  , (Text
"Clash.Sized.Vector.replace_int", ReducePrimHandler
reduceReplaceIntHandler)
  , (Text
"Clash.Sized.Vector.index_int", ReducePrimHandler
reduceIndexIntHandler)
  , ($(textNameLit 'Clash.Sized.Vector.imap), ReducePrimHandler
reduceImapHandler)
  , ($(textNameLit 'Clash.Sized.Vector.iterateI), ReducePrimHandler
reduceIterateIHandler)
  , ($(textNameLit 'Clash.Sized.Vector.dtfold), ReducePrimHandler
reduceDTFoldHandler)
  , ($(textNameLit 'Clash.Sized.Vector.reverse), ReducePrimHandler
reduceReverseHandler)
  , ($(textNameLit 'Clash.Sized.RTree.tdfold), ReducePrimHandler
reduceTDFoldHandler)
  , ($(textNameLit 'Clash.Sized.RTree.treplicate), ReducePrimHandler
reduceTReplicateHandler)
  , ($(textNameLit 'Clash.Sized.Internal.BitVector.split#), ReducePrimHandler
reduceSplitHandler)
  , ($(textNameLit 'Clash.Sized.Internal.BitVector.eq#), ReducePrimHandler
reduceEqHandler)
  ]

reduceZipWithHandler :: ReducePrimHandler
reduceZipWithHandler :: ReducePrimHandler
reduceZipWithHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
lhsElTy,Type
rhsElty,Type
resElTy,Type
nTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  , TyConApp TyConName
vecTcNm [Type]
_ <- TypeView
resultTypeView
  , let lhsTy :: Type
lhsTy = TyConName -> [Type] -> Type
mkTyConApp TyConName
vecTcNm [Type
nTy,Type
lhsElTy]
  , let rhsTy :: Type
rhsTy = TyConName -> [Type] -> Type
mkTyConApp TyConName
vecTcNm [Type
nTy,Type
rhsElty]
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> do
        Bool
lhsNonRep <- Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
lhsElTy
        Bool
rhsNonRep <- Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
rhsElty
        Bool
resNonRep <- Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
resElTy
        Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Bool
ultra Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
2)
                             , [CoreContext] -> RewriteMonad NormalizeState Bool
shouldReduce (TransformContext -> [CoreContext]
tfContext TransformContext
transformContext)
                             , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Bool
lhsNonRep Bool -> Bool -> Bool
|| Bool
rhsNonRep Bool -> Bool -> Bool
|| Bool
resNonRep)
                             -- Note [Unroll shouldSplit types]
                             , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Type -> Bool) -> [Type] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (Maybe ([Term] -> Term, Projections, [Type]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (Maybe ([Term] -> Term, Projections, [Type]) -> Bool)
-> (Type -> Maybe ([Term] -> Term, Projections, [Type]))
-> Type
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> Type -> Maybe ([Term] -> Term, Projections, [Type])
shouldSplit TyConMap
tyConMap)
                                         [Type
lhsTy,Type
rhsTy,Type
resultType]) ]
        if Bool
shouldReduce1
           then [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term
    -> Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                  (PrimInfo
-> Integer
-> Type
-> Type
-> Type
-> Bool
-> Bool
-> Term
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceZipWith PrimInfo
primInfo Integer
n Type
lhsElTy Type
rhsElty Type
resElTy
                     (Bool -> Bool
not Bool
lhsNonRep) (Bool -> Bool
not Bool
rhsNonRep))
           else Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: zipWith bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceMapHandler :: ReducePrimHandler
reduceMapHandler :: ReducePrimHandler
reduceMapHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
argElTy,Type
resElTy,Type
nTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  , TyConApp TyConName
vecTcNm [Type]
_ <- TypeView
resultTypeView
  , let argTy :: Type
argTy = TyConName -> [Type] -> Type
mkTyConApp TyConName
vecTcNm [Type
nTy,Type
argElTy]
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> do
        Bool
argNonRep <- Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
argElTy
        Bool
resNonRep <- Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
resElTy
        Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Bool
ultra Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
2 )
                             , [CoreContext] -> RewriteMonad NormalizeState Bool
shouldReduce (TransformContext -> [CoreContext]
tfContext TransformContext
transformContext)
                             , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Bool
argNonRep Bool -> Bool -> Bool
|| Bool
resNonRep)
                             -- Note [Unroll shouldSplit types]
                             , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Type -> Bool) -> [Type] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (Maybe ([Term] -> Term, Projections, [Type]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (Maybe ([Term] -> Term, Projections, [Type]) -> Bool)
-> (Type -> Maybe ([Term] -> Term, Projections, [Type]))
-> Type
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> Type -> Maybe ([Term] -> Term, Projections, [Type])
shouldSplit TyConMap
tyConMap)
                                         [Type
argTy,Type
resultType]) ]
        if Bool
shouldReduce1
           then [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                  (PrimInfo
-> Integer
-> Type
-> Type
-> Bool
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceMap PrimInfo
primInfo Integer
n Type
argElTy Type
resElTy (Bool -> Bool
not Bool
argNonRep))
           else Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: map bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceTraverseHandler :: ReducePrimHandler
reduceTraverseHandler :: ReducePrimHandler
reduceTraverseHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
aTy,Type
fTy,Type
bTy,Type
nTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term
    -> Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                   (Integer
-> Type
-> Type
-> Type
-> Term
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceTraverse Integer
n Type
aTy Type
fTy Type
bTy)
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: traverse# bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceFoldHandler :: ReducePrimHandler
reduceFoldHandler :: ReducePrimHandler
reduceFoldHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
nTy,Type
aTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  , (Either TyVar Type
_:Right Type
argTy:[Either TyVar Type]
_) <- ([Either TyVar Type], Type) -> [Either TyVar Type]
forall a b. (a, b) -> a
fst (Type -> ([Either TyVar Type], Type)
splitFunForallTy (HasCallStack => TyConMap -> Type -> [Type] -> Type
TyConMap -> Type -> [Type] -> Type
piResultTys TyConMap
tyConMap (PrimInfo -> Type
primType PrimInfo
primInfo) [Type
nTy,Type
aTy]))
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> do
        Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Bool
ultra Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0)
                             , [CoreContext] -> RewriteMonad NormalizeState Bool
shouldReduce (TransformContext -> [CoreContext]
tfContext TransformContext
transformContext)
                             , Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
aTy
                             -- Note [Unroll shouldSplit types]
                             , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Type]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Type -> Maybe ([Term] -> Term, Projections, [Type])
shouldSplit TyConMap
tyConMap Type
argTy))]
        if Bool
shouldReduce1 then
          [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
            (Integer
-> Type
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceFold (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Type
aTy)
        else Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: fold bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceFoldrHandler :: ReducePrimHandler
reduceFoldrHandler :: ReducePrimHandler
reduceFoldrHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
aTy,Type
bTy,Type
nTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  , (Either TyVar Type
_:Either TyVar Type
_:Right Type
argTy:[Either TyVar Type]
_) <- ([Either TyVar Type], Type) -> [Either TyVar Type]
forall a b. (a, b) -> a
fst (Type -> ([Either TyVar Type], Type)
splitFunForallTy (HasCallStack => TyConMap -> Type -> [Type] -> Type
TyConMap -> Type -> [Type] -> Type
piResultTys TyConMap
tyConMap (PrimInfo -> Type
primType PrimInfo
primInfo) [Type
aTy,Type
bTy,Type
nTy]))
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> do
        Bool
aNonRep <- Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
aTy
        Bool
bNonRep <- Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
bTy
        Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
ultra
                             , [CoreContext] -> RewriteMonad NormalizeState Bool
shouldReduce (TransformContext -> [CoreContext]
tfContext TransformContext
transformContext)
                             , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Bool
aNonRep Bool -> Bool -> Bool
|| Bool
bNonRep)
                             -- Note [Unroll shouldSplit types]
                             , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Type]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Type -> Maybe ([Term] -> Term, Projections, [Type])
shouldSplit TyConMap
tyConMap Type
argTy)) ]
        if Bool
shouldReduce1
          then [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term
    -> Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                 (PrimInfo
-> Integer
-> Type
-> Bool
-> Term
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceFoldr PrimInfo
primInfo Integer
n Type
aTy (Bool -> Bool
not Bool
aNonRep))
          else Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: foldr bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceDFoldHandler :: ReducePrimHandler
reduceDFoldHandler :: ReducePrimHandler
reduceDFoldHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
_mTy,Type
nTy,Type
aTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term
    -> Term
    -> Term
    -> Term
    -> Term
    -> TransformContext
    -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                   (Integer
-> Type
-> Term
-> Term
-> Term
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceDFold Integer
n Type
aTy)
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: dfold bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceAppendHandler :: ReducePrimHandler
reduceAppendHandler :: ReducePrimHandler
reduceAppendHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
nTy,Type
aTy,Type
mTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  = case (Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy), Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
mTy)) of
      (Right Integer
n, Right Integer
m) -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Integer
nInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
0)
                                 , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Integer
mInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
0)
                                 , [CoreContext] -> RewriteMonad NormalizeState Bool
shouldReduce (TransformContext -> [CoreContext]
tfContext TransformContext
transformContext)
                                 , Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
aTy
                                 -- Note [Unroll shouldSplit types]
                                 , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Type]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Type -> Maybe ([Term] -> Term, Projections, [Type])
shouldSplit TyConMap
tyConMap Type
resultType)) ]
            if Bool
shouldReduce1
               then [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                      (Integer
-> Integer
-> Type
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceAppend Integer
n Integer
m Type
aTy)
               else Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
      (Either [Char] Integer, Either [Char] Integer)
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: ++ bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceHeadHandler :: ReducePrimHandler
reduceHeadHandler :: ReducePrimHandler
reduceHeadHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
nTy,Type
aTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  , (Right Type
argTy:[Either TyVar Type]
_) <- ([Either TyVar Type], Type) -> [Either TyVar Type]
forall a b. (a, b) -> a
fst (Type -> ([Either TyVar Type], Type)
splitFunForallTy (HasCallStack => TyConMap -> Type -> [Type] -> Type
TyConMap -> Type -> [Type] -> Type
piResultTys TyConMap
tyConMap (PrimInfo -> Type
primType PrimInfo
primInfo) [Type
nTy,Type
aTy]))
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> do
        Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ [CoreContext] -> RewriteMonad NormalizeState Bool
shouldReduce (TransformContext -> [CoreContext]
tfContext TransformContext
transformContext)
                             , Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
aTy
                             -- Note [Unroll shouldSplit types]
                             , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Type]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Type -> Maybe ([Term] -> Term, Projections, [Type])
shouldSplit TyConMap
tyConMap Type
argTy)) ]
        if Bool
shouldReduce1
           then [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                  (Integer
-> Type -> Term -> TransformContext -> NormalizeSession Term
reduceHead (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) Type
aTy)
           else Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: head bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceTailHandler :: ReducePrimHandler
reduceTailHandler :: ReducePrimHandler
reduceTailHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
nTy,Type
aTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  , (Right Type
argTy:[Either TyVar Type]
_) <- ([Either TyVar Type], Type) -> [Either TyVar Type]
forall a b. (a, b) -> a
fst (Type -> ([Either TyVar Type], Type)
splitFunForallTy (HasCallStack => TyConMap -> Type -> [Type] -> Type
TyConMap -> Type -> [Type] -> Type
piResultTys TyConMap
tyConMap (PrimInfo -> Type
primType PrimInfo
primInfo) [Type
nTy,Type
aTy]))
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> do
        Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ [CoreContext] -> RewriteMonad NormalizeState Bool
shouldReduce (TransformContext -> [CoreContext]
tfContext TransformContext
transformContext)
                             , Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
aTy
                             -- Note [Unroll shouldSplit types]
                             , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Type]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Type -> Maybe ([Term] -> Term, Projections, [Type])
shouldSplit TyConMap
tyConMap Type
argTy)) ]
        if Bool
shouldReduce1
           then [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                  (Integer
-> Type -> Term -> TransformContext -> NormalizeSession Term
reduceTail (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) Type
aTy)
           else Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: tail bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceLastHandler :: ReducePrimHandler
reduceLastHandler :: ReducePrimHandler
reduceLastHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
nTy,Type
aTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  , (Right Type
argTy:[Either TyVar Type]
_) <- ([Either TyVar Type], Type) -> [Either TyVar Type]
forall a b. (a, b) -> a
fst (Type -> ([Either TyVar Type], Type)
splitFunForallTy (HasCallStack => TyConMap -> Type -> [Type] -> Type
TyConMap -> Type -> [Type] -> Type
piResultTys TyConMap
tyConMap (PrimInfo -> Type
primType PrimInfo
primInfo) [Type
nTy,Type
aTy]))
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> do
        Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ [CoreContext] -> RewriteMonad NormalizeState Bool
shouldReduce (TransformContext -> [CoreContext]
tfContext TransformContext
transformContext)
                             , Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
aTy
                             -- Note [Unroll shouldSplit types]
                             , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Type]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Type -> Maybe ([Term] -> Term, Projections, [Type])
shouldSplit TyConMap
tyConMap Type
argTy))
                             ]
        if Bool
shouldReduce1
           then [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                  (Integer
-> Type -> Term -> TransformContext -> NormalizeSession Term
reduceLast (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) Type
aTy)
           else Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: last bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceInitHandler :: ReducePrimHandler
reduceInitHandler :: ReducePrimHandler
reduceInitHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
nTy,Type
aTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  , (Right Type
argTy:[Either TyVar Type]
_) <- ([Either TyVar Type], Type) -> [Either TyVar Type]
forall a b. (a, b) -> a
fst (Type -> ([Either TyVar Type], Type)
splitFunForallTy (HasCallStack => TyConMap -> Type -> [Type] -> Type
TyConMap -> Type -> [Type] -> Type
piResultTys TyConMap
tyConMap (PrimInfo -> Type
primType PrimInfo
primInfo) [Type
nTy,Type
aTy]))
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> do
        Bool
aNonRep <- Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
aTy
        Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ [CoreContext] -> RewriteMonad NormalizeState Bool
shouldReduce (TransformContext -> [CoreContext]
tfContext TransformContext
transformContext)
                             , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
aNonRep
                             -- Note [Unroll shouldSplit types]
                             , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Type]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Type -> Maybe ([Term] -> Term, Projections, [Type])
shouldSplit TyConMap
tyConMap Type
argTy)) ]
        if Bool
shouldReduce1
           then [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                  (PrimInfo
-> Integer
-> Type
-> Bool
-> Term
-> TransformContext
-> NormalizeSession Term
reduceInit PrimInfo
primInfo Integer
n Type
aTy (Bool -> Bool
not Bool
aNonRep))
           else Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: init bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceUnconcatHandler :: ReducePrimHandler
reduceUnconcatHandler :: ReducePrimHandler
reduceUnconcatHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
nTy,Type
mTy,Type
aTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  , (Either TyVar Type
_:Either TyVar Type
_:Right Type
argTy:[Either TyVar Type]
_) <- ([Either TyVar Type], Type) -> [Either TyVar Type]
forall a b. (a, b) -> a
fst (Type -> ([Either TyVar Type], Type)
splitFunForallTy (HasCallStack => TyConMap -> Type -> [Type] -> Type
TyConMap -> Type -> [Type] -> Type
piResultTys TyConMap
tyConMap (PrimInfo -> Type
primType PrimInfo
primInfo) [Type
nTy,Type
mTy,Type
aTy]))
  = case (Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy), Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
mTy)) of
      (Right Integer
n, Right Integer
m) -> do
        Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Integer
mInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
0)
                                  , [CoreContext] -> RewriteMonad NormalizeState Bool
shouldReduce (TransformContext -> [CoreContext]
tfContext TransformContext
transformContext)
                                  , Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
aTy
                                  --  Note [Unroll shouldSplit types]
                                  , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Type]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Type -> Maybe ([Term] -> Term, Projections, [Type])
shouldSplit TyConMap
tyConMap Type
argTy))
                                  ]
        if Bool
shouldReduce1 then
          [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term
    -> Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
            (PrimInfo
-> Integer
-> Integer
-> Type
-> Term
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceUnconcat PrimInfo
primInfo Integer
n Integer
m Type
aTy)
        else
          Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
      (Either [Char] Integer, Either [Char] Integer)
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: unconcat bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceTransposeHandler :: ReducePrimHandler
reduceTransposeHandler :: ReducePrimHandler
reduceTransposeHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
mTy,Type
nTy,Type
aTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  = case (Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy), Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
mTy)) of
      (Right Integer
n, Right Integer
0) -> [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                              (Integer
-> Integer
-> Type
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceTranspose Integer
n Integer
0 Type
aTy)
      (Either [Char] Integer, Either [Char] Integer)
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: transpose bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceReplicateHandler :: ReducePrimHandler
reduceReplicateHandler :: ReducePrimHandler
reduceReplicateHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
nTy,Type
aTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> do
        Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ [CoreContext] -> RewriteMonad NormalizeState Bool
shouldReduce (TransformContext -> [CoreContext]
tfContext TransformContext
transformContext)
                             , Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
aTy
                             -- Note [Unroll shouldSplit types]
                             , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Type]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Type -> Maybe ([Term] -> Term, Projections, [Type])
shouldSplit TyConMap
tyConMap Type
resultType))
                             ]
        if Bool
shouldReduce1
           then [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                  (Integer
-> Type
-> Type
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceReplicate Integer
n Type
aTy Type
resultType)
           else Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: replicate bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

-- replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a
reduceReplaceIntHandler :: ReducePrimHandler
reduceReplaceIntHandler :: ReducePrimHandler
reduceReplaceIntHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
nTy,Type
aTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> do
        Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
ultra
                             , [CoreContext] -> RewriteMonad NormalizeState Bool
shouldReduce (TransformContext -> [CoreContext]
tfContext TransformContext
transformContext)
                             , Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
aTy
                             -- Note [Unroll shouldSplit types]
                             , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Type]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Type -> Maybe ([Term] -> Term, Projections, [Type])
shouldSplit TyConMap
tyConMap Type
resultType))
                             ]
        if Bool
shouldReduce1
           then [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term
    -> Term
    -> Term
    -> Term
    -> TransformContext
    -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                  (Integer
-> Type
-> Type
-> Term
-> Term
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceReplace_int Integer
n Type
aTy Type
resultType)
           else Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: replace_int bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceIndexIntHandler :: ReducePrimHandler
reduceIndexIntHandler :: ReducePrimHandler
reduceIndexIntHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
nTy,Type
aTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  , (Either TyVar Type
_:Right Type
argTy:[Either TyVar Type]
_) <- ([Either TyVar Type], Type) -> [Either TyVar Type]
forall a b. (a, b) -> a
fst (Type -> ([Either TyVar Type], Type)
splitFunForallTy (HasCallStack => TyConMap -> Type -> [Type] -> Type
TyConMap -> Type -> [Type] -> Type
piResultTys TyConMap
tyConMap (PrimInfo -> Type
primType PrimInfo
primInfo) [Type
nTy,Type
aTy]))
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> do
        Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
ultra
                             , [CoreContext] -> RewriteMonad NormalizeState Bool
shouldReduce (TransformContext -> [CoreContext]
tfContext TransformContext
transformContext)
                             , Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
aTy
                             -- Note [Unroll shouldSplit types]
                             , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Type]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Type -> Maybe ([Term] -> Term, Projections, [Type])
shouldSplit TyConMap
tyConMap Type
argTy)) ]
        if Bool
shouldReduce1
           then [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term
    -> Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                  (Integer
-> Type
-> Term
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceIndex_int Integer
n Type
aTy)
           else Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: index_int bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceImapHandler :: ReducePrimHandler
reduceImapHandler :: ReducePrimHandler
reduceImapHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
nTy,Type
argElTy,Type
resElTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  , TyConApp TyConName
vecTcNm [Type]
_ <- TypeView
resultTypeView
  , let argTy :: Type
argTy = TyConName -> [Type] -> Type
mkTyConApp TyConName
vecTcNm [Type
nTy,Type
argElTy]
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> do
        Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Bool
ultra Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
2)
                             , [CoreContext] -> RewriteMonad NormalizeState Bool
shouldReduce (TransformContext -> [CoreContext]
tfContext TransformContext
transformContext)
                             , (Type -> RewriteMonad NormalizeState Bool)
-> [Type] -> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type) a.
Monad m =>
(a -> m Bool) -> [a] -> m Bool
List.anyM Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly [Type
argElTy,Type
resElTy]
                             -- Note [Unroll shouldSplit types]
                             , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Type -> Bool) -> [Type] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (Maybe ([Term] -> Term, Projections, [Type]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (Maybe ([Term] -> Term, Projections, [Type]) -> Bool)
-> (Type -> Maybe ([Term] -> Term, Projections, [Type]))
-> Type
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> Type -> Maybe ([Term] -> Term, Projections, [Type])
shouldSplit TyConMap
tyConMap)
                                         [Type
argTy,Type
resultType]) ]
        if Bool
shouldReduce1
           then [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term
    -> Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                  (Integer
-> Type
-> Type
-> Term
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceImap Integer
n Type
argElTy Type
resElTy)
           else Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: imap bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceIterateIHandler :: ReducePrimHandler
reduceIterateIHandler :: ReducePrimHandler
reduceIterateIHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
nTy,Type
aTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> do
        Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM
          [ Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Bool
ultra Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
2)
          , [CoreContext] -> RewriteMonad NormalizeState Bool
shouldReduce (TransformContext -> [CoreContext]
tfContext TransformContext
transformContext)
          , Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
aTy
          -- Note [Unroll shouldSplit types]
          , Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Type]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Type -> Maybe ([Term] -> Term, Projections, [Type])
shouldSplit TyConMap
tyConMap Type
resultType)) ]

        if Bool
shouldReduce1 then
          [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term
    -> Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
            (Integer
-> Type
-> Type
-> Term
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceIterateI Integer
n Type
aTy Type
resultType)
        else
          Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: iterateI bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceDTFoldHandler :: ReducePrimHandler
reduceDTFoldHandler :: ReducePrimHandler
reduceDTFoldHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
_mTy,Type
nTy,Type
aTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term
    -> Term
    -> Term
    -> Term
    -> Term
    -> TransformContext
    -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                   (Integer
-> Type
-> Term
-> Term
-> Term
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceDTFold Integer
n Type
aTy)
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: dtfold bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceReverseHandler :: ReducePrimHandler
reduceReverseHandler :: ReducePrimHandler
reduceReverseHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | Bool
ultra
  , ([Term]
tmArgs,[Type
nTy,Type
aTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  , Right Integer
n <- Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy)
  = [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
      (Integer
-> Type -> Term -> TransformContext -> NormalizeSession Term
reduceReverse Integer
n Type
aTy)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceTDFoldHandler :: ReducePrimHandler
reduceTDFoldHandler :: ReducePrimHandler
reduceTDFoldHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
_mTy,Type
nTy,Type
aTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term
    -> Term
    -> Term
    -> Term
    -> Term
    -> TransformContext
    -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                   (Integer
-> Type
-> Term
-> Term
-> Term
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceTFold Integer
n Type
aTy)
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: tdfold bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceTReplicateHandler :: ReducePrimHandler
reduceTReplicateHandler :: ReducePrimHandler
reduceTReplicateHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
nTy,Type
aTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  = case Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy) of
      Right Integer
n -> do
        Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ [CoreContext] -> RewriteMonad NormalizeState Bool
shouldReduce (TransformContext -> [CoreContext]
tfContext TransformContext
transformContext)
                             , Bool -> Type -> RewriteMonad NormalizeState Bool
forall extra. Bool -> Type -> RewriteMonad extra Bool
isUntranslatableType Bool
False Type
aTy ]
        if Bool
shouldReduce1
           then [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext
                  (Integer
-> Type
-> Type
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceTReplicate Integer
n Type
aTy Type
resultType)
           else Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
      Either [Char] Integer
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: treplicate bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceSplitHandler :: ReducePrimHandler
reduceSplitHandler :: ReducePrimHandler
reduceSplitHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
nTy,Type
mTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  = case (Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy), Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
mTy), TypeView
resultTypeView) of
      (Right Integer
n, Right Integer
m, TyConApp TyConName
tupTcNm [Type
lTy,Type
rTy])
        -- XXX: This transformation is optimistic: it will return a defined value
        --      even if the input is a bottom, if one of its results is zero width.
        | Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0
        , Just Term
zeroWidthR <- TyConMap -> Type -> Maybe Term
zeroWidthTypeElem TyConMap
tyConMap (TyConMap -> Type -> Type
normalizeType TyConMap
tyConMap Type
rTy)
        -> [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext ((Term -> Term -> TransformContext -> NormalizeSession Term)
 -> NormalizeSession Term)
-> (Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a b. (a -> b) -> a -> b
$
            \(Term
_kn :: Term) Term
bvArg (TransformContext
_ctx :: TransformContext) -> do
              let tup :: Term
tup = Term -> [Either Term Type] -> Term
mkApps (DataCon -> Term
Data DataCon
tupDc)
                           [Type -> Either Term Type
forall a b. b -> Either a b
Right Type
lTy
                           ,Type -> Either Term Type
forall a b. b -> Either a b
Right Type
rTy
                           ,Term -> Either Term Type
forall a b. a -> Either a b
Left  Term
bvArg
                           ,Term -> Either Term Type
forall a b. a -> Either a b
Left  Term
zeroWidthR
                           ]

              (Term -> NormalizeSession Term
forall a extra. a -> RewriteMonad extra a
changed (Term -> [TickInfo] -> Term
mkTicks Term
tup [TickInfo]
primTicks) :: NormalizeSession Term)
        | Integer
m Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0
        , Just Term
zeroWidthL <- TyConMap -> Type -> Maybe Term
zeroWidthTypeElem TyConMap
tyConMap (TyConMap -> Type -> Type
normalizeType TyConMap
tyConMap Type
lTy)
        -> [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext ((Term -> Term -> TransformContext -> NormalizeSession Term)
 -> NormalizeSession Term)
-> (Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a b. (a -> b) -> a -> b
$
            \(Term
_kn :: Term) Term
bvArg (TransformContext
_ctx :: TransformContext) -> do
              let tup :: Term
tup = Term -> [Either Term Type] -> Term
mkApps (DataCon -> Term
Data DataCon
tupDc)
                           [Type -> Either Term Type
forall a b. b -> Either a b
Right Type
lTy
                           ,Type -> Either Term Type
forall a b. b -> Either a b
Right Type
rTy
                           ,Term -> Either Term Type
forall a b. a -> Either a b
Left  Term
zeroWidthL
                           ,Term -> Either Term Type
forall a b. a -> Either a b
Left  Term
bvArg
                           ]

              (Term -> NormalizeSession Term
forall a extra. a -> RewriteMonad extra a
changed (Term -> [TickInfo] -> Term
mkTicks Term
tup [TickInfo]
primTicks) :: NormalizeSession Term)
       where
        tupDc :: DataCon
tupDc = DataCon -> Maybe DataCon -> DataCon
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> DataCon
forall a. HasCallStack => [Char] -> a
error [Char]
"reducePrim: failed to create tup DC") (Maybe DataCon -> DataCon) -> Maybe DataCon -> DataCon
forall a b. (a -> b) -> a -> b
$ do
                TyCon
tupTc <- TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
UniqMap.lookup TyConName
tupTcNm TyConMap
tyConMap
                [DataCon] -> Maybe DataCon
forall a. [a] -> Maybe a
listToMaybe (TyCon -> [DataCon]
tyConDataCons TyCon
tupTc)
      (Either [Char] Integer, Either [Char] Integer, TypeView)
_ -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm
  | [Either Term Type] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Type]
primArguments Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reducePrim: split# bad args" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
originalTerm)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

reduceEqHandler :: ReducePrimHandler
reduceEqHandler :: ReducePrimHandler
reduceEqHandler ReducePrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReducePrimContext -> TransformContext
originalTerm :: ReducePrimContext -> Term
primInfo :: ReducePrimContext -> PrimInfo
primArguments :: ReducePrimContext -> [Either Term Type]
primTicks :: ReducePrimContext -> [TickInfo]
tyConMap :: ReducePrimContext -> TyConMap
ultra :: ReducePrimContext -> Bool
termType :: ReducePrimContext -> Type
resultType :: ReducePrimContext -> Type
resultTypeView :: ReducePrimContext -> TypeView
transformContext :: TransformContext
originalTerm :: Term
primInfo :: PrimInfo
primArguments :: [Either Term Type]
primTicks :: [TickInfo]
tyConMap :: TyConMap
ultra :: Bool
termType :: Type
resultType :: Type
resultTypeView :: TypeView
..}
  | ([Term]
tmArgs,[Type
nTy]) <- [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Type]
primArguments
  , Right Integer
0 <- Except [Char] Integer -> Either [Char] Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except [Char] Integer
tyNatSize TyConMap
tyConMap Type
nTy)
  , TyConApp TyConName
boolTcNm [] <- TypeView
resultTypeView
  = [TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term
    -> Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
primTicks [Term]
tmArgs Type
termType TransformContext
transformContext ((Term
  -> Term -> Term -> TransformContext -> NormalizeSession Term)
 -> NormalizeSession Term)
-> (Term
    -> Term -> Term -> TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
forall a b. (a -> b) -> a -> b
$
      \(Term
_kn :: Term) (Term
_l :: Term) (Term
_r :: Term) (TransformContext
_ctx :: TransformContext) ->
        let trueDc :: DataCon
trueDc = DataCon -> Maybe DataCon -> DataCon
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> DataCon
forall a. HasCallStack => [Char] -> a
error [Char]
"reducePrim: failed to create True DC") (Maybe DataCon -> DataCon) -> Maybe DataCon -> DataCon
forall a b. (a -> b) -> a -> b
$ do
              TyCon
boolTc <- TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
UniqMap.lookup TyConName
boolTcNm TyConMap
tyConMap
              [DataCon
_falseDc,DataCon
dc] <- [DataCon] -> Maybe [DataCon]
forall a. a -> Maybe a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TyCon -> [DataCon]
tyConDataCons TyCon
boolTc)
              DataCon -> Maybe DataCon
forall a. a -> Maybe a
forall (m :: Type -> Type) a. Monad m => a -> m a
return DataCon
dc
        in (Term -> NormalizeSession Term
forall a extra. a -> RewriteMonad extra a
changed (DataCon -> Term
Data DataCon
trueDc) :: NormalizeSession Term)
  | Bool
otherwise
  = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
originalTerm

isUntranslatableType_not_poly :: Type -> NormalizeSession Bool
isUntranslatableType_not_poly :: Type -> RewriteMonad NormalizeState Bool
isUntranslatableType_not_poly Type
t = do
  Bool
u <- Bool -> Type -> RewriteMonad NormalizeState Bool
forall extra. Bool -> Type -> RewriteMonad extra Bool
isUntranslatableType Bool
False Type
t
  if Bool
u
     then Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null ([TyVar] -> Bool) -> [TyVar] -> Bool
forall a b. (a -> b) -> a -> b
$ Getting (Endo [TyVar]) Type TyVar -> Type -> [TyVar]
forall a s. Getting (Endo [a]) s a -> s -> [a]
Lens.toListOf Getting (Endo [TyVar]) Type TyVar
Fold Type TyVar
typeFreeVars Type
t)
     else Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False

class AbstractOverMissingArgs a where
  -- | Abstract over a primitive until it is saturated
  abstractOverMissingArgs ::
    HasCallStack =>
    -- | Ticks originally tagged to the applied primitive
    [TickInfo] ->
    -- | Available arguments
    [Term] ->
    -- | The type of the expression containing the applied primitive
    Type ->
    -- | The context in which reducePrim was called
    TransformContext ->
    a ->
    NormalizeSession Term

instance AbstractOverMissingArgs (TransformContext -> NormalizeSession Term) where
  abstractOverMissingArgs :: HasCallStack =>
[TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (TransformContext -> NormalizeSession Term)
-> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
ticks [Term]
args Type
_ TransformContext
is TransformContext -> NormalizeSession Term
f = (Term -> [Term] -> Term
`mkTmApps` [Term]
args) (Term -> Term) -> (Term -> Term) -> Term -> Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term) -> NormalizeSession Term -> NormalizeSession Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TransformContext -> NormalizeSession Term
f TransformContext
is

instance AbstractOverMissingArgs a => AbstractOverMissingArgs (Term -> a) where
  abstractOverMissingArgs :: HasCallStack =>
[TickInfo]
-> [Term]
-> Type
-> TransformContext
-> (Term -> a)
-> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
ticks (Term
t:[Term]
ts) Type
ty TransformContext
ctx Term -> a
f = [TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
ticks [Term]
ts Type
ty TransformContext
ctx (Term -> a
f Term
t)
  abstractOverMissingArgs [TickInfo]
ticks []     (Type -> TypeView
tyView -> FunTy Type
argTy Type
resTy) (TransformContext InScopeSet
is0 [CoreContext]
ctx) Term -> a
f = do
     Id
newId <- InScopeSet -> Text -> Type -> RewriteMonad NormalizeState Id
forall (m :: Type -> Type).
MonadUnique m =>
InScopeSet -> Text -> Type -> m Id
mkInternalVar InScopeSet
is0 Text
"arg" Type
argTy
     let ctx1 :: TransformContext
ctx1 = InScopeSet -> [CoreContext] -> TransformContext
TransformContext (InScopeSet -> Id -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
is0 Id
newId) (Id -> CoreContext
LamBody Id
newId CoreContext -> [CoreContext] -> [CoreContext]
forall a. a -> [a] -> [a]
: [CoreContext]
ctx)
     Id -> Term -> Term
Lam Id
newId (Term -> Term) -> NormalizeSession Term -> NormalizeSession Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
forall a.
(AbstractOverMissingArgs a, HasCallStack) =>
[TickInfo]
-> [Term] -> Type -> TransformContext -> a -> NormalizeSession Term
abstractOverMissingArgs [TickInfo]
ticks [] Type
resTy TransformContext
ctx1 (Term -> a
f (Id -> Term
Var Id
newId))
  abstractOverMissingArgs [TickInfo]
_ [Term]
_ Type
ty TransformContext
_ Term -> a
_ = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"not a funty: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Type -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Type
ty)