### Extra type safety using polymorphic types as first-level refinements

This post is literate Haskell.

I will demonstrate a new technique for using polytypes as first-level refinement types. (mirror). The goal, as usual, is for types to better express program invariants and ensure programs are safe.

I'm going to demonstrate using the `risers`

function, as presented in Dana N. Xu's ESC/Haskell (mirror), which references Neil Mitchell's Catch.

> {-# OPTIONS -fglasgow-exts #-} > -- The LANGUAGE pragma is usually a pain for exploratory programming.

Below are the `risers`

functions as presented by Xu and
Mitchell. They are the same function, though slightly syntacticly
different. `risers`

returns the sorted sublists of a
list.

Risers has two properties that we are going to discuss:

- None of the lists in the returned value are empty
- If the argument is non-empty, the return value is also non-empty.

> risersXu :: (Ord t) => [t] -> [[t]] > risersXu [] = [] > risersXu [x] = [[x]] > risersXu (x:y:etc) = > let ss = risersXu (y : etc) > in case x <= y of > True -> (x : (head ss)) : (tail ss) > False -> ([x]) : ss > > risersMitchell :: Ord a => [a] -> [[a]] > risersMitchell [] = [] > risersMitchell [x] = [[x]] > risersMitchell (x:y:etc) = if x <= y > then (x:s):ss > else [x]:(s:ss) > where (s:ss) = risersMitchell (y:etc)

Neither one of these functions is obviously safe. Xu uses head and
tail and ESC/Haskell to create a proof of their safety. The unsafe part
of Mitchell's code is the `where`

clause, and Mitchell also presents a
tool to prove this safe.

Our goal will be to write this function in a safe way, with a type signature that ensures the two properties we expect from the function. We also aim to do this without having to change the shape of the code, only the list implementation we are using.

The present unsafe operations in risersXu and risersMitchell depend on
the second property of the function: non-null inputs generate non-null
outputs. We could write a type for this functions using a trusted
library with phantom types for branding (paper mirror). This technique (called lightweight static capabilities) can do this
and much else as well, but since clients lose all ability to pattern match
(even in case), risers becomes much more verbose. We could also write
a type signature guaranteeing this by using GADTs. Without using one
of these, incomplete pattern matching or calling unsafe `head`

and `tail`

on the result of the recursive call seems inevitable.

Here's another way to write the function which does away with the need for the second property on the recursive call, substituting instead the need for the first property that no lists in the return value are empty:

> risersAlt :: (Ord t) => [t] -> [[t]] > risersAlt [] = [] > risersAlt (x:xs) = > case risersAlt xs of > [] -> [[x]] > w@((y:ys):z) -> > if x <= y > then (x:y:ys):z > else ([x]):w > ([]:_) -> error "risersAlt"

The error is never reached.

Though ensuring the second property with our usual types seems tricky, ensuring the first is not too tough:

> type And1 a = (a,[a]) > > risersAlt' :: Ord a => [a] -> [And1 a] > risersAlt' [] = [] > risersAlt' (x:xs) = > case risersAlt' xs of > [] -> [(x,[])] > w@(yys:z) -> > if x <= fst yys > then (x,fst yys : snd yys):z > else (x,[]):w

It is now much easier to see that risers is safe: There is one pattern match and one case, and each is simple. No unsafe functions like head or tail are called. It does have three disadvantages, however.

First, the second property is still true, but the function type does not enforce it. This means that any other callers of risers may have to use incomplete pattern matching or unsafe functions, since they may not be so easy to transform. It is my intuition that it is not frequently the case that these functions are tricky to transform, but perhaps Neil Mitchell disagrees.

We could fix this by writing another risers function with
type `And1 a -> And1 (And1 a)`

, but this brings us to
the second problem: `And1 a`

is not a subtype
of `[a]`

. This means that callers of our hypothetical other
`risers`

function (as well as consumers of the output
from `risersAlt'`

) must explicitly coerce the results back
to lists.

Finally, if we are wrong about the first property, and risers does
return an empty list for some non-empty input `i`

, then for any `x`

,
`risers (x:i)`

is `_|_`

, while ```
risersAlt'
(x:i)
```

is `[(x,[])]`

. Thus, the equivalence of these
two function definitions depends on the truth of the second property
on the first function, which is something we were trying to get out of
proving in the first place! Of course, if we're interested in the correctness of
`risersAlt'`

, rather than its equivalence with `risersXu`

or
`risersMitchell`

, then it is not to difficult to reason
about. But part of the point of this was to get they compiler to do some
of this reasoning for us, without having to change the shape of the
code.

Let's write more expressive signatures using something we may have noticed when using GHCi. The only value of type `forall a. [a]`

(excluding lists of _|_s) is `[]`

. Every value of type `forall a . Maybe a`

is `Nothing`

, and every `forall a . Either a Int`

has an `Int`

in `Right`

. Andrew Koenig noticed something similar when learning ML (archived), and the ST monad operates on a similar principle. (paper with details about ST, mirror)

> data List a n = Nil n > | forall r . a :| (List a r)

The only values of type `forall a . List a n`

use the `Nil`

constructor, and the only values of type `forall n . List a n`

use the `:|`

constructor.

> infixr :| > > box x = x :| Nil () > > type NonEmpty a = forall n . List a n > > onebox :: NonEmpty Int > onebox = box 1 > > onebox' :: List Int Dummy > onebox' = onebox > > data Dummy > > -- This doesn't compile > -- empty :: NonEmpty a > -- empty = Nil ()

`NonEmpty a`

is a subtype of `List a x`

` for all types `

`x`

.

```
> data Some fa = forall n . Some (fa n)
>
> safeHead :: NonEmpty a -> a
> safeHead x = unsafeHead x where
> unsafeHead (x :| _) = x
>
> safeTail :: NonEmpty a -> Some (List a)
> safeTail x = unsafeTail x where
> unsafeTail (_ :| xs) = Some xs
```

```
```
Unfortunately, we'll be forced to `Some`

and un-`Some`

some values, since Haskell does not have first-class existentials, and it takes some thinking to see that `safeHead`

and `safeTail`

are actually safe.

Here is a transformed version of Mitchell's risers:

> risersMitchell' :: Ord a => List a n -> List (NonEmpty a) n
> risersMitchell' (Nil x) = (Nil x)
> risersMitchell' (x :| Nil _) = box (box x)
> risersMitchell' ((x {- :: a -}) :| y :| etc) =
> case risersMitchell' (y :| etc) {- :: NonEmpty (NonEmpty a) -} of
> Nil _ -> error "risersMitchell'"
> s :| ss -> if x <= y
> then (x :| s) :| ss
> else (box x) :| s :| ss

Since we can't put the recursive call in a where clause, we must use a case with some dead code. The type annotations are commented out here to show they are not needed, but uncommenting them shows that the recursive call really does return a non-empty lists, and so the `Nil`

case really is dead code.

This type signature ensures both of the properties listed when introducing `risers`

. The key to the non-empty-arguments-produce-non-empty-results property is that the variable `n`

in the signature is used twice. That means applying `risersMitchell'`

to a list with a fixed (or existential) type as its second parameter can't produce a `NonEmpty`

list.

> risersXu' :: Ord a => List a r -> List (NonEmpty a) r
> risersXu' (Nil x) = Nil x
> risersXu' (x :| Nil _) = box (box x)
> risersXu' (((x :: a) :| y :| etc) :: List a r) =
> let ss = risersXu' (y :| etc)
> in case x <= y of
> True -> case safeTail ss of
> Some v -> (x :| (safeHead ss)) :| v
> False -> (box x) :| ss

Here we see that the type annotation isn't necessary to infer that `risers`

applied to a non-empty list returns a non-empty list. The value `ss`

isn't given a type signature, but we can apply `safeHead`

and `safeTail`

. The case matching on `safeTail`

is the pain of boxing up existentials.

This is the first version of `risers`

with a type signature that gives us the original invariant Xu and Mitchell can infer, as well as calling no unsafe functions and containing no incomplete case or let matching. It also returns a list of lists, just like the original function, and has a definition in the same shape.

With first-class existentials, this would look just like Xu's `risers`

(modulo built-in syntax for lists). With let binding for polymorphic values, `risersMitchell'`

would look just like Mitchell's original risers, but be safe by construction. Let binding for polymorphic values would also allow non-trusted implementations of `safeTail`

and
`safeHead`

to be actually safe.

For contrast, here is a GADT implementation of risers:

> data GList a n where
> GNil :: GList a IsNil
> (:||) :: a -> GList a m -> GList a IsCons
>
> infixr :||
>
> data IsNil
> data IsCons
>
> gbox x = x :|| GNil
>
> risersMitchellG :: Ord a => GList a n -> GList (GList a IsCons) n
> risersMitchellG GNil = GNil
> risersMitchellG (c :|| GNil) = gbox $ gbox c
> risersMitchellG (x :|| y :|| etc) =
> case risersMitchellG (y :|| etc) of
> -- GHC complains, "Inaccessible case alternative: Can't match types `IsCons' and `IsNil'
> -- In the pattern: GNil"
> -- GNil -> error "risers"
> s :|| ss ->
> if x <= y
> then (x :|| s) :|| ss
> else (gbox x) :|| s :|| ss

This is safe and has its safety checked by GHC. It also does not require existentials, though when using this encoding, many other list functions (such as filter) will.

Now here is a lightweight static capabilities version of risers:

> -- module Protected where
>
> -- Export type constructor, do not export value constructor
> newtype LWSC b a = LWSC_do_not_export_me [a]
>
> data Full
> type FullList = LWSC Full
>
> data Any
>
> lnil :: LWSC Any a
> lnil = LWSC_do_not_export_me []
>
> lcons :: a -> LWSC b a -> FullList a
> lcons x (LWSC_do_not_export_me xs) = LWSC_do_not_export_me (x:xs)
>
> lwhead :: FullList a -> a
> lwhead (LWSC_do_not_export_me x) = head x
>
> data Some' f n = forall a . Some' (f a n)
>
> lwtail :: FullList a -> Some' LWSC a
> lwtail (LWSC_do_not_export_me a) = Some' (LWSC_do_not_export_me (tail a))
>
> deal :: LWSC b a -> LWSC Any c -> (FullList a -> FullList c) -> LWSC b c
> deal (LWSC_do_not_export_me []) _ _ = LWSC_do_not_export_me []
> deal (LWSC_do_not_export_me x) _ f =
> case f (LWSC_do_not_export_me x) of
> LWSC_do_not_export_me z -> LWSC_do_not_export_me z
>
> nullcase :: LWSC b a -> c -> (FullList a -> c) -> c
> nullcase (LWSC_do_not_export_me []) z _ = z
> nullcase (LWSC_do_not_export_me x) _ f = f (LWSC_do_not_export_me x)
>
> -- module Risers where
>
> lbox x = lcons x lnil
>
> risersXuLW :: Ord a => LWSC b a -> LWSC b (FullList a)
> risersXuLW x =
> deal x
> lnil
> (\z -> let x = lwhead z
> in case lwtail z of
> Some' rest ->
> nullcase rest
> (lbox (lbox x))
> (\yetc ->
> let y = lwhead yetc
> etc = lwtail yetc
> ss = risersXuLW yetc
> in if x <= y
> then case lwtail ss of
> Some' v -> lcons (lcons x $ lwhead ss) v
> else lcons (lbox x) ss))

There is a good bit of code that must go in the protected module, including two different functions for case dispatch. These functions are used instead of pattern matching, and make the definition of risers much more verbose, though I may not have written it with all the oleg-magic possible to make it more usable.

Out of the three, I think GADTs are still the winning approach, but it's fun to explore this new idea, especially since Haskell doesn't have traditional subtyping.

```
```