stgi-1: src/Stg/Prelude/List.hs
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Stg.Prelude.List (
nil,
concat2,
reverse,
foldl,
foldl',
foldr,
iterate,
cycle,
take,
filter,
repeat,
replicate,
sort,
naiveSort,
map,
equals_List_Int,
length,
zip,
zipWith,
forceSpine,
) where
import Prelude ()
import Data.Monoid
import Stg.Language
import Stg.Parser.QuasiQuoter
import Stg.Prelude.Function as Func
import Stg.Prelude.Number as Num
-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Stg.Language.Prettyprint
-- >>> import qualified Data.Text.IO as T
nil, concat2, foldl, foldl', foldr, iterate, cycle, take, filter,
repeat, replicate, sort, map, equals_List_Int, length, zip, zipWith,
reverse, forceSpine, naiveSort :: Program
-- | The empty list as a top-level closure.
--
-- @
-- nil : [a]
-- @
nil = [program| nil = \ -> Nil |]
-- | Concatenate two lists. Haskell's @(++)@.
--
-- @
-- concat2 : [a] -> [a] -> [a]
-- @
concat2 = [program|
concat2 = \xs ys -> case xs of
Nil -> ys;
Cons x xs' ->
let rest = \(xs' ys) => concat2 xs' ys
in Cons x rest;
badList -> Error_concat2 badList
|]
-- | Lazy left list fold. Provided mostly for seeing how it causes stack
-- overflows.
--
-- @
-- foldl : (b -> a -> b) -> b -> [a] -> b
-- @
foldl = [program|
foldl = \f acc xs -> case xs of
Nil -> acc;
Cons y ys ->
let acc' = \(f acc y) => case f acc y of v -> v
in foldl f acc' ys;
badList -> Error_foldl badList
|]
-- | Strict left list fold.
--
-- Careful: the STG only supports primitive and algebraic case scrutinees.
-- As a result, you can only hand primitive or algebraic @b@ values to this
-- function or it will fail!
--
-- @
-- foldl' : (b -> a -> b) -> b -> [a] -> b
-- @
foldl' = [program|
foldl' = \f acc xs -> case xs of
Nil -> acc;
Cons y ys -> case f acc y of
acc' -> foldl' f acc' ys;
badList -> Error_foldl' badList
|]
-- | Right list fold.
--
-- @
-- foldr : (a -> b -> b) -> b -> [a] -> b
-- @
foldr = [program|
foldr = \f z xs -> case xs of
Nil -> z;
Cons y ys ->
-- rest only used once, no need for update
let rest = \(f z ys) -> foldr f z ys
in f y rest;
badList -> Error_foldr badList
|]
-- | Build a list by repeatedly applying a function to an initial value.
--
-- @
-- iterate f x = [x, f x, f (f x), ...]
-- @
--
-- @
-- iterate : (a -> a) -> a -> [a]
-- @
iterate = [program|
iterate = \f x ->
letrec
fx = \(f x) => f x;
rest = \(f fx) => iterate f fx
in Cons x rest
|]
-- | Infinite list created by repeating an initial (non-empty) list.
--
-- @
-- cycle [x,y,z] = [x,y,z, x,y,z, x,y,z, ...]
-- @
--
-- @
-- cycle : [a] -> [a]
-- @
cycle = concat2 <> [program|
cycle = \xs ->
letrec xs' = \(xs xs') => concat2 xs xs'
in xs'
|]
-- | Take n elements form the beginning of a list.
--
-- @
-- take 3 [1..] = [1,2,3]
-- @
--
-- @
-- take : Int -> [a] -> [a]
-- @
take = [program|
take = \n ->
letrec
takePrim = \(takePrim) nPrim xs ->
case nPrim of
0# -> Nil;
default -> case xs of
Nil -> Nil;
Cons x xs ->
let rest = \(takePrim xs nPrim) => case -# nPrim 1# of
nPrimPred -> takePrim nPrimPred xs
in Cons x rest;
badList -> Error_take_badList badList
in case n of
Int# nPrim -> takePrim nPrim;
badInt -> Error_take_badInt badInt
|]
-- | Keep only the elements for which a predicate holds.
--
-- @
-- filter even [1..] = [2, 4, 6, ...]
-- @
--
-- @
-- filter : (a -> Bool) -> [a] -> [a]
-- @
filter = [program|
filter = \p xs -> case xs of
Nil -> Nil;
Cons x xs' -> case p x of
False -> filter p xs';
True ->
let rest = \(p xs') => filter p xs'
in Cons x rest;
badBool -> Error_filter_1 badBool;
badList -> Error_filter_2 badList
|]
-- | reverse a list.
--
-- @
-- reverse [1,2,3] = [3,2,1]
-- @
--
-- @
-- reverse : [a] -> [a]
-- @
reverse = nil <> [program|
reverse = \xs ->
letrec
reverse' = \(reverse') xs ys ->
case xs of
Nil -> ys;
Cons x xs ->
let yxs = \(x ys) -> Cons x ys
in reverse' xs yxs;
badList -> Error_reverse badList
in reverse' xs nil
|]
-- | Repeat a single element infinitely.
--
-- @
-- repeat 1 = [1, 1, 1, ...]
-- @
--
-- @
-- repeat : a -> [a]
-- @
repeat = [program|
repeat = \x ->
letrec xs = \(x xs) -> Cons x xs
in xs
|]
-- | Repeat a single element a number of times.
--
-- @
-- replicate 3 1 = [1, 1, 1]
-- @
--
-- @
-- replicate : Int -> a -> [a]
-- @
replicate = [program|
replicate = \n x ->
letrec
replicateXPrim = \(replicateXPrim x) nPrim ->
case ># nPrim 0# of
0# -> Nil;
default ->
let rest = \(replicateXPrim nPrim) =>
case -# nPrim 1# of
nPrimPred -> replicateXPrim nPrimPred
in Cons x rest
in case n of
Int# nPrim -> replicateXPrim nPrim;
badInt -> Error_replicate badInt
|]
-- | Haskell's Prelude sort function at the time of implementing this.
-- Not quite as pretty as the Haskell version, but functionally equivalent. :-)
--
-- This implementation is particularly efficient when the input contains runs of
-- already sorted elements. For comparison, sorting [1..100] takes 6496 steps,
-- whereas 'naiveSort' requires 268082.
--
-- @
-- sort : [Int] -> [Int]
-- @
sort = mconcat [gt_Int, Func.compose, nil] <> [program|
sort = \ =>
letrec
sequences = \(descending ascending) xs2 -> case xs2 of
Cons a xs1 -> case xs1 of
Cons b xs -> case gt_Int a b of
True -> let aList = \(a) -> Cons a nil
in descending b aList xs;
False -> let aCons = \(a) as -> Cons a as
in ascending b aCons xs;
badBool -> Error_sort_sequences1 badBool;
Nil -> Cons xs2 nil;
badList -> Error_sort_sequences2 badList;
Nil -> Cons xs2 nil;
badList -> Error_sort_sequences3 badList;
descending = \(descending sequences) a as bbs ->
letrec
aas = \(a as) -> Cons a as;
fallthrough = \(sequences aas bbs) ->
let sequencesBs = \(sequences bbs) -> sequences bbs
in Cons aas sequencesBs
in case bbs of
Cons b bs -> case gt_Int a b of
True -> descending b aas bs;
False -> fallthrough;
badBool -> Error_sort_descending1 badBool;
Nil -> fallthrough;
badList -> Error_sort_descending2 badList;
ascending = \(ascending sequences) a as bbs ->
letrec
asa = \(a as) ys ->
let aConsYs = \(a ys) -> Cons a ys
in as aConsYs;
fallthrough = \(sequences asa bbs) ->
let sequencesBs = \(sequences bbs) -> sequences bbs;
asaNil = \(asa) -> asa nil
in Cons asaNil sequencesBs
in case bbs of
Cons b bs -> case gt_Int a b of
False -> ascending b asa bs;
True -> fallthrough;
badBool -> Error_sort_ascescending1 badBool;
Nil -> fallthrough;
badList -> Error_sort_ascescending2 badList;
mergeAll = \(mergeAll mergePairs) xs -> case xs of
Cons y ys -> case ys of
Nil -> y;
Cons _1 _2 -> compose mergeAll mergePairs xs;
badList -> Error_sort_mergeAll1 badList;
Nil -> Error_sort_mergeAll_emptyListAsArgument;
badList -> Error_sort_mergeAll2 badList;
mergePairs = \(merge mergePairs) zs -> case zs of
Cons a ys -> case ys of
Cons b xs ->
let mergeAB = \(merge a b) -> merge a b;
mergePairsXs = \(mergePairs xs) -> mergePairs xs
in Cons mergeAB mergePairsXs;
Nil -> zs;
badList -> Error_sort_mergePairs1 badList;
Nil -> zs;
badList -> Error_sort_mergePairs2 badList;
merge = \(merge) as bs -> case as of
Cons a as' -> case bs of
Cons b bs' -> case gt_Int a b of
True ->
let mergeAsBs' = \(merge as bs') => merge as bs'
in Cons b mergeAsBs';
False ->
let mergeAs'Bs = \(merge as' bs) => merge as' bs
in Cons a mergeAs'Bs;
badBool -> Error_sort_merge3 badBool;
Nil -> as;
badList -> Error_sort_merge2 badList;
Nil -> bs;
badList -> Error_sort_merge1 badList
in compose mergeAll sequences |]
-- | That Haskell sort function often misleadingly referred to as "quicksort".
--
-- @
-- naiveSort : [Int] -> [Int]
-- @
naiveSort = mconcat [leq_Int, gt_Int, filter, concat2] <> [program|
naiveSort = \xs -> case xs of
Nil -> Nil;
Cons pivot xs' ->
let beforePivotSorted = \(pivot xs') =>
letrec
atMostPivot = \(pivot) y -> leq_Int y pivot;
beforePivot = \(xs' atMostPivot) => filter atMostPivot xs'
in naiveSort beforePivot;
afterPivotSorted = \(pivot xs') =>
letrec
moreThanPivot = \(pivot) y -> gt_Int y pivot;
afterPivot = \(xs' moreThanPivot) => filter moreThanPivot xs'
in naiveSort afterPivot
in let fromPivotOn = \(pivot afterPivotSorted) -> Cons pivot afterPivotSorted
in concat2 beforePivotSorted fromPivotOn;
badList -> Error_sort badList |]
-- | Apply a function to each element of a list.
--
-- @
-- map : (a -> b) -> [a] -> [b]
-- @
map = [program|
map = \f list -> case list of
Nil -> Nil;
Cons x xs -> let fx = \(f x) => f x;
fxs = \(f xs) => map f xs
in Cons fx fxs;
badList -> Error_map badList
|]
-- | Equality of lists of integers.
--
-- @
-- equals_List_Int : [Int] -> [Int] -> Bool
-- @
equals_List_Int = Num.eq_Int <> [program|
equals_List_Int = \xs ys ->
case xs of
Nil -> case ys of
Nil -> True;
Cons y ys' -> False;
badList -> Error_listEquals badList;
Cons x xs' -> case ys of
Nil -> False;
Cons y ys' -> case eq_Int x y of
True -> equals_List_Int xs' ys';
False -> False;
badBool -> Error_listEquals_1 badBool;
badList -> Error_listEquals_2 badList;
badList -> Error_listEquals_3 badList
|]
-- | Length of a list.
--
-- @
-- length : [a] -> Int
-- @
length = [program|
length = \ =>
letrec
length' = \(length') n xs -> case xs of
Nil -> Int# n;
Cons y ys -> case +# n 1# of
n' -> length' n' ys;
badList -> Error_length badList
in length' 0#
|]
-- | Zip two lists into one. If one list is longer than the other ignore the
-- exceeding elements.
--
-- @
-- zip [1,2,3,4,5] [10,20,30] ==> [(1,10),(2,20),(3,30)]
--
-- zip xs ys = zipWith Pair xs ys
-- @
--
-- @
-- zip : [a] -> [b] -> [(a,b)]
-- @
zip = [program|
zip = \xs ys -> case xs of
Nil -> Nil;
Cons x xs' -> case ys of
Nil -> Nil;
Cons y ys' ->
let tup = \(x y) -> Pair x y;
rest = \(xs' ys') => zip xs' ys'
in Cons tup rest;
badList -> Error_zip badList;
badList -> Error_zip badList
|]
-- | Zip two lists into one using a user-specified combining function.
-- If one list is longer than the other ignore the exceeding elements.
--
-- @
-- zipWith (+) [1,2,3,4,5] [10,20,30] ==> [11,22,33]
--
-- zipWith f xs ys = map f (zip xs ys)
-- @
--
-- @
-- zipWith : (a -> b -> c) -> [a] -> [b] -> [c]
-- @
zipWith = [program|
zipWith = \f xs ys -> case xs of
Nil -> Nil;
Cons x xs' -> case ys of
Nil -> Nil;
Cons y ys' ->
let fxy = \(f x y) => f x y;
rest = \(f xs' ys') => zipWith f xs' ys'
in Cons fxy rest;
badList -> Error_zipWith badList;
badList -> Error_zipWith badList
|]
-- | Force the spine of a list.
--
-- @
-- forceSpine :: [a] -> [a]
-- @
forceSpine = [program|
forceSpine = \xs ->
letrec
go = \(go) ys -> case ys of
Nil -> Done;
Cons _ ys' -> go ys';
badList -> Error_forceSpine badList
in case go xs of _ -> xs
|]