{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Redundant lambda" #-}
{-# HLINT ignore "Avoid lambda" #-}
{-# HLINT ignore "Use foldr" #-}
{-# HLINT ignore "Use sum" #-}

-- | Algorithms and functions for testing purposes
module Perf.Algos
  ( -- * command-line options
    Example (..),
    allExamples,
    parseExample,
    ExamplePattern (..),
    examplePattern,
    exampleLabel,
    testExample,
    statExamples,

    -- * sum algorithms
    SumPattern (..),
    allSums,
    testSum,
    statSums,
    sumTail,
    sumTailLazy,
    sumFlip,
    sumFlipLazy,
    sumCo,
    sumCoGo,
    sumCoCase,
    sumAux,
    sumFoldr,
    sumCata,
    sumSum,
    sumMono,
    sumPoly,
    sumLambda,
    sumF,
    sumFuse,
    sumFusePoly,
    sumFuseFoldl',
    sumFuseFoldr,

    -- * length algorithms
    LengthPattern (..),
    allLengths,
    testLength,
    statLengths,

    -- * length
    lengthTail,
    lengthTailLazy,
    lengthFlip,
    lengthFlipLazy,
    lengthCo,
    lengthCoCase,
    lengthAux,
    lengthFoldr,
    lengthFoldrConst,
    lengthF,
    lengthFMono,

    -- * recursion patterns
    recurseTail,
    recurseTailLazy,
    recurseFlip,
    recurseFlipLazy,
    recurseCo,
    recurseCoLazy,
    recurseCata,

    -- * miscellaneous
    mapInc,
    constFuse,
    splitHalf,
  )
where

import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Bifunctor
import Data.Foldable
import Data.Functor.Foldable
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import Options.Applicative
import Perf.Types

-- | Algorithm examples for testing
data Example = ExampleSumFuse | ExampleSum | ExampleLengthF | ExampleConstFuse | ExampleMapInc | ExampleNoOp deriving (Example -> Example -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Example -> Example -> Bool
$c/= :: Example -> Example -> Bool
== :: Example -> Example -> Bool
$c== :: Example -> Example -> Bool
Eq, Int -> Example -> ShowS
[Example] -> ShowS
Example -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Example] -> ShowS
$cshowList :: [Example] -> ShowS
show :: Example -> String
$cshow :: Example -> String
showsPrec :: Int -> Example -> ShowS
$cshowsPrec :: Int -> Example -> ShowS
Show)

-- | All the example algorithms.
allExamples :: [Example]
allExamples :: [Example]
allExamples =
  [ Example
ExampleSumFuse,
    Example
ExampleSum,
    Example
ExampleLengthF,
    Example
ExampleConstFuse,
    Example
ExampleMapInc,
    Example
ExampleNoOp
  ]

-- | Parse command-line options for algorithm examples.
parseExample :: Parser Example
parseExample :: Parser Example
parseExample =
  forall a. a -> Mod FlagFields a -> Parser a
flag' Example
ExampleSumFuse (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"sumFuse" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"fused sum pipeline")
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Mod FlagFields a -> Parser a
flag' Example
ExampleSum (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"sum" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"sum")
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Mod FlagFields a -> Parser a
flag' Example
ExampleLengthF (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"lengthF" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"foldr id length")
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Mod FlagFields a -> Parser a
flag' Example
ExampleConstFuse (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"constFuse" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"fused const pipeline")
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Mod FlagFields a -> Parser a
flag' Example
ExampleMapInc (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"mapInc" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"fmap (+1)")
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Mod FlagFields a -> Parser a
flag' Example
ExampleNoOp (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"noOp" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"const ()")
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Example
ExampleSum

-- | Unification of example function applications
data ExamplePattern a
  = PatternSumFuse Text ((Num a) => (a -> a)) a
  | PatternSum Text ((Num a) => [a] -> a) [a]
  | PatternLengthF Text ([a] -> Int) [a]
  | PatternConstFuse Text (Int -> ()) Int
  | PatternMapInc Text ([Int] -> [Int]) [Int]
  | PatternNoOp Text (() -> ()) ()

-- | Labels
exampleLabel :: ExamplePattern a -> Text
exampleLabel :: forall a. ExamplePattern a -> Text
exampleLabel (PatternSumFuse Text
l Num a => a -> a
_ a
_) = Text
l
exampleLabel (PatternSum Text
l Num a => [a] -> a
_ [a]
_) = Text
l
exampleLabel (PatternLengthF Text
l [a] -> Int
_ [a]
_) = Text
l
exampleLabel (PatternConstFuse Text
l Int -> ()
_ Int
_) = Text
l
exampleLabel (PatternMapInc Text
l [Int] -> [Int]
_ [Int]
_) = Text
l
exampleLabel (PatternNoOp Text
l () -> ()
_ ()
_) = Text
l

-- | Convert an 'Example' to an 'ExamplePattern'.
examplePattern :: Example -> Int -> ExamplePattern Int
examplePattern :: Example -> Int -> ExamplePattern Int
examplePattern Example
ExampleSumFuse Int
l = forall a. Text -> (Num a => a -> a) -> a -> ExamplePattern a
PatternSumFuse Text
"sumFuse" Int -> Int
sumFuse Int
l
examplePattern Example
ExampleSum Int
l = forall a. Text -> (Num a => [a] -> a) -> [a] -> ExamplePattern a
PatternSum Text
"sum" forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int
1 .. Int
l]
examplePattern Example
ExampleLengthF Int
l = forall a. Text -> ([a] -> Int) -> [a] -> ExamplePattern a
PatternLengthF Text
"lengthF" forall a. [a] -> Int
lengthF [Int
1 .. Int
l]
examplePattern Example
ExampleConstFuse Int
l = forall a. Text -> (Int -> ()) -> Int -> ExamplePattern a
PatternConstFuse Text
"constFuse" Int -> ()
constFuse Int
l
examplePattern Example
ExampleMapInc Int
l = forall a. Text -> ([Int] -> [Int]) -> [Int] -> ExamplePattern a
PatternMapInc Text
"mapInc" [Int] -> [Int]
mapInc [Int
1 .. Int
l]
examplePattern Example
ExampleNoOp Int
_ = forall a. Text -> (() -> ()) -> () -> ExamplePattern a
PatternNoOp Text
"noop" (forall a b. a -> b -> a
const ()) ()

-- | Convert an 'ExamplePattern' to a 'PerfT'.
testExample :: (Semigroup a, MonadIO m) => ExamplePattern Int -> PerfT m a ()
testExample :: forall a (m :: * -> *).
(Semigroup a, MonadIO m) =>
ExamplePattern Int -> PerfT m a ()
testExample (PatternSumFuse Text
label Num Int => Int -> Int
f Int
a) = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) t a b.
(MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
fap Text
label Num Int => Int -> Int
f Int
a
testExample (PatternSum Text
label Num Int => [Int] -> Int
f [Int]
a) = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) t a b.
(MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
fap Text
label Num Int => [Int] -> Int
f [Int]
a
testExample (PatternLengthF Text
label [Int] -> Int
f [Int]
a) = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) t a b.
(MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
fap Text
label [Int] -> Int
f [Int]
a
testExample (PatternConstFuse Text
label Int -> ()
f Int
a) = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) t a b.
(MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
fap Text
label Int -> ()
f Int
a
testExample (PatternMapInc Text
label [Int] -> [Int]
f [Int]
a) = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) t a b.
(MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
fap Text
label [Int] -> [Int]
f [Int]
a
testExample (PatternNoOp Text
label () -> ()
f ()
a) = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) t a b.
(MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
fap Text
label () -> ()
f ()
a

-- | run an example measurement.
statExamples :: (MonadIO m) => Int -> Int -> (Int -> Measure m [a]) -> m (Map.Map Text [a])
statExamples :: forall (m :: * -> *) a.
MonadIO m =>
Int -> Int -> (Int -> Measure m [a]) -> m (Map Text [a])
statExamples Int
n Int
l Int -> Measure m [a]
m = forall (m :: * -> *) t a.
Monad m =>
Measure m t -> PerfT m t a -> m (Map Text t)
execPerfT (Int -> Measure m [a]
m Int
n) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a (m :: * -> *).
(Semigroup a, MonadIO m) =>
ExamplePattern Int -> PerfT m a ()
testExample ((Example -> Int -> ExamplePattern Int
`examplePattern` Int
l) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Example]
allExamples)

-- | Unification of sum function applications
data SumPattern a
  = SumFuse Text (Int -> Int) Int
  | SumFusePoly Text ((Enum a, Num a) => a -> a) a
  | SumPoly Text ((Num a) => [a] -> a) [a]
  | SumMono Text ([Int] -> Int) [Int]

-- | All the sum algorithms.
allSums :: Int -> [SumPattern Int]
allSums :: Int -> [SumPattern Int]
allSums Int
l =
  [ forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumTail" forall a. Num a => [a] -> a
sumTail [Int
1 .. Int
l],
    forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumTailLazy" forall a. Num a => [a] -> a
sumTailLazy [Int
1 .. Int
l],
    forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumFlip" forall a. Num a => [a] -> a
sumFlip [Int
1 .. Int
l],
    forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumFlipLazy" forall a. Num a => [a] -> a
sumFlipLazy [Int
1 .. Int
l],
    forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumCo" forall a. Num a => [a] -> a
sumCo [Int
1 .. Int
l],
    forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumCoGo" forall a. Num a => [a] -> a
sumCoGo [Int
1 .. Int
l],
    forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumCoCase" forall a. Num a => [a] -> a
sumCoCase [Int
1 .. Int
l],
    forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumAux" forall a. Num a => [a] -> a
sumAux [Int
1 .. Int
l],
    forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumFoldr" forall a. Num a => [a] -> a
sumFoldr [Int
1 .. Int
l],
    forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumCata" forall a. Num a => [a] -> a
sumCata [Int
1 .. Int
l],
    forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumSum" forall a. Num a => [a] -> a
sumSum [Int
1 .. Int
l],
    forall a. Text -> ([Int] -> Int) -> [Int] -> SumPattern a
SumMono Text
"sumMono" [Int] -> Int
sumMono [Int
1 .. Int
l],
    forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumPoly" forall a. Num a => [a] -> a
sumPoly [Int
1 .. Int
l],
    forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumLambda" forall a. Num a => [a] -> a
sumLambda [Int
1 .. Int
l],
    forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumF" forall a. Num a => [a] -> a
sumF [Int
1 .. Int
l],
    forall a. Text -> (Int -> Int) -> Int -> SumPattern a
SumFuse Text
"sumFuse" Int -> Int
sumFuse Int
l,
    forall a. Text -> ((Enum a, Num a) => a -> a) -> a -> SumPattern a
SumFusePoly Text
"sumFusePoly" forall a. (Enum a, Num a) => a -> a
sumFusePoly Int
l,
    forall a. Text -> (Int -> Int) -> Int -> SumPattern a
SumFuse Text
"sumFuseFoldl'" Int -> Int
sumFuseFoldl' Int
l,
    forall a. Text -> (Int -> Int) -> Int -> SumPattern a
SumFuse Text
"sumFuseFoldr" Int -> Int
sumFuseFoldr Int
l
  ]

-- | Convert an 'SumPattern' to a 'PerfT'.
testSum :: (Semigroup a, MonadIO m) => SumPattern Int -> PerfT m a Int
testSum :: forall a (m :: * -> *).
(Semigroup a, MonadIO m) =>
SumPattern Int -> PerfT m a Int
testSum (SumFuse Text
label Int -> Int
f Int
a) = forall (m :: * -> *) t a b.
(MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
fap Text
label Int -> Int
f Int
a
testSum (SumFusePoly Text
label (Enum Int, Num Int) => Int -> Int
f Int
a) = forall (m :: * -> *) t a b.
(MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
fap Text
label (Enum Int, Num Int) => Int -> Int
f Int
a
testSum (SumMono Text
label [Int] -> Int
f [Int]
a) = forall (m :: * -> *) t a b.
(MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
fap Text
label [Int] -> Int
f [Int]
a
testSum (SumPoly Text
label Num Int => [Int] -> Int
f [Int]
a) = forall (m :: * -> *) t a b.
(MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
fap Text
label Num Int => [Int] -> Int
f [Int]
a

-- | Run a sum algorithm measurement.
statSums :: (MonadIO m) => Int -> Int -> (Int -> Measure m [a]) -> m (Map.Map Text [a])
statSums :: forall (m :: * -> *) a.
MonadIO m =>
Int -> Int -> (Int -> Measure m [a]) -> m (Map Text [a])
statSums Int
n Int
l Int -> Measure m [a]
m = forall (m :: * -> *) t a.
Monad m =>
Measure m t -> PerfT m t a -> m (Map Text t)
execPerfT (Int -> Measure m [a]
m Int
n) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a (m :: * -> *).
(Semigroup a, MonadIO m) =>
SumPattern Int -> PerfT m a Int
testSum (Int -> [SumPattern Int]
allSums Int
l)

-- | tail resursive
sumTail :: (Num a) => [a] -> a
sumTail :: forall a. Num a => [a] -> a
sumTail = forall {t}. Num t => t -> [t] -> t
go a
0
  where
    go :: t -> [t] -> t
go t
acc [] = t
acc
    go t
acc (t
x : [t]
xs) = t -> [t] -> t
go (t
x forall a. Num a => a -> a -> a
+ t
acc) forall a b. (a -> b) -> a -> b
$! [t]
xs

-- | lazy recursion.
sumTailLazy :: (Num a) => [a] -> a
sumTailLazy :: forall a. Num a => [a] -> a
sumTailLazy = forall {t}. Num t => t -> [t] -> t
go a
0
  where
    go :: t -> [t] -> t
go t
acc [] = t
acc
    go t
acc (t
x : [t]
xs) = t -> [t] -> t
go (t
x forall a. Num a => a -> a -> a
+ t
acc) forall a b. (a -> b) -> a -> b
$! [t]
xs

-- | With argument order flipped
sumFlip :: (Num a) => [a] -> a
sumFlip :: forall a. Num a => [a] -> a
sumFlip [a]
xs0 = forall {a}. Num a => [a] -> a -> a
go [a]
xs0 a
0
  where
    go :: [a] -> a -> a
go [] a
s = a
s
    go (a
x : [a]
xs) a
s = [a] -> a -> a
go [a]
xs forall a b. (a -> b) -> a -> b
$! a
x forall a. Num a => a -> a -> a
+ a
s

-- | Lazy with argument order flipped.
sumFlipLazy :: (Num a) => [a] -> a
sumFlipLazy :: forall a. Num a => [a] -> a
sumFlipLazy [a]
xs0 = forall {a}. Num a => [a] -> a -> a
go [a]
xs0 a
0
  where
    go :: [a] -> a -> a
go [] a
s = a
s
    go (a
x : [a]
xs) a
s = [a] -> a -> a
go [a]
xs forall a b. (a -> b) -> a -> b
$ a
x forall a. Num a => a -> a -> a
+ a
s

-- | Co-routine style
sumCo :: (Num a) => [a] -> a
sumCo :: forall a. Num a => [a] -> a
sumCo [] = a
0
sumCo (a
x : [a]
xs) = a
x forall a. Num a => a -> a -> a
+ forall a. Num a => [a] -> a
sumCo [a]
xs

-- | Co-routine, go style
sumCoGo :: (Num a) => [a] -> a
sumCoGo :: forall a. Num a => [a] -> a
sumCoGo = forall a. Num a => [a] -> a
go
  where
    go :: [a] -> a
go [] = a
0
    go (a
x : [a]
xs) = a
x forall a. Num a => a -> a -> a
+ [a] -> a
go [a]
xs

-- | Co-routine, case-style
sumCoCase :: (Num a) => [a] -> a
sumCoCase :: forall a. Num a => [a] -> a
sumCoCase = \case
  [] -> a
0
  (a
x : [a]
xs) -> a
x forall a. Num a => a -> a -> a
+ forall a. Num a => [a] -> a
sumCoCase [a]
xs

-- | Auxillary style.
sumAux :: (Num a) => [a] -> a
sumAux :: forall a. Num a => [a] -> a
sumAux = \case
  [] -> a
b
  (a
x : [a]
xs) -> forall a. Num a => a -> a -> a
f a
x (forall a. Num a => [a] -> a
sumAux [a]
xs)
  where
    b :: a
b = a
0
    f :: a -> a -> a
f a
x a
xs = a
x forall a. Num a => a -> a -> a
+ a
xs

-- | foldr style
sumFoldr :: (Num a) => [a] -> a
sumFoldr :: forall a. Num a => [a] -> a
sumFoldr [a]
xs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Num a => a -> a -> a
(+) a
0 [a]
xs

-- | cata style
sumCata :: (Num a) => [a] -> a
sumCata :: forall a. Num a => [a] -> a
sumCata = forall t a. Recursive t => (Base t a -> a) -> t -> a
cata forall a b. (a -> b) -> a -> b
$ \case
  Base [a] a
ListF a a
Nil -> a
0
  Cons a
x a
acc -> a
x forall a. Num a => a -> a -> a
+ a
acc

-- | sum
sumSum :: (Num a) => [a] -> a
sumSum :: forall a. Num a => [a] -> a
sumSum [a]
xs = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [a]
xs

-- | Monomorphic sum
sumMono :: [Int] -> Int
sumMono :: [Int] -> Int
sumMono [Int]
xs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Num a => a -> a -> a
(+) Int
0 [Int]
xs

-- | Polymorphic sum
sumPoly :: (Num a) => [a] -> a
sumPoly :: forall a. Num a => [a] -> a
sumPoly [a]
xs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Num a => a -> a -> a
(+) a
0 [a]
xs

-- | Lambda-style sum
sumLambda :: (Num a) => [a] -> a
sumLambda :: forall a. Num a => [a] -> a
sumLambda = \[a]
xs -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Num a => a -> a -> a
(+) a
0 [a]
xs

sumF' :: (Num a) => a -> (a -> a) -> a -> a
sumF' :: forall a. Num a => a -> (a -> a) -> a -> a
sumF' a
x a -> a
r = \ !a
a -> a -> a
r (a
x forall a. Num a => a -> a -> a
+ a
a)

-- | GHC-style foldr method.
sumF :: (Num a) => [a] -> a
sumF :: forall a. Num a => [a] -> a
sumF [a]
xs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Num a => a -> (a -> a) -> a -> a
sumF' forall a. a -> a
id [a]
xs a
0

-- | Fusion check
sumFuse :: Int -> Int
sumFuse :: Int -> Int
sumFuse Int
x = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int
1 .. Int
x]

-- | Fusion under polymorph
sumFusePoly :: (Enum a, Num a) => a -> a
sumFusePoly :: forall a. (Enum a, Num a) => a -> a
sumFusePoly a
x = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [a
1 .. a
x]

-- | foldl' fusion
sumFuseFoldl' :: Int -> Int
sumFuseFoldl' :: Int -> Int
sumFuseFoldl' Int
x = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Num a => a -> a -> a
(+) Int
0 [Int
1 .. Int
x]

-- | foldr fusion
sumFuseFoldr :: Int -> Int
sumFuseFoldr :: Int -> Int
sumFuseFoldr Int
x = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Num a => a -> a -> a
(+) Int
0 [Int
1 .. Int
x]

-- | Unification of length function applications
data LengthPattern a
  = LengthPoly Text ([a] -> Int) [a]
  | LengthMono Text ([Int] -> Int) [Int]

-- | All the length algorithms.
allLengths :: Int -> [LengthPattern Int]
allLengths :: Int -> [LengthPattern Int]
allLengths Int
l =
  [ forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthTail" forall a. [a] -> Int
lengthTail [Int
1 .. Int
l],
    forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthTailLazy" forall a. [a] -> Int
lengthTailLazy [Int
1 .. Int
l],
    forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthFlip" forall a. [a] -> Int
lengthFlip [Int
1 .. Int
l],
    forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthFlipLazy" forall a. [a] -> Int
lengthFlipLazy [Int
1 .. Int
l],
    forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthCo" forall a. [a] -> Int
lengthCo [Int
1 .. Int
l],
    forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthCoCase" forall a. [a] -> Int
lengthCoCase [Int
1 .. Int
l],
    forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthAux" forall a. [a] -> Int
lengthAux [Int
1 .. Int
l],
    forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthFoldr" forall a. [a] -> Int
lengthFoldr [Int
1 .. Int
l],
    forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthFoldrConst" forall a. [a] -> Int
lengthFoldrConst [Int
1 .. Int
l],
    forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthF" forall a. [a] -> Int
lengthF [Int
1 .. Int
l],
    forall a. Text -> ([Int] -> Int) -> [Int] -> LengthPattern a
LengthMono Text
"lengthFMono" [Int] -> Int
lengthFMono [Int
1 .. Int
l]
  ]

-- | Convert an 'LengthPattern' to a 'PerfT'.
testLength :: (Semigroup a, MonadIO m) => LengthPattern Int -> PerfT m a Int
testLength :: forall a (m :: * -> *).
(Semigroup a, MonadIO m) =>
LengthPattern Int -> PerfT m a Int
testLength (LengthMono Text
label [Int] -> Int
f [Int]
a) = forall (m :: * -> *) t a b.
(MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
fap Text
label [Int] -> Int
f [Int]
a
testLength (LengthPoly Text
label [Int] -> Int
f [Int]
a) = forall (m :: * -> *) t a b.
(MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
fap Text
label [Int] -> Int
f [Int]
a

-- | Run a lengths algorithm
statLengths :: (MonadIO m) => Int -> Int -> (Int -> Measure m [a]) -> m (Map.Map Text [a])
statLengths :: forall (m :: * -> *) a.
MonadIO m =>
Int -> Int -> (Int -> Measure m [a]) -> m (Map Text [a])
statLengths Int
n Int
l Int -> Measure m [a]
m = forall (m :: * -> *) t a.
Monad m =>
Measure m t -> PerfT m t a -> m (Map Text t)
execPerfT (Int -> Measure m [a]
m Int
n) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a (m :: * -> *).
(Semigroup a, MonadIO m) =>
LengthPattern Int -> PerfT m a Int
testLength (Int -> [LengthPattern Int]
allLengths Int
l)

-- | tail resursive
lengthTail :: [a] -> Int
lengthTail :: forall a. [a] -> Int
lengthTail [a]
xs0 = forall {t} {a}. Num t => t -> [a] -> t
go Int
0 [a]
xs0
  where
    go :: t -> [a] -> t
go t
s [] = t
s
    go t
s (a
_ : [a]
xs) = t -> [a] -> t
go (t
s forall a. Num a => a -> a -> a
+ t
1) forall a b. (a -> b) -> a -> b
$! [a]
xs

-- | lazy recursion.
lengthTailLazy :: [a] -> Int
lengthTailLazy :: forall a. [a] -> Int
lengthTailLazy [a]
xs0 = forall {t} {a}. Num t => t -> [a] -> t
go Int
0 [a]
xs0
  where
    go :: t -> [a] -> t
go t
s [] = t
s
    go t
s (a
_ : [a]
xs) = t -> [a] -> t
go (t
s forall a. Num a => a -> a -> a
+ t
1) [a]
xs

-- | With argument order flipped
lengthFlip :: [a] -> Int
lengthFlip :: forall a. [a] -> Int
lengthFlip [a]
xs0 = forall {a} {a}. Num a => [a] -> a -> a
go [a]
xs0 Int
0
  where
    go :: [a] -> a -> a
go [] a
s = a
s
    go (a
_ : [a]
xs) a
s = [a] -> a -> a
go [a]
xs forall a b. (a -> b) -> a -> b
$! a
s forall a. Num a => a -> a -> a
+ a
1

-- | Lazy with argument order flipped.
lengthFlipLazy :: [a] -> Int
lengthFlipLazy :: forall a. [a] -> Int
lengthFlipLazy [a]
xs0 = forall {a} {a}. Num a => [a] -> a -> a
go [a]
xs0 Int
0
  where
    go :: [a] -> a -> a
go [] a
s = a
s
    go (a
_ : [a]
xs) a
s = [a] -> a -> a
go [a]
xs forall a b. (a -> b) -> a -> b
$ a
s forall a. Num a => a -> a -> a
+ a
1

-- | Co-routine style
lengthCo :: [a] -> Int
lengthCo :: forall a. [a] -> Int
lengthCo [] = Int
0
lengthCo (a
_ : [a]
xs) = Int
1 forall a. Num a => a -> a -> a
+ forall a. [a] -> Int
lengthCo [a]
xs

-- | Co-routine style as a Case statement.
lengthCoCase :: [a] -> Int
lengthCoCase :: forall a. [a] -> Int
lengthCoCase = \case
  [] -> Int
0
  (a
_ : [a]
xs) -> Int
1 forall a. Num a => a -> a -> a
+ forall a. [a] -> Int
lengthCoCase [a]
xs

-- | Auxillary version.
lengthAux :: [a] -> Int
lengthAux :: forall a. [a] -> Int
lengthAux = \case
  [] -> Int
b
  (a
x : [a]
xs) -> forall {a} {p}. Num a => p -> a -> a
f a
x (forall a. [a] -> Int
lengthAux [a]
xs)
  where
    b :: Int
b = Int
0
    f :: p -> a -> a
f p
_ a
xs = a
1 forall a. Num a => a -> a -> a
+ a
xs

-- | foldr style
lengthFoldr :: [a] -> Int
lengthFoldr :: forall a. [a] -> Int
lengthFoldr = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a} {p}. Num a => p -> a -> a
f Int
b
  where
    b :: Int
b = Int
0
    f :: p -> a -> a
f p
_ a
xs = a
1 forall a. Num a => a -> a -> a
+ a
xs

-- | foldr style with explicit const usage.
lengthFoldrConst :: [a] -> Int
lengthFoldrConst :: forall a. [a] -> Int
lengthFoldrConst = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b. a -> b -> a
const (Int
1 forall a. Num a => a -> a -> a
+)) Int
0

{-
-- from base:
-- https://hackage.haskell.org/package/base-4.16.0.0/docs/src/GHC.List.html#length
-- The lambda form turns out to be necessary to make this inline
-- when we need it to and give good performance.
{-# INLINE [0] lengthFB #-}
lengthFB :: x -> (Int -> Int) -> Int -> Int
lengthFB _ r !a = r (a + 1)

-}
lengthF' :: (Num a) => x -> (a -> a) -> a -> a
lengthF' :: forall a x. Num a => x -> (a -> a) -> a -> a
lengthF' x
_ a -> a
r = \ !a
a -> a -> a
r (a
a forall a. Num a => a -> a -> a
+ a
1)

-- | GHC style
lengthF :: [a] -> Int
lengthF :: forall a. [a] -> Int
lengthF [a]
xs0 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a x. Num a => x -> (a -> a) -> a -> a
lengthF' forall a. a -> a
id [a]
xs0 Int
0

-- | Monomorphic, GHC style
lengthFMono :: [Int] -> Int
lengthFMono :: [Int] -> Int
lengthFMono [Int]
xs0 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a x. Num a => x -> (a -> a) -> a -> a
lengthF' forall a. a -> a
id [Int]
xs0 Int
0

-- * recursion patterns

-- | Tail recursion
recurseTail :: (a -> b -> b) -> b -> [a] -> b
recurseTail :: forall a b. (a -> b -> b) -> b -> [a] -> b
recurseTail a -> b -> b
f = b -> [a] -> b
go
  where
    go :: b -> [a] -> b
go b
s [] = b
s
    go b
s (a
x : [a]
xs) = b -> [a] -> b
go (a -> b -> b
f a
x b
s) forall a b. (a -> b) -> a -> b
$! [a]
xs

-- | Lazy tail recursion
recurseTailLazy :: (a -> b -> b) -> b -> [a] -> b
recurseTailLazy :: forall a b. (a -> b -> b) -> b -> [a] -> b
recurseTailLazy a -> b -> b
f = b -> [a] -> b
go
  where
    go :: b -> [a] -> b
go b
s [] = b
s
    go b
s (a
x : [a]
xs) = b -> [a] -> b
go (a -> b -> b
f a
x b
s) [a]
xs

-- | Tail resursion with flipped argument order.
recurseFlip :: (a -> b -> b) -> b -> [a] -> b
recurseFlip :: forall a b. (a -> b -> b) -> b -> [a] -> b
recurseFlip a -> b -> b
f b
s0 [a]
xs0 = [a] -> b -> b
go [a]
xs0 b
s0
  where
    go :: [a] -> b -> b
go [] b
s = b
s
    go (a
x : [a]
xs) b
s = [a] -> b -> b
go [a]
xs forall a b. (a -> b) -> a -> b
$! a -> b -> b
f a
x b
s

-- | Lazy tail resursion with flipped argument order.
recurseFlipLazy :: (a -> b -> b) -> b -> [a] -> b
recurseFlipLazy :: forall a b. (a -> b -> b) -> b -> [a] -> b
recurseFlipLazy a -> b -> b
f b
s0 [a]
xs0 = [a] -> b -> b
go [a]
xs0 b
s0
  where
    go :: [a] -> b -> b
go [] b
s = b
s
    go (a
x : [a]
xs) b
s = [a] -> b -> b
go [a]
xs forall a b. (a -> b) -> a -> b
$ a -> b -> b
f a
x b
s

-- | Coroutine
recurseCo :: (a -> b -> b) -> b -> [a] -> b
recurseCo :: forall a b. (a -> b -> b) -> b -> [a] -> b
recurseCo a -> b -> b
f b
s0 = [a] -> b
go
  where
    go :: [a] -> b
go [] = b
s0
    go (a
x : [a]
xs) = a -> b -> b
f a
x forall a b. (a -> b) -> a -> b
$! [a] -> b
go [a]
xs

-- | Lazy, coroutine
recurseCoLazy :: (a -> b -> b) -> b -> [a] -> b
recurseCoLazy :: forall a b. (a -> b -> b) -> b -> [a] -> b
recurseCoLazy a -> b -> b
f b
s0 = [a] -> b
go
  where
    go :: [a] -> b
go [] = b
s0
    go (a
x : [a]
xs) = a -> b -> b
f a
x forall a b. (a -> b) -> a -> b
$ [a] -> b
go [a]
xs

-- | Cata style
recurseCata :: (a -> b -> b) -> b -> [a] -> b
recurseCata :: forall a b. (a -> b -> b) -> b -> [a] -> b
recurseCata a -> b -> b
f b
s0 = forall t a. Recursive t => (Base t a -> a) -> t -> a
cata forall a b. (a -> b) -> a -> b
$ \case
  Base [a] b
ListF a b
Nil -> b
s0
  Cons a
x b
acc -> a -> b -> b
f a
x b
acc

-- * miscellaneous

-- | Test of const fusion
constFuse :: Int -> ()
constFuse :: Int -> ()
constFuse Int
x = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a b. a -> b -> a
const () [Int
1 .. Int
x]

-- | Increment a list.
mapInc :: [Int] -> [Int]
mapInc :: [Int] -> [Int]
mapInc [Int]
xs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
+ Int
1) [Int]
xs

-- | Split a list.
splitHalf :: [a] -> ([a], [a])
splitHalf :: forall a. [a] -> ([a], [a])
splitHalf [a]
xs = forall {a} {a}. [a] -> [a] -> ([a], [a])
go [a]
xs [a]
xs
  where
    go :: [a] -> [a] -> ([a], [a])
go (a
y : [a]
ys) (a
_ : a
_ : [a]
zs) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (a
y forall a. a -> [a] -> [a]
:) ([a] -> [a] -> ([a], [a])
go [a]
ys [a]
zs)
    go [a]
ys [a]
_ = ([], [a]
ys)