{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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 (..),
    parseExample,
    ExamplePattern (..),
    examplePattern,
    exampleLabel,
    testExample,
    tastyExample,

    -- * 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 Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Options.Applicative
import Options.Applicative.Help.Pretty
import Perf.Types
import Test.Tasty.Bench

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

-- | Parse command-line options for algorithm examples.
parseExample :: Parser Example
parseExample :: Parser Example
parseExample =
  Example -> Mod FlagFields Example -> Parser Example
forall a. a -> Mod FlagFields a -> Parser a
flag' Example
ExampleSumFuse (String -> Mod FlagFields Example
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"sumFuse" Mod FlagFields Example
-> Mod FlagFields Example -> Mod FlagFields Example
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Example
forall (f :: * -> *) a. String -> Mod f a
help String
"fused sum pipeline")
    Parser Example -> Parser Example -> Parser Example
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Example -> Mod FlagFields Example -> Parser Example
forall a. a -> Mod FlagFields a -> Parser a
flag' Example
ExampleSum (String -> Mod FlagFields Example
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"sum" Mod FlagFields Example
-> Mod FlagFields Example -> Mod FlagFields Example
forall a. Semigroup a => a -> a -> a
<> (Doc -> Doc) -> Mod FlagFields Example
forall (f :: * -> *) a. (Doc -> Doc) -> Mod f a
style (AnsiStyle -> Doc -> Doc
forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
bold) Mod FlagFields Example
-> Mod FlagFields Example -> Mod FlagFields Example
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Example
forall (f :: * -> *) a. String -> Mod f a
help String
"sum")
    Parser Example -> Parser Example -> Parser Example
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Example -> Mod FlagFields Example -> Parser Example
forall a. a -> Mod FlagFields a -> Parser a
flag' Example
ExampleLengthF (String -> Mod FlagFields Example
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"lengthF" Mod FlagFields Example
-> Mod FlagFields Example -> Mod FlagFields Example
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Example
forall (f :: * -> *) a. String -> Mod f a
help String
"foldr id length")
    Parser Example -> Parser Example -> Parser Example
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Example -> Mod FlagFields Example -> Parser Example
forall a. a -> Mod FlagFields a -> Parser a
flag' Example
ExampleConstFuse (String -> Mod FlagFields Example
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"constFuse" Mod FlagFields Example
-> Mod FlagFields Example -> Mod FlagFields Example
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Example
forall (f :: * -> *) a. String -> Mod f a
help String
"fused const pipeline")
    Parser Example -> Parser Example -> Parser Example
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Example -> Mod FlagFields Example -> Parser Example
forall a. a -> Mod FlagFields a -> Parser a
flag' Example
ExampleMapInc (String -> Mod FlagFields Example
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"mapInc" Mod FlagFields Example
-> Mod FlagFields Example -> Mod FlagFields Example
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Example
forall (f :: * -> *) a. String -> Mod f a
help String
"fmap (+1)")
    Parser Example -> Parser Example -> Parser Example
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Example -> Mod FlagFields Example -> Parser Example
forall a. a -> Mod FlagFields a -> Parser a
flag' Example
ExampleNoOp (String -> Mod FlagFields Example
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"noOp" Mod FlagFields Example
-> Mod FlagFields Example -> Mod FlagFields Example
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Example
forall (f :: * -> *) a. String -> Mod f a
help String
"const ()")
    Parser Example -> Parser Example -> Parser Example
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Example -> Mod FlagFields Example -> Parser Example
forall a. a -> Mod FlagFields a -> Parser a
flag' Example
ExampleFib (String -> Mod FlagFields Example
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"fib" Mod FlagFields Example
-> Mod FlagFields Example -> Mod FlagFields Example
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Example
forall (f :: * -> *) a. String -> Mod f a
help String
"fibonacci")
    Parser Example -> Parser Example -> Parser Example
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Example -> Mod FlagFields Example -> Parser Example
forall a. a -> Mod FlagFields a -> Parser a
flag' Example
ExampleNub (String -> Mod FlagFields Example
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"nub" Mod FlagFields Example
-> Mod FlagFields Example -> Mod FlagFields Example
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Example
forall (f :: * -> *) a. String -> Mod f a
help String
"List.nub")
    Parser Example -> Parser Example -> Parser Example
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Example -> Parser Example
forall a. a -> Parser 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 (() -> ()) ()
  | PatternNub Text ([Int] -> [Int]) [Int]
  | PatternFib Text (Int -> Integer) Int

-- | 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
exampleLabel (PatternNub Text
l [Int] -> [Int]
_ [Int]
_) = Text
l
exampleLabel (PatternFib Text
l Int -> Integer
_ Int
_) = Text
l

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

-- | 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) = PerfT m a Int -> PerfT m a ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PerfT m a Int -> PerfT m a ()) -> PerfT m a Int -> PerfT m a ()
forall a b. (a -> b) -> a -> b
$ Text -> (Int -> Int) -> Int -> PerfT m a Int
forall a b (m :: * -> *) t.
(NFData a, NFData b, MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
ffap Text
label Num Int => Int -> Int
Int -> Int
f Int
a
testExample (PatternSum Text
label Num Int => [Int] -> Int
f [Int]
a) = PerfT m a Int -> PerfT m a ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PerfT m a Int -> PerfT m a ()) -> PerfT m a Int -> PerfT m a ()
forall a b. (a -> b) -> a -> b
$ Text -> ([Int] -> Int) -> [Int] -> PerfT m a Int
forall a b (m :: * -> *) t.
(NFData a, NFData b, MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
ffap Text
label Num Int => [Int] -> Int
[Int] -> Int
f [Int]
a
testExample (PatternLengthF Text
label [Int] -> Int
f [Int]
a) = PerfT m a Int -> PerfT m a ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PerfT m a Int -> PerfT m a ()) -> PerfT m a Int -> PerfT m a ()
forall a b. (a -> b) -> a -> b
$ Text -> ([Int] -> Int) -> [Int] -> PerfT m a Int
forall a b (m :: * -> *) t.
(NFData a, NFData b, MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
ffap Text
label [Int] -> Int
f [Int]
a
testExample (PatternConstFuse Text
label Int -> ()
f Int
a) = PerfT m a () -> PerfT m a ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PerfT m a () -> PerfT m a ()) -> PerfT m a () -> PerfT m a ()
forall a b. (a -> b) -> a -> b
$ Text -> (Int -> ()) -> Int -> PerfT m a ()
forall a b (m :: * -> *) t.
(NFData a, NFData b, MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
ffap Text
label Int -> ()
f Int
a
testExample (PatternMapInc Text
label [Int] -> [Int]
f [Int]
a) = PerfT m a [Int] -> PerfT m a ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PerfT m a [Int] -> PerfT m a ())
-> PerfT m a [Int] -> PerfT m a ()
forall a b. (a -> b) -> a -> b
$ Text -> ([Int] -> [Int]) -> [Int] -> PerfT m a [Int]
forall a b (m :: * -> *) t.
(NFData a, NFData b, MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
ffap Text
label [Int] -> [Int]
f [Int]
a
testExample (PatternNoOp Text
label () -> ()
f ()
a) = PerfT m a () -> PerfT m a ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PerfT m a () -> PerfT m a ()) -> PerfT m a () -> PerfT m a ()
forall a b. (a -> b) -> a -> b
$ Text -> (() -> ()) -> () -> PerfT m a ()
forall a b (m :: * -> *) t.
(NFData a, NFData b, MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
ffap Text
label () -> ()
f ()
a
testExample (PatternNub Text
label [Int] -> [Int]
f [Int]
a) = PerfT m a [Int] -> PerfT m a ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PerfT m a [Int] -> PerfT m a ())
-> PerfT m a [Int] -> PerfT m a ()
forall a b. (a -> b) -> a -> b
$ Text -> ([Int] -> [Int]) -> [Int] -> PerfT m a [Int]
forall a b (m :: * -> *) t.
(NFData a, NFData b, MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
ffap Text
label [Int] -> [Int]
f [Int]
a
testExample (PatternFib Text
label Int -> Integer
f Int
a) = PerfT m a Integer -> PerfT m a ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PerfT m a Integer -> PerfT m a ())
-> PerfT m a Integer -> PerfT m a ()
forall a b. (a -> b) -> a -> b
$ Text -> (Int -> Integer) -> Int -> PerfT m a Integer
forall a b (m :: * -> *) t.
(NFData a, NFData b, MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
ffap Text
label Int -> Integer
f Int
a

-- | Convert an 'ExamplePattern' to a tasty-bench run.
tastyExample :: ExamplePattern Int -> Benchmarkable
tastyExample :: ExamplePattern Int -> Benchmarkable
tastyExample (PatternSumFuse Text
_ Num Int => Int -> Int
f Int
a) = (Int -> Int) -> Int -> Benchmarkable
forall b a. NFData b => (a -> b) -> a -> Benchmarkable
nf Num Int => Int -> Int
Int -> Int
f Int
a
tastyExample (PatternSum Text
_ Num Int => [Int] -> Int
f [Int]
a) = ([Int] -> Int) -> [Int] -> Benchmarkable
forall b a. NFData b => (a -> b) -> a -> Benchmarkable
nf Num Int => [Int] -> Int
[Int] -> Int
f [Int]
a
tastyExample (PatternLengthF Text
_ [Int] -> Int
f [Int]
a) = ([Int] -> Int) -> [Int] -> Benchmarkable
forall b a. NFData b => (a -> b) -> a -> Benchmarkable
nf [Int] -> Int
f [Int]
a
tastyExample (PatternConstFuse Text
_ Int -> ()
f Int
a) = (Int -> ()) -> Int -> Benchmarkable
forall b a. NFData b => (a -> b) -> a -> Benchmarkable
nf Int -> ()
f Int
a
tastyExample (PatternMapInc Text
_ [Int] -> [Int]
f [Int]
a) = ([Int] -> [Int]) -> [Int] -> Benchmarkable
forall b a. NFData b => (a -> b) -> a -> Benchmarkable
nf [Int] -> [Int]
f [Int]
a
tastyExample (PatternNoOp Text
_ () -> ()
f ()
a) = (() -> ()) -> () -> Benchmarkable
forall b a. NFData b => (a -> b) -> a -> Benchmarkable
nf () -> ()
f ()
a
tastyExample (PatternNub Text
_ [Int] -> [Int]
f [Int]
a) = ([Int] -> [Int]) -> [Int] -> Benchmarkable
forall b a. NFData b => (a -> b) -> a -> Benchmarkable
nf [Int] -> [Int]
f [Int]
a
tastyExample (PatternFib Text
_ Int -> Integer
f Int
a) = (Int -> Integer) -> Int -> Benchmarkable
forall b a. NFData b => (a -> b) -> a -> Benchmarkable
nf Int -> Integer
f Int
a

-- | 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 =
  [ Text -> (Num Int => [Int] -> Int) -> [Int] -> SumPattern Int
forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumTail" Num Int => [Int] -> Int
[Int] -> Int
forall a. Num a => [a] -> a
sumTail [Int
1 .. Int
l],
    Text -> (Num Int => [Int] -> Int) -> [Int] -> SumPattern Int
forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumTailLazy" Num Int => [Int] -> Int
[Int] -> Int
forall a. Num a => [a] -> a
sumTailLazy [Int
1 .. Int
l],
    Text -> (Num Int => [Int] -> Int) -> [Int] -> SumPattern Int
forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumFlip" Num Int => [Int] -> Int
[Int] -> Int
forall a. Num a => [a] -> a
sumFlip [Int
1 .. Int
l],
    Text -> (Num Int => [Int] -> Int) -> [Int] -> SumPattern Int
forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumFlipLazy" Num Int => [Int] -> Int
[Int] -> Int
forall a. Num a => [a] -> a
sumFlipLazy [Int
1 .. Int
l],
    Text -> (Num Int => [Int] -> Int) -> [Int] -> SumPattern Int
forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumCo" Num Int => [Int] -> Int
[Int] -> Int
forall a. Num a => [a] -> a
sumCo [Int
1 .. Int
l],
    Text -> (Num Int => [Int] -> Int) -> [Int] -> SumPattern Int
forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumCoGo" Num Int => [Int] -> Int
[Int] -> Int
forall a. Num a => [a] -> a
sumCoGo [Int
1 .. Int
l],
    Text -> (Num Int => [Int] -> Int) -> [Int] -> SumPattern Int
forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumCoCase" Num Int => [Int] -> Int
[Int] -> Int
forall a. Num a => [a] -> a
sumCoCase [Int
1 .. Int
l],
    Text -> (Num Int => [Int] -> Int) -> [Int] -> SumPattern Int
forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumAux" Num Int => [Int] -> Int
[Int] -> Int
forall a. Num a => [a] -> a
sumAux [Int
1 .. Int
l],
    Text -> (Num Int => [Int] -> Int) -> [Int] -> SumPattern Int
forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumFoldr" Num Int => [Int] -> Int
[Int] -> Int
forall a. Num a => [a] -> a
sumFoldr [Int
1 .. Int
l],
    Text -> (Num Int => [Int] -> Int) -> [Int] -> SumPattern Int
forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumCata" Num Int => [Int] -> Int
[Int] -> Int
forall a. Num a => [a] -> a
sumCata [Int
1 .. Int
l],
    Text -> (Num Int => [Int] -> Int) -> [Int] -> SumPattern Int
forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumSum" Num Int => [Int] -> Int
[Int] -> Int
forall a. Num a => [a] -> a
sumSum [Int
1 .. Int
l],
    Text -> ([Int] -> Int) -> [Int] -> SumPattern Int
forall a. Text -> ([Int] -> Int) -> [Int] -> SumPattern a
SumMono Text
"sumMono" [Int] -> Int
sumMono [Int
1 .. Int
l],
    Text -> (Num Int => [Int] -> Int) -> [Int] -> SumPattern Int
forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumPoly" Num Int => [Int] -> Int
[Int] -> Int
forall a. Num a => [a] -> a
sumPoly [Int
1 .. Int
l],
    Text -> (Num Int => [Int] -> Int) -> [Int] -> SumPattern Int
forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumLambda" Num Int => [Int] -> Int
[Int] -> Int
forall a. Num a => [a] -> a
sumLambda [Int
1 .. Int
l],
    Text -> (Num Int => [Int] -> Int) -> [Int] -> SumPattern Int
forall a. Text -> (Num a => [a] -> a) -> [a] -> SumPattern a
SumPoly Text
"sumF" Num Int => [Int] -> Int
[Int] -> Int
forall a. Num a => [a] -> a
sumF [Int
1 .. Int
l],
    Text -> (Int -> Int) -> Int -> SumPattern Int
forall a. Text -> (Int -> Int) -> Int -> SumPattern a
SumFuse Text
"sumFuse" Int -> Int
sumFuse Int
l,
    Text
-> ((Enum Int, Num Int) => Int -> Int) -> Int -> SumPattern Int
forall a. Text -> ((Enum a, Num a) => a -> a) -> a -> SumPattern a
SumFusePoly Text
"sumFusePoly" (Enum Int, Num Int) => Int -> Int
Int -> Int
forall a. (Enum a, Num a) => a -> a
sumFusePoly Int
l,
    Text -> (Int -> Int) -> Int -> SumPattern Int
forall a. Text -> (Int -> Int) -> Int -> SumPattern a
SumFuse Text
"sumFuseFoldl'" Int -> Int
sumFuseFoldl' Int
l,
    Text -> (Int -> Int) -> Int -> SumPattern Int
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) = Text -> (Int -> Int) -> Int -> PerfT m a Int
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) = Text -> (Int -> Int) -> Int -> PerfT m a Int
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
Int -> Int
f Int
a
testSum (SumMono Text
label [Int] -> Int
f [Int]
a) = Text -> ([Int] -> Int) -> [Int] -> PerfT m a Int
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) = Text -> ([Int] -> Int) -> [Int] -> PerfT m a Int
forall (m :: * -> *) t a b.
(MonadIO m, Semigroup t) =>
Text -> (a -> b) -> a -> PerfT m t b
fap Text
label Num Int => [Int] -> 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 = Measure m [a] -> PerfT m [a] () -> m (Map Text [a])
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) (PerfT m [a] () -> m (Map Text [a]))
-> PerfT m [a] () -> m (Map Text [a])
forall a b. (a -> b) -> a -> b
$ (SumPattern Int -> PerfT m [a] Int)
-> [SumPattern Int] -> PerfT m [a] ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SumPattern Int -> PerfT m [a] Int
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 = a -> [a] -> a
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 t -> t -> t
forall a. Num a => a -> a -> a
+ t
acc) ([t] -> t) -> [t] -> t
forall a b. (a -> b) -> a -> b
$! [t]
xs

-- | lazy recursion.
sumTailLazy :: (Num a) => [a] -> a
sumTailLazy :: forall a. Num a => [a] -> a
sumTailLazy = a -> [a] -> a
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 t -> t -> t
forall a. Num a => a -> a -> a
+ t
acc) ([t] -> t) -> [t] -> t
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 = [a] -> a -> a
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 (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$! a
x a -> a -> a
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 = [a] -> a -> a
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 (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
x a -> a -> a
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 a -> a -> a
forall a. Num a => a -> 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 = [a] -> a
forall a. Num a => [a] -> a
go
  where
    go :: [a] -> a
go [] = a
0
    go (a
x : [a]
xs) = a
x a -> a -> a
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 a -> a -> a
forall a. Num a => a -> 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) -> a -> a -> a
forall a. Num a => a -> a -> a
f a
x ([a] -> a
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 a -> a -> a
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 = (a -> a -> a) -> a -> [a] -> a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> a -> a
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 = (Base [a] a -> a) -> [a] -> a
forall t a. Recursive t => (Base t a -> a) -> t -> a
forall a. (Base [a] a -> a) -> [a] -> a
cata ((Base [a] a -> a) -> [a] -> a) -> (Base [a] a -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ \case
  ListF a a
Base [a] a
Nil -> a
0
  Cons a
x a
acc -> a
x a -> a -> a
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 = [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [a]
xs

-- | Monomorphic sum
sumMono :: [Int] -> Int
sumMono :: [Int] -> Int
sumMono [Int]
xs = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> Int -> Int
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 = (a -> a -> a) -> a -> [a] -> a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> a -> a
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 -> (a -> a -> a) -> a -> [a] -> a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> a -> a
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 a -> a -> a
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 = (a -> (a -> a) -> a -> a) -> (a -> a) -> [a] -> a -> a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> (a -> a) -> a -> a
forall a. Num a => a -> (a -> a) -> a -> a
sumF' a -> a
forall a. a -> a
id [a]
xs a
0

-- | Fusion check
sumFuse :: Int -> Int
sumFuse :: Int -> Int
sumFuse Int
x = [Int] -> Int
forall a. Num a => [a] -> a
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 = [a] -> a
forall a. Num a => [a] -> a
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 = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0 [Int
1 .. Int
x]

-- | foldr fusion
sumFuseFoldr :: Int -> Int
sumFuseFoldr :: Int -> Int
sumFuseFoldr Int
x = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> Int -> Int
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 =
  [ Text -> ([Int] -> Int) -> [Int] -> LengthPattern Int
forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthTail" [Int] -> Int
forall a. [a] -> Int
lengthTail [Int
1 .. Int
l],
    Text -> ([Int] -> Int) -> [Int] -> LengthPattern Int
forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthTailLazy" [Int] -> Int
forall a. [a] -> Int
lengthTailLazy [Int
1 .. Int
l],
    Text -> ([Int] -> Int) -> [Int] -> LengthPattern Int
forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthFlip" [Int] -> Int
forall a. [a] -> Int
lengthFlip [Int
1 .. Int
l],
    Text -> ([Int] -> Int) -> [Int] -> LengthPattern Int
forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthFlipLazy" [Int] -> Int
forall a. [a] -> Int
lengthFlipLazy [Int
1 .. Int
l],
    Text -> ([Int] -> Int) -> [Int] -> LengthPattern Int
forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthCo" [Int] -> Int
forall a. [a] -> Int
lengthCo [Int
1 .. Int
l],
    Text -> ([Int] -> Int) -> [Int] -> LengthPattern Int
forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthCoCase" [Int] -> Int
forall a. [a] -> Int
lengthCoCase [Int
1 .. Int
l],
    Text -> ([Int] -> Int) -> [Int] -> LengthPattern Int
forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthAux" [Int] -> Int
forall a. [a] -> Int
lengthAux [Int
1 .. Int
l],
    Text -> ([Int] -> Int) -> [Int] -> LengthPattern Int
forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthFoldr" [Int] -> Int
forall a. [a] -> Int
lengthFoldr [Int
1 .. Int
l],
    Text -> ([Int] -> Int) -> [Int] -> LengthPattern Int
forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthFoldrConst" [Int] -> Int
forall a. [a] -> Int
lengthFoldrConst [Int
1 .. Int
l],
    Text -> ([Int] -> Int) -> [Int] -> LengthPattern Int
forall a. Text -> ([a] -> Int) -> [a] -> LengthPattern a
LengthPoly Text
"lengthF" [Int] -> Int
forall a. [a] -> Int
lengthF [Int
1 .. Int
l],
    Text -> ([Int] -> Int) -> [Int] -> LengthPattern Int
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) = Text -> ([Int] -> Int) -> [Int] -> PerfT m a Int
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) = Text -> ([Int] -> Int) -> [Int] -> PerfT m a Int
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 = Measure m [a] -> PerfT m [a] () -> m (Map Text [a])
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) (PerfT m [a] () -> m (Map Text [a]))
-> PerfT m [a] () -> m (Map Text [a])
forall a b. (a -> b) -> a -> b
$ (LengthPattern Int -> PerfT m [a] Int)
-> [LengthPattern Int] -> PerfT m [a] ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LengthPattern Int -> PerfT m [a] Int
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 = Int -> [a] -> Int
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 t -> t -> t
forall a. Num a => a -> a -> a
+ t
1) ([a] -> t) -> [a] -> t
forall a b. (a -> b) -> a -> b
$! [a]
xs

-- | lazy recursion.
lengthTailLazy :: [a] -> Int
lengthTailLazy :: forall a. [a] -> Int
lengthTailLazy [a]
xs0 = Int -> [a] -> Int
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 t -> t -> t
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 = [a] -> Int -> Int
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 (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$! a
s a -> a -> a
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 = [a] -> Int -> Int
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 (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
s a -> a -> a
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [a] -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [a] -> Int
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) -> a -> Int -> Int
forall {a} {p}. Num a => p -> a -> a
f a
x ([a] -> Int
forall a. [a] -> Int
lengthAux [a]
xs)
  where
    b :: Int
b = Int
0
    f :: p -> a -> a
f p
_ a
xs = a
1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
xs

-- | foldr style
lengthFoldr :: [a] -> Int
lengthFoldr :: forall a. [a] -> Int
lengthFoldr = (a -> Int -> Int) -> Int -> [a] -> Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> Int -> Int
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 a -> a -> a
forall a. Num a => a -> a -> a
+ a
xs

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

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

-- | Monomorphic, GHC style
lengthFMono :: [Int] -> Int
lengthFMono :: [Int] -> Int
lengthFMono [Int]
xs0 = (Int -> (Int -> Int) -> Int -> Int)
-> (Int -> Int) -> [Int] -> Int -> Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> (Int -> Int) -> Int -> Int
forall a x. Num a => x -> (a -> a) -> a -> a
lengthF' Int -> Int
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) ([a] -> b) -> [a] -> b
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 (b -> b) -> b -> b
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 (b -> b) -> b -> b
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 (b -> b) -> b -> b
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 (b -> b) -> b -> b
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 = (Base [a] b -> b) -> [a] -> b
forall t a. Recursive t => (Base t a -> a) -> t -> a
forall a. (Base [a] a -> a) -> [a] -> a
cata ((Base [a] b -> b) -> [a] -> b) -> (Base [a] b -> b) -> [a] -> b
forall a b. (a -> b) -> a -> b
$ \case
  ListF a b
Base [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 = (() -> Int -> ()) -> () -> [Int] -> ()
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' () -> Int -> ()
forall a b. a -> b -> a
const () [Int
1 .. Int
x]

-- | Increment a list.
mapInc :: [Int] -> [Int]
mapInc :: [Int] -> [Int]
mapInc [Int]
xs = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int -> Int
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 = [a] -> [a] -> ([a], [a])
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) = ([a] -> [a]) -> ([a], [a]) -> ([a], [a])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (a
y :) ([a] -> [a] -> ([a], [a])
go [a]
ys [a]
zs)
    go [a]
ys [a]
_ = ([], [a]
ys)

-- | Fibonnacci
fib :: Int -> Integer
fib :: Int -> Integer
fib Int
n = if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 then Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n else Int -> Integer
fib (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
fib (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)