{-|
  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
  , reduceNonRepPrim
  ) 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)
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.Primitives (removedArg)
import Clash.Normalize.Types (NormRewrite, NormalizeSession)
import Clash.Normalize.Util (shouldReduce)
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 :: HasCallStack => NormRewrite
-- 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.
reduceConst :: HasCallStack => NormRewrite
reduceConst (TransformContext InScopeSet
_ (CoreContext
AppFun:[CoreContext]
_)) Term
e = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
reduceConst TransformContext
ctx e :: Term
e@(App Term
_ Term
_)
  | (Prim PrimInfo
p0, [Either Term Type]
_) <- Term -> (Term, [Either Term Type])
collectArgs Term
e
  = Bool
-> TransformContext -> Term -> NormRewrite -> NormalizeSession Term
forall extra.
Bool
-> TransformContext
-> Term
-> Rewrite extra
-> RewriteMonad extra Term
whnfRW Bool
False TransformContext
ctx Term
e (NormRewrite -> NormalizeSession Term)
-> NormRewrite -> 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

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

-- | 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.
--
-- 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 'reduceNonRepPrimImpls'.
--
-- 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
reduceNonRepPrim :: HasCallStack => NormRewrite
-- 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.
reduceNonRepPrim :: HasCallStack => NormRewrite
reduceNonRepPrim (TransformContext InScopeSet
_ (CoreContext
AppFun:[CoreContext]
_)) Term
e = Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
reduceNonRepPrim TransformContext
c e :: Term
e@(App Term
_ Term
_)
  | (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 ReduceNonRepPrimHandler
handlerM = Text
-> HashMap Text ReduceNonRepPrimHandler
-> Maybe ReduceNonRepPrimHandler
forall k v. Hashable k => k -> HashMap k v -> Maybe v
HashMap.lookup (PrimInfo -> Text
primName PrimInfo
p) HashMap Text ReduceNonRepPrimHandler
reduceNonRepPrimImpls
    -- 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 ReduceNonRepPrimHandler -> Bool
forall a. Maybe a -> Bool
Maybe.isNothing Maybe ReduceNonRepPrimHandler
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 ReduceNonRepPrimHandler
handlerM of
          Maybe ReduceNonRepPrimHandler
Nothing -> Term -> NormalizeSession Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          Just ReduceNonRepPrimHandler
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
            ReduceNonRepPrimHandler
handler ReduceNonRepPrimContext
              { 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
              }

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

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

-- | A handler for a specific primitive in 'reduceNonRepPrimImpls'.
type ReduceNonRepPrimHandler
  = ReduceNonRepPrimContext -> NormalizeSession Term

-- | The primitives 'reduceNonRepPrim' 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.
reduceNonRepPrimImpls :: HashMap Text ReduceNonRepPrimHandler
reduceNonRepPrimImpls :: HashMap Text ReduceNonRepPrimHandler
reduceNonRepPrimImpls = [(Text, ReduceNonRepPrimHandler)]
-> HashMap Text ReduceNonRepPrimHandler
forall k v. Hashable k => [(k, v)] -> HashMap k v
HashMap.fromList
  [ ($(textNameLit 'Clash.Sized.Vector.zipWith), ReduceNonRepPrimHandler
reduceZipWithHandler)
  , ($(textNameLit 'Clash.Sized.Vector.map), ReduceNonRepPrimHandler
reduceMapHandler)
  , ($(textNameLit 'Clash.Sized.Vector.traverse#), ReduceNonRepPrimHandler
reduceTraverseHandler)
  , ($(textNameLit 'Clash.Sized.Vector.fold), ReduceNonRepPrimHandler
reduceFoldHandler)
  , ($(textNameLit 'Clash.Sized.Vector.foldr), ReduceNonRepPrimHandler
reduceFoldrHandler)
  , ($(textNameLit 'Clash.Sized.Vector.dfold), ReduceNonRepPrimHandler
reduceDFoldHandler)
  , ($(textNameLit '(Clash.Sized.Vector.++)), ReduceNonRepPrimHandler
reduceAppendHandler)
  , ($(textNameLit 'Clash.Sized.Vector.head), ReduceNonRepPrimHandler
reduceHeadHandler)
  , ($(textNameLit 'Clash.Sized.Vector.tail), ReduceNonRepPrimHandler
reduceTailHandler)
  , ($(textNameLit 'Clash.Sized.Vector.last), ReduceNonRepPrimHandler
reduceLastHandler)
  , ($(textNameLit 'Clash.Sized.Vector.init), ReduceNonRepPrimHandler
reduceInitHandler)
  , ($(textNameLit 'Clash.Sized.Vector.unconcat), ReduceNonRepPrimHandler
reduceUnconcatHandler)
  , ($(textNameLit 'Clash.Sized.Vector.transpose), ReduceNonRepPrimHandler
reduceTransposeHandler)
  , ($(textNameLit 'Clash.Sized.Vector.replicate), ReduceNonRepPrimHandler
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", ReduceNonRepPrimHandler
reduceReplaceIntHandler)
  , (Text
"Clash.Sized.Vector.index_int", ReduceNonRepPrimHandler
reduceIndexIntHandler)
  , ($(textNameLit 'Clash.Sized.Vector.imap), ReduceNonRepPrimHandler
reduceImapHandler)
  , ($(textNameLit 'Clash.Sized.Vector.iterateI), ReduceNonRepPrimHandler
reduceIterateIHandler)
  , ($(textNameLit 'Clash.Sized.Vector.dtfold), ReduceNonRepPrimHandler
reduceDTFoldHandler)
  , ($(textNameLit 'Clash.Sized.Vector.reverse), ReduceNonRepPrimHandler
reduceReverseHandler)
  , ($(textNameLit 'Clash.Sized.RTree.tdfold), ReduceNonRepPrimHandler
reduceTDFoldHandler)
  , ($(textNameLit 'Clash.Sized.RTree.treplicate), ReduceNonRepPrimHandler
reduceTReplicateHandler)
  , ($(textNameLit 'Clash.Sized.Internal.BitVector.split#), ReduceNonRepPrimHandler
reduceSplitHandler)
  , ($(textNameLit 'Clash.Sized.Internal.BitVector.eq#), ReduceNonRepPrimHandler
reduceEqHandler)
  ]

reduceZipWithHandler :: ReduceNonRepPrimHandler
reduceZipWithHandler :: ReduceNonRepPrimHandler
reduceZipWithHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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
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
lhsElTy,Type
rhsElty,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
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
-> Term
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceZipWith PrimInfo
primInfo Integer
n Type
lhsElTy Type
rhsElty 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
4
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceMapHandler :: ReduceNonRepPrimHandler
reduceMapHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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
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 -> 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
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceMap PrimInfo
primInfo 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceTraverseHandler :: ReduceNonRepPrimHandler
reduceTraverseHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceFoldHandler :: ReduceNonRepPrimHandler
reduceFoldHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceFoldrHandler :: ReduceNonRepPrimHandler
reduceFoldrHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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
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)
-> [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
aTy,Type
bTy]
                             -- 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
-> Term
-> Term
-> Term
-> TransformContext
-> NormalizeSession Term
reduceFoldr PrimInfo
primInfo 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
3
  = [Char] -> NormalizeSession Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceDFoldHandler :: ReduceNonRepPrimHandler
reduceDFoldHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceAppendHandler :: ReduceNonRepPrimHandler
reduceAppendHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: ++ 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 :: ReduceNonRepPrimHandler
reduceHeadHandler :: ReduceNonRepPrimHandler
reduceHeadHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceTailHandler :: ReduceNonRepPrimHandler
reduceTailHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceLastHandler :: ReduceNonRepPrimHandler
reduceLastHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceInitHandler :: ReduceNonRepPrimHandler
reduceInitHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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
                  (PrimInfo
-> Integer
-> Type
-> Term
-> TransformContext
-> NormalizeSession Term
reduceInit PrimInfo
primInfo 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceUnconcatHandler :: ReduceNonRepPrimHandler
reduceUnconcatHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceTransposeHandler :: ReduceNonRepPrimHandler
reduceTransposeHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceReplicateHandler :: ReduceNonRepPrimHandler
reduceReplicateHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceReplaceIntHandler :: ReduceNonRepPrimHandler
reduceReplaceIntHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceIndexIntHandler :: ReduceNonRepPrimHandler
reduceIndexIntHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceImapHandler :: ReduceNonRepPrimHandler
reduceImapHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceIterateIHandler :: ReduceNonRepPrimHandler
reduceIterateIHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceDTFoldHandler :: ReduceNonRepPrimHandler
reduceDTFoldHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceReverseHandler :: ReduceNonRepPrimHandler
reduceReverseHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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 :: ReduceNonRepPrimHandler
reduceTDFoldHandler :: ReduceNonRepPrimHandler
reduceTDFoldHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceTReplicateHandler :: ReduceNonRepPrimHandler
reduceTReplicateHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceSplitHandler :: ReduceNonRepPrimHandler
reduceSplitHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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])
        | Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 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 ((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 -> Type -> Term
TyApp (PrimInfo -> Term
Prim PrimInfo
removedArg) Type
rTy)
                           ]

              (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 -> [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 -> Type -> Term
TyApp (PrimInfo -> Term
Prim PrimInfo
removedArg) Type
lTy)
                           ,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]
"reduceNonRepPrim: faield 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]
"reduceNonRepPrim: 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 :: ReduceNonRepPrimHandler
reduceEqHandler :: ReduceNonRepPrimHandler
reduceEqHandler ReduceNonRepPrimContext{Bool
[Either Term Type]
[TickInfo]
TyConMap
Term
Type
TypeView
PrimInfo
TransformContext
transformContext :: ReduceNonRepPrimContext -> TransformContext
originalTerm :: ReduceNonRepPrimContext -> Term
primInfo :: ReduceNonRepPrimContext -> PrimInfo
primArguments :: ReduceNonRepPrimContext -> [Either Term Type]
primTicks :: ReduceNonRepPrimContext -> [TickInfo]
tyConMap :: ReduceNonRepPrimContext -> TyConMap
ultra :: ReduceNonRepPrimContext -> Bool
termType :: ReduceNonRepPrimContext -> Type
resultType :: ReduceNonRepPrimContext -> Type
resultTypeView :: ReduceNonRepPrimContext -> 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]
"reduceNonRepPrim: 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 reduceNonRepPrim 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)