{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LinearTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Foreign.List where

import qualified Data.List as List
import Foreign.Marshal.Pure (Box, Pool)
import qualified Foreign.Marshal.Pure as Manual
import Prelude.Linear hiding (foldl, foldr, map)

-- XXX: we keep the last Cons in Memory here. A better approach would be to
-- always keep a Box instead.
data List a
  = Nil
  | Cons !a !(Box (List a))

-- TODO: generating appropriate instances using the Generic framework
instance
  (Manual.Representable a) =>
  Manual.MkRepresentable (List a) (Maybe (a, Box (List a)))
  where
  toRepr :: List a %1 -> Maybe (a, Box (List a))
toRepr List a
Nil = Maybe (a, Box (List a))
forall a. Maybe a
Nothing
  toRepr (Cons a
a Box (List a)
l) = (a, Box (List a)) -> Maybe (a, Box (List a))
forall a. a -> Maybe a
Just (a
a, Box (List a)
l)

  ofRepr :: Maybe (a, Box (List a)) %1 -> List a
ofRepr Maybe (a, Box (List a))
Nothing = List a
forall a. List a
Nil
  ofRepr (Just (a
a, Box (List a)
l)) = a -> Box (List a) -> List a
forall a. a -> Box (List a) -> List a
Cons a
a Box (List a)
l

instance (Manual.Representable a) => Manual.Representable (List a) where
  type AsKnown (List a) = Manual.AsKnown (Maybe (a, Box (List a)))

-- Remark: this is a bit wasteful, we could implement an allocation-free map by
-- reusing the old pointer with realloc.
--
-- XXX: the mapped function should be of type (a %1-> Pool %1-> b)
--
-- Remark: map could be tail-recursive in destination-passing style
map :: forall a b. (Manual.Representable a, Manual.Representable b) => (a %1 -> b) -> List a %1 -> Pool %1 -> List b
map :: forall a b.
(Representable a, Representable b) =>
(a %1 -> b) -> List a %1 -> Pool %1 -> List b
map a %1 -> b
_f List a
Nil Pool
pool = Pool
pool Pool %1 -> List b %1 -> List b
forall a b. Consumable a => a %1 -> b %1 -> b
`lseq` List b
forall a. List a
Nil
map a %1 -> b
f (Cons a
a Box (List a)
l) Pool
pool =
  (Pool, Pool) %1 -> a %1 -> List a %1 -> List b
withPools (Pool %1 -> (Pool, Pool)
forall a. Dupable a => a %1 -> (a, a)
dup Pool
pool) a
a (Box (List a) %1 -> List a
forall a. Representable a => Box a %1 -> a
Manual.deconstruct Box (List a)
l)
  where
    withPools :: (Pool, Pool) %1 -> a %1 -> List a %1 -> List b
    withPools :: (Pool, Pool) %1 -> a %1 -> List a %1 -> List b
withPools (Pool
pool1, Pool
pool2) a
a' List a
l' =
      b -> Box (List b) -> List b
forall a. a -> Box (List a) -> List a
Cons (a %1 -> b
f a
a') (List b %1 -> Pool %1 -> Box (List b)
forall a. Representable a => a %1 -> Pool %1 -> Box a
Manual.alloc ((a %1 -> b) -> List a %1 -> Pool %1 -> List b
forall a b.
(Representable a, Representable b) =>
(a %1 -> b) -> List a %1 -> Pool %1 -> List b
map a %1 -> b
f List a
l' Pool
pool1) Pool
pool2)

foldr :: forall a b. (Manual.Representable a) => (a %1 -> b %1 -> b) -> b %1 -> List a %1 -> b
foldr :: forall a b.
Representable a =>
(a %1 -> b %1 -> b) -> b %1 -> List a %1 -> b
foldr a %1 -> b %1 -> b
_f b
seed List a
Nil = b
seed
foldr a %1 -> b %1 -> b
f b
seed (Cons a
a Box (List a)
l) = a %1 -> b %1 -> b
f a
a ((a %1 -> b %1 -> b) -> b %1 -> List a %1 -> b
forall a b.
Representable a =>
(a %1 -> b %1 -> b) -> b %1 -> List a %1 -> b
foldr a %1 -> b %1 -> b
f b
seed (Box (List a) %1 -> List a
forall a. Representable a => Box a %1 -> a
Manual.deconstruct Box (List a)
l))

foldl :: forall a b. (Manual.Representable a) => (b %1 -> a %1 -> b) -> b %1 -> List a %1 -> b
foldl :: forall a b.
Representable a =>
(b %1 -> a %1 -> b) -> b %1 -> List a %1 -> b
foldl b %1 -> a %1 -> b
_f b
seed List a
Nil = b
seed
foldl b %1 -> a %1 -> b
f b
seed (Cons a
a Box (List a)
l) = (b %1 -> a %1 -> b) -> b %1 -> List a %1 -> b
forall a b.
Representable a =>
(b %1 -> a %1 -> b) -> b %1 -> List a %1 -> b
foldl b %1 -> a %1 -> b
f (b %1 -> a %1 -> b
f b
seed a
a) (Box (List a) %1 -> List a
forall a. Representable a => Box a %1 -> a
Manual.deconstruct Box (List a)
l)

-- Remark: could be tail-recursive with destination-passing style

-- | Make a 'List' from a stream. 'List' is a type of strict lists, therefore
-- the stream must terminate otherwise 'unfold' will loop. Not tail-recursive.
unfold :: forall a s. (Manual.Representable a) => (s -> Maybe (a, s)) -> s -> Pool %1 -> List a
unfold :: forall a s.
Representable a =>
(s -> Maybe (a, s)) -> s -> Pool %1 -> List a
unfold s -> Maybe (a, s)
step s
state Pool
pool = Maybe (a, s) -> (Pool, Pool) %1 -> List a
dispatch (s -> Maybe (a, s)
step s
state) (Pool %1 -> (Pool, Pool)
forall a. Dupable a => a %1 -> (a, a)
dup Pool
pool)
  where
    -- XXX: ^ The reason why we need to `dup` the pool before we know whether the
    -- next step is a `Nothing` (in which case we don't need the pool at all) or a
    -- `Just`, is because of the limitation of `case` to the unrestricted
    -- case. Will be fixed.

    dispatch :: Maybe (a, s) -> (Pool, Pool) %1 -> List a
    dispatch :: Maybe (a, s) -> (Pool, Pool) %1 -> List a
dispatch Maybe (a, s)
Nothing (Pool, Pool)
pools = (Pool, Pool)
pools (Pool, Pool) %1 -> List a %1 -> List a
forall a b. Consumable a => a %1 -> b %1 -> b
`lseq` List a
forall a. List a
Nil
    dispatch (Just (a
a, s
next)) (Pool
pool1, Pool
pool2) =
      a -> Box (List a) -> List a
forall a. a -> Box (List a) -> List a
Cons a
a (List a %1 -> Pool %1 -> Box (List a)
forall a. Representable a => a %1 -> Pool %1 -> Box a
Manual.alloc ((s -> Maybe (a, s)) -> s -> Pool %1 -> List a
forall a s.
Representable a =>
(s -> Maybe (a, s)) -> s -> Pool %1 -> List a
unfold s -> Maybe (a, s)
step s
next Pool
pool1) Pool
pool2)

-- | Linear variant of 'unfold'. Note how they are implemented exactly
-- identically. They could be merged if multiplicity polymorphism was supported.
unfoldL :: forall a s. (Manual.Representable a) => (s %1 -> Maybe (a, s)) -> s %1 -> Pool %1 -> List a
unfoldL :: forall a s.
Representable a =>
(s %1 -> Maybe (a, s)) -> s %1 -> Pool %1 -> List a
unfoldL s %1 -> Maybe (a, s)
step s
state Pool
pool = Maybe (a, s) %1 -> (Pool, Pool) %1 -> List a
dispatch (s %1 -> Maybe (a, s)
step s
state) (Pool %1 -> (Pool, Pool)
forall a. Dupable a => a %1 -> (a, a)
dup Pool
pool)
  where
    dispatch :: Maybe (a, s) %1 -> (Pool, Pool) %1 -> List a
    dispatch :: Maybe (a, s) %1 -> (Pool, Pool) %1 -> List a
dispatch Maybe (a, s)
Nothing (Pool, Pool)
pools = (Pool, Pool)
pools (Pool, Pool) %1 -> List a %1 -> List a
forall a b. Consumable a => a %1 -> b %1 -> b
`lseq` List a
forall a. List a
Nil
    dispatch (Just (a
a, s
next)) (Pool
pool1, Pool
pool2) =
      a -> Box (List a) -> List a
forall a. a -> Box (List a) -> List a
Cons a
a (List a %1 -> Pool %1 -> Box (List a)
forall a. Representable a => a %1 -> Pool %1 -> Box a
Manual.alloc ((s %1 -> Maybe (a, s)) -> s %1 -> Pool %1 -> List a
forall a s.
Representable a =>
(s %1 -> Maybe (a, s)) -> s %1 -> Pool %1 -> List a
unfoldL s %1 -> Maybe (a, s)
step s
next Pool
pool1) Pool
pool2)

ofList :: (Manual.Representable a) => [a] -> Pool %1 -> List a
ofList :: forall a. Representable a => [a] -> Pool %1 -> List a
ofList [a]
l Pool
pool = ([a] -> Maybe (a, [a])) -> [a] -> Pool %1 -> List a
forall a s.
Representable a =>
(s -> Maybe (a, s)) -> s -> Pool %1 -> List a
unfold [a] -> Maybe (a, [a])
forall a. [a] -> Maybe (a, [a])
List.uncons [a]
l Pool
pool

toList :: (Manual.Representable a) => List a %1 -> [a]
toList :: forall a. Representable a => List a %1 -> [a]
toList List a
l = (a %1 -> [a] %1 -> [a]) -> [a] %1 -> List a %1 -> [a]
forall a b.
Representable a =>
(a %1 -> b %1 -> b) -> b %1 -> List a %1 -> b
foldr (:) [] List a
l

-- | Like unfold but builds the list in reverse, and tail recursive
runfold :: forall a s. (Manual.Representable a) => (s -> Maybe (a, s)) -> s -> Pool %1 -> List a
runfold :: forall a s.
Representable a =>
(s -> Maybe (a, s)) -> s -> Pool %1 -> List a
runfold s -> Maybe (a, s)
step s
state Pool
pool = s -> List a %1 -> Pool %1 -> List a
loop s
state List a
forall a. List a
Nil Pool
pool
  where
    loop :: s -> List a %1 -> Pool %1 -> List a
    loop :: s -> List a %1 -> Pool %1 -> List a
loop s
state' List a
acc Pool
pool' = Maybe (a, s) -> List a %1 -> (Pool, Pool) %1 -> List a
dispatch (s -> Maybe (a, s)
step s
state') List a
acc (Pool %1 -> (Pool, Pool)
forall a. Dupable a => a %1 -> (a, a)
dup Pool
pool')

    dispatch :: Maybe (a, s) -> List a %1 -> (Pool, Pool) %1 -> List a
    dispatch :: Maybe (a, s) -> List a %1 -> (Pool, Pool) %1 -> List a
dispatch Maybe (a, s)
Nothing !List a
acc (Pool, Pool)
pools = (Pool, Pool)
pools (Pool, Pool) %1 -> List a %1 -> List a
forall a b. Consumable a => a %1 -> b %1 -> b
`lseq` List a
acc
    dispatch (Just (a
a, s
next)) !List a
acc (Pool
pool1, Pool
pool2) =
      s -> List a %1 -> Pool %1 -> List a
loop s
next (a -> Box (List a) -> List a
forall a. a -> Box (List a) -> List a
Cons a
a (List a %1 -> Pool %1 -> Box (List a)
forall a. Representable a => a %1 -> Pool %1 -> Box a
Manual.alloc List a
acc Pool
pool1)) Pool
pool2

ofRList :: (Manual.Representable a) => [a] -> Pool %1 -> List a
ofRList :: forall a. Representable a => [a] -> Pool %1 -> List a
ofRList [a]
l Pool
pool = ([a] -> Maybe (a, [a])) -> [a] -> Pool %1 -> List a
forall a s.
Representable a =>
(s -> Maybe (a, s)) -> s -> Pool %1 -> List a
runfold [a] -> Maybe (a, [a])
forall a. [a] -> Maybe (a, [a])
List.uncons [a]
l Pool
pool