{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1993-1998


This is useful, general stuff for the Native Code Generator.

Provide trees (of instructions), so that lists of instructions
can be appended in linear time.
-}
{-# LANGUAGE DeriveFunctor #-}

{-# LANGUAGE BangPatterns #-}

module OrdList (
        OrdList,
        nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL,
        headOL,
        mapOL, fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse,
        strictlyEqOL, strictlyOrdOL
) where

import GhcPrelude
import Data.Foldable

import Outputable

import qualified Data.Semigroup as Semigroup

infixl 5  `appOL`
infixl 5  `snocOL`
infixr 5  `consOL`

data OrdList a
  = None
  | One a
  | Many [a]          -- Invariant: non-empty
  | Cons a (OrdList a)
  | Snoc (OrdList a) a
  | Two (OrdList a) -- Invariant: non-empty
        (OrdList a) -- Invariant: non-empty
  deriving (a -> OrdList b -> OrdList a
(a -> b) -> OrdList a -> OrdList b
(forall a b. (a -> b) -> OrdList a -> OrdList b)
-> (forall a b. a -> OrdList b -> OrdList a) -> Functor OrdList
forall a b. a -> OrdList b -> OrdList a
forall a b. (a -> b) -> OrdList a -> OrdList b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> OrdList b -> OrdList a
$c<$ :: forall a b. a -> OrdList b -> OrdList a
fmap :: (a -> b) -> OrdList a -> OrdList b
$cfmap :: forall a b. (a -> b) -> OrdList a -> OrdList b
Functor)

instance Outputable a => Outputable (OrdList a) where
  ppr :: OrdList a -> SDoc
ppr ol :: OrdList a
ol = [a] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OrdList a -> [a]
forall a. OrdList a -> [a]
fromOL OrdList a
ol)  -- Convert to list and print that

instance Semigroup (OrdList a) where
  <> :: OrdList a -> OrdList a -> OrdList a
(<>) = OrdList a -> OrdList a -> OrdList a
forall a. OrdList a -> OrdList a -> OrdList a
appOL

instance Monoid (OrdList a) where
  mempty :: OrdList a
mempty = OrdList a
forall a. OrdList a
nilOL
  mappend :: OrdList a -> OrdList a -> OrdList a
mappend = OrdList a -> OrdList a -> OrdList a
forall a. Semigroup a => a -> a -> a
(Semigroup.<>)
  mconcat :: [OrdList a] -> OrdList a
mconcat = [OrdList a] -> OrdList a
forall a. [OrdList a] -> OrdList a
concatOL

instance Foldable OrdList where
  foldr :: (a -> b -> b) -> b -> OrdList a -> b
foldr   = (a -> b -> b) -> b -> OrdList a -> b
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL
  foldl' :: (b -> a -> b) -> b -> OrdList a -> b
foldl'  = (b -> a -> b) -> b -> OrdList a -> b
forall b a. (b -> a -> b) -> b -> OrdList a -> b
foldlOL
  toList :: OrdList a -> [a]
toList  = OrdList a -> [a]
forall a. OrdList a -> [a]
fromOL
  null :: OrdList a -> Bool
null    = OrdList a -> Bool
forall a. OrdList a -> Bool
isNilOL
  length :: OrdList a -> Int
length  = OrdList a -> Int
forall a. OrdList a -> Int
lengthOL

instance Traversable OrdList where
  traverse :: (a -> f b) -> OrdList a -> f (OrdList b)
traverse f :: a -> f b
f xs :: OrdList a
xs = [b] -> OrdList b
forall a. [a] -> OrdList a
toOL ([b] -> OrdList b) -> f [b] -> f (OrdList b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> [a] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f (OrdList a -> [a]
forall a. OrdList a -> [a]
fromOL OrdList a
xs)

nilOL    :: OrdList a
isNilOL  :: OrdList a -> Bool

unitOL   :: a           -> OrdList a
snocOL   :: OrdList a   -> a         -> OrdList a
consOL   :: a           -> OrdList a -> OrdList a
appOL    :: OrdList a   -> OrdList a -> OrdList a
concatOL :: [OrdList a] -> OrdList a
headOL   :: OrdList a   -> a
lastOL   :: OrdList a   -> a
lengthOL :: OrdList a   -> Int

nilOL :: OrdList a
nilOL        = OrdList a
forall a. OrdList a
None
unitOL :: a -> OrdList a
unitOL as :: a
as    = a -> OrdList a
forall a. a -> OrdList a
One a
as
snocOL :: OrdList a -> a -> OrdList a
snocOL as :: OrdList a
as   b :: a
b    = OrdList a -> a -> OrdList a
forall a. OrdList a -> a -> OrdList a
Snoc OrdList a
as a
b
consOL :: a -> OrdList a -> OrdList a
consOL a :: a
a    bs :: OrdList a
bs   = a -> OrdList a -> OrdList a
forall a. a -> OrdList a -> OrdList a
Cons a
a OrdList a
bs
concatOL :: [OrdList a] -> OrdList a
concatOL aas :: [OrdList a]
aas = (OrdList a -> OrdList a -> OrdList a)
-> OrdList a -> [OrdList a] -> OrdList a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr OrdList a -> OrdList a -> OrdList a
forall a. OrdList a -> OrdList a -> OrdList a
appOL OrdList a
forall a. OrdList a
None [OrdList a]
aas

headOL :: OrdList a -> a
headOL None        = String -> a
forall a. String -> a
panic "headOL"
headOL (One a :: a
a)     = a
a
headOL (Many as :: [a]
as)   = [a] -> a
forall a. [a] -> a
head [a]
as
headOL (Cons a :: a
a _)  = a
a
headOL (Snoc as :: OrdList a
as _) = OrdList a -> a
forall a. OrdList a -> a
headOL OrdList a
as
headOL (Two as :: OrdList a
as _)  = OrdList a -> a
forall a. OrdList a -> a
headOL OrdList a
as

lastOL :: OrdList a -> a
lastOL None        = String -> a
forall a. String -> a
panic "lastOL"
lastOL (One a :: a
a)     = a
a
lastOL (Many as :: [a]
as)   = [a] -> a
forall a. [a] -> a
last [a]
as
lastOL (Cons _ as :: OrdList a
as) = OrdList a -> a
forall a. OrdList a -> a
lastOL OrdList a
as
lastOL (Snoc _ a :: a
a)  = a
a
lastOL (Two _ as :: OrdList a
as)  = OrdList a -> a
forall a. OrdList a -> a
lastOL OrdList a
as

lengthOL :: OrdList a -> Int
lengthOL None        = 0
lengthOL (One _)     = 1
lengthOL (Many as :: [a]
as)   = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as
lengthOL (Cons _ as :: OrdList a
as) = 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ OrdList a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length OrdList a
as
lengthOL (Snoc as :: OrdList a
as _) = 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ OrdList a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length OrdList a
as
lengthOL (Two as :: OrdList a
as bs :: OrdList a
bs) = OrdList a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length OrdList a
as Int -> Int -> Int
forall a. Num a => a -> a -> a
+ OrdList a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length OrdList a
bs

isNilOL :: OrdList a -> Bool
isNilOL None = Bool
True
isNilOL _    = Bool
False

None  appOL :: OrdList a -> OrdList a -> OrdList a
`appOL` b :: OrdList a
b     = OrdList a
b
a :: OrdList a
a     `appOL` None  = OrdList a
a
One a :: a
a `appOL` b :: OrdList a
b     = a -> OrdList a -> OrdList a
forall a. a -> OrdList a -> OrdList a
Cons a
a OrdList a
b
a :: OrdList a
a     `appOL` One b :: a
b = OrdList a -> a -> OrdList a
forall a. OrdList a -> a -> OrdList a
Snoc OrdList a
a a
b
a :: OrdList a
a     `appOL` b :: OrdList a
b     = OrdList a -> OrdList a -> OrdList a
forall a. OrdList a -> OrdList a -> OrdList a
Two OrdList a
a OrdList a
b

fromOL :: OrdList a -> [a]
fromOL :: OrdList a -> [a]
fromOL a :: OrdList a
a = OrdList a -> [a] -> [a]
forall a. OrdList a -> [a] -> [a]
go OrdList a
a []
  where go :: OrdList a -> [a] -> [a]
go None       acc :: [a]
acc = [a]
acc
        go (One a :: a
a)    acc :: [a]
acc = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc
        go (Cons a :: a
a b :: OrdList a
b) acc :: [a]
acc = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: OrdList a -> [a] -> [a]
go OrdList a
b [a]
acc
        go (Snoc a :: OrdList a
a b :: a
b) acc :: [a]
acc = OrdList a -> [a] -> [a]
go OrdList a
a (a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc)
        go (Two a :: OrdList a
a b :: OrdList a
b)  acc :: [a]
acc = OrdList a -> [a] -> [a]
go OrdList a
a (OrdList a -> [a] -> [a]
go OrdList a
b [a]
acc)
        go (Many xs :: [a]
xs)  acc :: [a]
acc = [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
acc

fromOLReverse :: OrdList a -> [a]
fromOLReverse :: OrdList a -> [a]
fromOLReverse a :: OrdList a
a = OrdList a -> [a] -> [a]
forall a. OrdList a -> [a] -> [a]
go OrdList a
a []
        -- acc is already in reverse order
  where go :: OrdList a -> [a] -> [a]
        go :: OrdList a -> [a] -> [a]
go None       acc :: [a]
acc = [a]
acc
        go (One a :: a
a)    acc :: [a]
acc = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc
        go (Cons a :: a
a b :: OrdList a
b) acc :: [a]
acc = OrdList a -> [a] -> [a]
forall a. OrdList a -> [a] -> [a]
go OrdList a
b (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc)
        go (Snoc a :: OrdList a
a b :: a
b) acc :: [a]
acc = a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: OrdList a -> [a] -> [a]
forall a. OrdList a -> [a] -> [a]
go OrdList a
a [a]
acc
        go (Two a :: OrdList a
a b :: OrdList a
b)  acc :: [a]
acc = OrdList a -> [a] -> [a]
forall a. OrdList a -> [a] -> [a]
go OrdList a
b (OrdList a -> [a] -> [a]
forall a. OrdList a -> [a] -> [a]
go OrdList a
a [a]
acc)
        go (Many xs :: [a]
xs)  acc :: [a]
acc = [a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
acc

mapOL :: (a -> b) -> OrdList a -> OrdList b
mapOL :: (a -> b) -> OrdList a -> OrdList b
mapOL = (a -> b) -> OrdList a -> OrdList b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

foldrOL :: (a->b->b) -> b -> OrdList a -> b
foldrOL :: (a -> b -> b) -> b -> OrdList a -> b
foldrOL _ z :: b
z None        = b
z
foldrOL k :: a -> b -> b
k z :: b
z (One x :: a
x)     = a -> b -> b
k a
x b
z
foldrOL k :: a -> b -> b
k z :: b
z (Cons x :: a
x xs :: OrdList a
xs) = a -> b -> b
k a
x ((a -> b -> b) -> b -> OrdList a -> b
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL a -> b -> b
k b
z OrdList a
xs)
foldrOL k :: a -> b -> b
k z :: b
z (Snoc xs :: OrdList a
xs x :: a
x) = (a -> b -> b) -> b -> OrdList a -> b
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL a -> b -> b
k (a -> b -> b
k a
x b
z) OrdList a
xs
foldrOL k :: a -> b -> b
k z :: b
z (Two b1 :: OrdList a
b1 b2 :: OrdList a
b2) = (a -> b -> b) -> b -> OrdList a -> b
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL a -> b -> b
k ((a -> b -> b) -> b -> OrdList a -> b
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL a -> b -> b
k b
z OrdList a
b2) OrdList a
b1
foldrOL k :: a -> b -> b
k z :: b
z (Many xs :: [a]
xs)   = (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> b -> b
k b
z [a]
xs

-- | Strict left fold.
foldlOL :: (b->a->b) -> b -> OrdList a -> b
foldlOL :: (b -> a -> b) -> b -> OrdList a -> b
foldlOL _ z :: b
z None        = b
z
foldlOL k :: b -> a -> b
k z :: b
z (One x :: a
x)     = b -> a -> b
k b
z a
x
foldlOL k :: b -> a -> b
k z :: b
z (Cons x :: a
x xs :: OrdList a
xs) = let !z' :: b
z' = (b -> a -> b
k b
z a
x) in (b -> a -> b) -> b -> OrdList a -> b
forall b a. (b -> a -> b) -> b -> OrdList a -> b
foldlOL b -> a -> b
k b
z' OrdList a
xs
foldlOL k :: b -> a -> b
k z :: b
z (Snoc xs :: OrdList a
xs x :: a
x) = let !z' :: b
z' = ((b -> a -> b) -> b -> OrdList a -> b
forall b a. (b -> a -> b) -> b -> OrdList a -> b
foldlOL b -> a -> b
k b
z OrdList a
xs) in b -> a -> b
k b
z' a
x
foldlOL k :: b -> a -> b
k z :: b
z (Two b1 :: OrdList a
b1 b2 :: OrdList a
b2) = let !z' :: b
z' = ((b -> a -> b) -> b -> OrdList a -> b
forall b a. (b -> a -> b) -> b -> OrdList a -> b
foldlOL b -> a -> b
k b
z OrdList a
b1) in (b -> a -> b) -> b -> OrdList a -> b
forall b a. (b -> a -> b) -> b -> OrdList a -> b
foldlOL b -> a -> b
k b
z' OrdList a
b2
foldlOL k :: b -> a -> b
k z :: b
z (Many xs :: [a]
xs)   = (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' b -> a -> b
k b
z [a]
xs

toOL :: [a] -> OrdList a
toOL :: [a] -> OrdList a
toOL [] = OrdList a
forall a. OrdList a
None
toOL [x :: a
x] = a -> OrdList a
forall a. a -> OrdList a
One a
x
toOL xs :: [a]
xs = [a] -> OrdList a
forall a. [a] -> OrdList a
Many [a]
xs

reverseOL :: OrdList a -> OrdList a
reverseOL :: OrdList a -> OrdList a
reverseOL None = OrdList a
forall a. OrdList a
None
reverseOL (One x :: a
x) = a -> OrdList a
forall a. a -> OrdList a
One a
x
reverseOL (Cons a :: a
a b :: OrdList a
b) = OrdList a -> a -> OrdList a
forall a. OrdList a -> a -> OrdList a
Snoc (OrdList a -> OrdList a
forall a. OrdList a -> OrdList a
reverseOL OrdList a
b) a
a
reverseOL (Snoc a :: OrdList a
a b :: a
b) = a -> OrdList a -> OrdList a
forall a. a -> OrdList a -> OrdList a
Cons a
b (OrdList a -> OrdList a
forall a. OrdList a -> OrdList a
reverseOL OrdList a
a)
reverseOL (Two a :: OrdList a
a b :: OrdList a
b)  = OrdList a -> OrdList a -> OrdList a
forall a. OrdList a -> OrdList a -> OrdList a
Two (OrdList a -> OrdList a
forall a. OrdList a -> OrdList a
reverseOL OrdList a
b) (OrdList a -> OrdList a
forall a. OrdList a -> OrdList a
reverseOL OrdList a
a)
reverseOL (Many xs :: [a]
xs)  = [a] -> OrdList a
forall a. [a] -> OrdList a
Many ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs)

-- | Compare not only the values but also the structure of two lists
strictlyEqOL :: Eq a => OrdList a   -> OrdList a -> Bool
strictlyEqOL :: OrdList a -> OrdList a -> Bool
strictlyEqOL None         None       = Bool
True
strictlyEqOL (One x :: a
x)     (One y :: a
y)     = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
strictlyEqOL (Cons a :: a
a as :: OrdList a
as) (Cons b :: a
b bs :: OrdList a
bs) = a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b Bool -> Bool -> Bool
&& OrdList a
as OrdList a -> OrdList a -> Bool
forall a. Eq a => OrdList a -> OrdList a -> Bool
`strictlyEqOL` OrdList a
bs
strictlyEqOL (Snoc as :: OrdList a
as a :: a
a) (Snoc bs :: OrdList a
bs b :: a
b) = a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b Bool -> Bool -> Bool
&& OrdList a
as OrdList a -> OrdList a -> Bool
forall a. Eq a => OrdList a -> OrdList a -> Bool
`strictlyEqOL` OrdList a
bs
strictlyEqOL (Two a1 :: OrdList a
a1 a2 :: OrdList a
a2) (Two b1 :: OrdList a
b1 b2 :: OrdList a
b2) = OrdList a
a1 OrdList a -> OrdList a -> Bool
forall a. Eq a => OrdList a -> OrdList a -> Bool
`strictlyEqOL` OrdList a
b1 Bool -> Bool -> Bool
&& OrdList a
a2 OrdList a -> OrdList a -> Bool
forall a. Eq a => OrdList a -> OrdList a -> Bool
`strictlyEqOL` OrdList a
b2
strictlyEqOL (Many as :: [a]
as)   (Many bs :: [a]
bs)   = [a]
as [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a]
bs
strictlyEqOL _            _          = Bool
False

-- | Compare not only the values but also the structure of two lists
strictlyOrdOL :: Ord a => OrdList a   -> OrdList a -> Ordering
strictlyOrdOL :: OrdList a -> OrdList a -> Ordering
strictlyOrdOL None         None       = Ordering
EQ
strictlyOrdOL None         _          = Ordering
LT
strictlyOrdOL (One x :: a
x)     (One y :: a
y)     = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
x a
y
strictlyOrdOL (One _)      _          = Ordering
LT
strictlyOrdOL (Cons a :: a
a as :: OrdList a
as) (Cons b :: a
b bs :: OrdList a
bs) =
  a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` OrdList a -> OrdList a -> Ordering
forall a. Ord a => OrdList a -> OrdList a -> Ordering
strictlyOrdOL OrdList a
as OrdList a
bs
strictlyOrdOL (Cons _ _)   _          = Ordering
LT
strictlyOrdOL (Snoc as :: OrdList a
as a :: a
a) (Snoc bs :: OrdList a
bs b :: a
b) =
  a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` OrdList a -> OrdList a -> Ordering
forall a. Ord a => OrdList a -> OrdList a -> Ordering
strictlyOrdOL OrdList a
as OrdList a
bs
strictlyOrdOL (Snoc _ _)   _          = Ordering
LT
strictlyOrdOL (Two a1 :: OrdList a
a1 a2 :: OrdList a
a2) (Two b1 :: OrdList a
b1 b2 :: OrdList a
b2) =
  (OrdList a -> OrdList a -> Ordering
forall a. Ord a => OrdList a -> OrdList a -> Ordering
strictlyOrdOL OrdList a
a1 OrdList a
b1) Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` (OrdList a -> OrdList a -> Ordering
forall a. Ord a => OrdList a -> OrdList a -> Ordering
strictlyOrdOL OrdList a
a2 OrdList a
b2)
strictlyOrdOL (Two _ _)    _          = Ordering
LT
strictlyOrdOL (Many as :: [a]
as)   (Many bs :: [a]
bs)   = [a] -> [a] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [a]
as [a]
bs
strictlyOrdOL (Many _ )   _           = Ordering
GT