content: {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE QuasiQuotes       #-}
  
  -- | A collection of  example programs that might be interesting to look  at
  -- during execution.
  module Stg.ExamplePrograms (
  
      -- * Simple introductory programs
  
          implies,
          addTwoNumbers,
          calculateLength,
          mapNot,
          mapNotForced,
  
      -- * Sum of list
  
          -- ** via 'Data.Foldable.foldl''
          sum_foldl',
  
          -- ** via 'Data.Foldable.foldl'' implemented with 'foldr'
          sum_foldl'ViaFoldr,
  
          -- ** via 'foldl'
          sum_foldl,
  
          -- ** via 'foldr'
          sum_foldr,
  
  
      -- * Fibonacci
  
          -- ** Naive implementation (exponential time)
          fibonacciNaive,
  
          -- ** Improved implementation (linear time)
          fibonacciImproved,
  
          -- ** Infinite list with zipWith (+)
          fibonacciZipWith,
  
  
      -- * List concatenation
  
          -- | It is well-known that Haskell's (++) operator is linear if
          -- associated to the right, but quadratic when associated to the left.
          -- These two examples showcase the issue.
  
          -- ** Right-associated
          listConcatRightAssociated,
  
          -- ** Left-associated
          listConcatLeftAssociated,
  
      -- * Sorting
      naiveSort,
      librarySort,
  
      -- * Sharing
  
          -- ** Repeat
          repeatNaive,
          repeatSharing,
  ) where
  
  
  
  import           Stg.Language
  import           Stg.Marshal
  import           Stg.Parser.QuasiQuoter
  import qualified Stg.Prelude            as Stg
  
  
  
  
  
  -- | A program that calculates @x and not y@. This is probably the simplest
  -- example program worth showing. It demonstrates how functions are evaluated,
  -- has an update for the @main@ closure, and shows how nested functions result
  -- in @let@ allocations.
  implies :: Bool -> Bool -> Program
  implies p q = mconcat
      [ Stg.or2
      , Stg.not
      , toStg "p" p
      , toStg "q" q
      , [program|
      main = \ => let notP = \ -> not p
                  in or2 notP q
      |]]
  
  -- | A program that adds two numbers.
  addTwoNumbers :: Integer -> Integer -> Program
  addTwoNumbers x y = mconcat
      [ Stg.add
      , toStg "x" x
      , toStg "y" y
      , [program|
      main = \ => add x y
      |]]
  
  -- | A program that measures the length of a list.
  calculateLength :: ToStg a => [a] -> Program
  calculateLength xs = mconcat
      [ Stg.length
      , toStg "xs" xs
      , [program|
      main = \ => length xs
      |]]
  
  -- | Negate a list of booleans, but non-strictly. This program does almost
  -- nothing, because nothing forces the list.
  mapNot :: [Bool] -> Program
  mapNot xs = mconcat
      [ Stg.not
      , Stg.map
      , toStg "xs" xs
      , [program|
      main = \ => map not xs
      |]]
  
  -- | Negate a list of booleans strictly.
  mapNotForced :: [Bool] -> Program
  mapNotForced xs = mconcat
      [ Stg.not
      , Stg.map
      , toStg "xs" xs
      , [program|
      main = \ => let mapped = \ => map not xs
                  in force mapped;
      force = \bs -> case bs of
          Nil -> Nil;
          Cons y ys -> case y of
              someBool -> case force ys of
                  someList -> Cons someBool someList;
          badList -> error_force badList
      |]]
  
  
  
  -- | Program to sum up a list, but with the @sum@ function left undefined.
  sumTemplate :: [Integer] -> Program
  sumTemplate list = mconcat
      [ Stg.add
      , toStg "zero" (0 :: Integer)
      , toStg "list" list
      , [program| main = \ => sum list |]]
  
  -- | Sum up a list of 'Integer's using
  --
  -- @
  -- sum = 'Data.Foldable.foldl'' ('+') 0
  -- @
  --
  -- This is a good way to sum up a list in Haskell, as it runs in constant space.
  sum_foldl' :: [Integer] -> Program
  sum_foldl' list = mconcat
      [ sumTemplate list
      , Stg.foldl'
      , [program| sum = \ -> foldl' add zero |]]
  
  -- | Sum up a list of 'Integer's using
  --
  -- @
  -- sum = 'Data.Foldable.foldl'' ('+') 0
  -- @
  --
  -- where 'Data.Foldable.foldl'' is implemented via 'foldr' as
  --
  -- @
  -- foldl' f z ys = 'foldr' (\x xs acc -> xs '$!' f acc x) id ys z
  -- @
  --
  -- which is a standard "'Data.Foldable.foldl'' in terms of 'foldr'" definition.
  -- This definition is denotationally equivalent to the standard
  -- 'Data.Foldable.foldl'', but has a bit more computational overhead.
  sum_foldl'ViaFoldr :: [Integer] -> Program
  sum_foldl'ViaFoldr list = mconcat
      [ sumTemplate list
      , Stg.id
      , Stg.foldr
      , [program|
      sum = \ -> foldl' add zero;
      foldl' = \f z xs ->
          let go = \(f) x xs acc -> case f acc x of
                  forced -> xs forced
          in foldr go id xs z
      |]]
  
  -- | Sum up a list of 'Integer's using
  --
  -- @
  -- sum = 'foldl' ('+') 0
  -- @
  --
  -- This is the canonical space leak in Haskell: note how the accumulator is
  -- lazy, resulting in a large thunk buildup of suspended additions, that is only
  -- collapsed to a final value after 'foldl' has terminated. The thunks are
  -- stored on the heap, so it grows linearly with the length of the list. When
  -- that thunk is forced, it will push lots of additions on the stack; in
  -- summary, this produces a heap overflow, and if the heap is not exhausted, it
  -- will try to overflow the stack.
  sum_foldl :: [Integer] -> Program
  sum_foldl list = mconcat
      [ sumTemplate list
      , Stg.foldl
      , [program| sum = \ -> foldl add zero |]]
  
  -- | Sum up a list of 'Integer's using
  --
  -- @
  -- sum = 'foldr' ('+') 0
  -- @
  --
  -- Like the 'foldl' version demonstrated in 'sum_foldl', this is a space-leaking
  -- implementation of the sum of a list. In this case however, the leak spills to
  -- the stack and the heap alike: the stack contains the continuations for the
  -- additions, while the heap contains thunks for the recursive call to @foldr@.
  sum_foldr :: [Integer] -> Program
  sum_foldr list = mconcat
      [ sumTemplate list
      , Stg.foldr
      , [program| sum = \ -> foldr add zero |]]
  
  
  
  -- | Compute the list of Fibonacci numbers eagerly in the contents, but lazy in
  -- the spine.
  --
  -- This means that the program will successively generate all the Fibonacci
  -- numbers, allocating new cells of the infinite list and calculating their new
  -- values, and garbage collecting previous values.
  --
  -- You can picture this as what happens to `fibo` in the Haskell program
  --
  -- @
  -- main = let fibo = 'zipWith' ('+') fibo ('tail' fibo)
  --        in 'Data.Foldable.traverse_' 'print' fibo
  -- @
  fibonacciZipWith :: Program
  fibonacciZipWith = mconcat
      [ Stg.add
      , toStg "zero" (0 :: Integer)
      , Stg.foldl'
      , Stg.zipWith
      , [program|
  
      flipConst = \x y -> y;
      main = \ =>
          letrec
              fibo = \ =>
                  letrec
                      fib0 = \(fib1) -> Cons zero fib1;
                      fib1 = \(fib2) =>
                          let one = \ -> Int# 1#
                          in Cons one fib2;
                      fib2 = \(fib0 fib1) => zipWith add fib0 fib1
                  in fib0
          in foldl' flipConst zero fibo
      |]]
  
  -- | Calculate the n-th Fibonacci number using the computationally (horribly)
  -- inefficient formula
  --
  -- @
  -- fib n | n <= 1 = n
  -- fib n = fib (n-1) + fib (n-2)
  -- @
  --
  -- This implementation is stack-only, so enjoy watching it explode. At the time
  -- of writing this, the machine takes:
  --
  -- * fib  0  =>    27 steps
  -- * fib  1  =>    27 steps
  -- * fib  2  =>   122 steps
  -- * fib  3  =>   218 steps
  -- * fib  4  =>   410 steps
  -- * fib  5  =>   698 steps
  -- * fib  6  =>  1178 steps
  -- * fib  7  =>  1946 steps
  -- * fib  8  =>  3194 steps
  -- * fib  9  =>  5210 steps
  -- * fib 10  =>  8474 steps
  fibonacciNaive :: Integer -> Program
  fibonacciNaive n = mconcat
      [ Stg.add
      , Stg.leq_Int
      , Stg.sub
      , toStg "one" (1 :: Integer)
      , toStg "n" n
      , [program|
      main = \ =>
          letrec
              fib = \(fib) n -> case leq_Int n one of
              True -> n;
              _False -> case sub n one of
                  nMinusOne -> case fib nMinusOne of
                      fibNMinusOne -> case sub nMinusOne one of
                          nMinusTwo -> case fib nMinusTwo of
                              fibNMinusTwo -> case add fibNMinusOne fibNMinusTwo of
                                  result -> result
          in fib n
      |]]
  
  -- | Calculate the n-th Fibonacci number using the more efficient formula
  --
  -- @
  -- fib = fib' 0 1
  --   where
  --     fib' x _ | n <= 0 = x
  --     fib' x !y n = fib' y (x+y) (n-1)
  -- @
  --
  -- This implementation is a lot faster than the naive exponential
  -- implementation. For example, calculating the 10th Fibonacci number (55) takes
  -- only 490 steps, compared to the many thousands of the exponential version.
  fibonacciImproved :: Integer -> Program
  fibonacciImproved n = mconcat
      [ Stg.add
      , Stg.leq_Int
      , Stg.sub
      , toStg "zero" (0 :: Integer)
      , toStg "one" (1 :: Integer)
      , toStg "n" n
      , [program|
      main = \ =>
          letrec
              fib = \(fib') -> fib' zero one;
              fib' = \(fib') x y n -> case leq_Int n zero of
                  True -> x;
                  _False -> case add x y of
                      xy -> case sub n one of
                          nMinusOne -> fib' y xy nMinusOne
          in fib n
      |]]
  
  -- | List concatenation example with the 'concat' definition left out.
  listConcatTemplate :: ToStg a => [[a]] -> Program
  listConcatTemplate xss = mconcat
      [ toStg "xss" xss
      , Stg.concat2
      , [program|
  
      forceList = \xs -> case xs of
          Nil -> Done;
          Cons _ xs' -> forceList xs';
          _ -> BadListError;
  
      concatenated = \ => concat xss;
      main = \ => case forceList concatenated of
          _ -> concatenated
  
      |]]
  
  -- | Force a right-associated concatenation
  --
  -- @
  -- [0] '++' ([1] '++' ([2] '++' ([3])))
  -- @
  --
  -- and store it in the @main@ closure.
  --
  -- This computation is __linear__ in the number of elements of the sublists.
  listConcatRightAssociated :: ToStg a => [[a]] -> Program
  listConcatRightAssociated xss = mconcat
      [ listConcatTemplate xss
      , Stg.foldr
      , [program| concat = \ -> foldr concat2 nil |]]
  
  -- | Force a left-associated concatenation
  --
  -- @
  -- (([0] '++' [1]) '++' [2]) '++' [3]
  -- @
  --
  -- and store it in the @main@ closure.
  --
  -- This computation is __quadratic__ in the number of elements of the sublists.
  listConcatLeftAssociated :: ToStg a => [[a]] -> Program
  listConcatLeftAssociated xss = mconcat
      [ listConcatTemplate xss
      , Stg.foldl'
      , [program| concat = \ -> foldl' concat2 nil |]]
  
  -- | Sort a list with the canonical Quicksort-inspired algorithm often found
  -- in introductory texts about Haskell.
  --
  -- Note that this is not Quicksort itself, as one key feature of it is sorting
  -- in-place. In particular, this algorithm is not all that quick, as it takes
  -- almost a thousand steps to reach the final state when sorting @[5,4,3,2,1]@.
  naiveSort :: [Integer] -> Program
  naiveSort xs =
      toStg "xs" xs
      <> Stg.forceSpine
      <> Stg.naiveSort
      <> [program|
          sorted = \ => naiveSort xs;
          main = \ => forceSpine sorted |]
  
  -- | Sort a list with a translation of Haskell's 'Data.List.sort', which is
  -- an implementation of mergesort with ordered sublist detection.
  librarySort :: [Integer] -> Program
  librarySort xs =
      toStg "xs" xs
      <> Stg.forceSpine
      <> Stg.sort
      <> [program|
          sorted = \ => sort xs;
          main = \ => forceSpine sorted |]
  
  
  
  -- | This is a naive implementation of the 'repeat' function,
  --
  -- @
  -- 'repeat' x = x : 'repeat' x
  -- @
  --
  -- and it is used to compute the infinite repetition of a number. Run this
  -- program for a couple hundred steps and observe the heap and the garbage
  -- collector. Count the GC invocations, and compare it to the behaviour of
  -- 'repeatSharing'! Also note how long it takes to generate two successive
  -- list elements.
  --
  -- The reason for this behaviour is that the call to @'repeat' x@ is not shared,
  -- but done again for each cons cell, requiring one heap allocation every time.
  -- Cleaning up after this keeps the GC quite busy.
  repeatNaive :: Program
  repeatNaive = repeatSharing <> [program|
      repeat = \x ->
          let repeatX = \(x) -> repeat x
          in Cons x repeatX
      |]
  
  -- | This uses a much better definition of 'repeat',
  --
  -- @
  -- 'repeat' x = let repeatX = x : repeatX
  --            in repeatX
  -- @
  --
  -- This program does only a total of three heap allocations before continuously
  -- running without interruption: one for the @repeated@ value, one for the
  -- self-referencing cons cell, and one because of how 'Stg.forceSpine' works.
  --
  -- Note how much smaller the cycles between the traversal of two neighbouring
  -- list cells are!
  repeatSharing :: Program
  repeatSharing = mconcat
      [ Stg.forceSpine
      , Stg.repeat
      , [program|
      main = \ =>
          let repeated = \ -> repeat 1#
          in case forceSpine repeated of v -> v
      |]]
  