-- {-# LANGUAGE #-}
{-# OPTIONS_GHC -Wall #-}
----------------------------------------------------------------------
-- |
-- Module      :  Data.Laxer
-- Copyright   :  (c) Conal Elliott 2010
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Some laxer operations.
-- See <http://conal.net/blog/posts/lazier-functional-programming-part-2/>
----------------------------------------------------------------------

module Data.Laxer (eitherL,condL,foldrL,maybeL,fairZipWith, fairZip) where

import Data.Lub
import Data.Glb

-- | Laxer if-then-else, due to Luke Palmer.
--
-- @
-- condL a a undefined = a
-- condL (Left 3) (Left undefined) undefined = Left undefined
-- @
condL :: (HasLub a, HasGlb a) =>
         a -> a -> Bool -> a
condL :: a -> a -> Bool -> a
condL a
a a
b = a -> Bool -> a
forall a b. a -> b -> a
const (a
a a -> a -> a
forall a. HasGlb a => a -> a -> a
`glb` a
b) (Bool -> a) -> (Bool -> a) -> Bool -> a
forall a. HasLub a => a -> a -> a
`lub` (\ Bool
c -> if Bool
c then a
a else a
b)

-- | Laxer variant of 'either'
eitherL :: (HasLub c, HasGlb c) =>
           (a -> c) -> (b -> c) -> (Either a b -> c)
eitherL :: (a -> c) -> (b -> c) -> Either a b -> c
eitherL a -> c
f b -> c
g = c -> Either a b -> c
forall a b. a -> b -> a
const (a -> c
f a
forall a. HasCallStack => a
undefined c -> c -> c
forall a. HasGlb a => a -> a -> a
`glb` b -> c
g b
forall a. HasCallStack => a
undefined) (Either a b -> c) -> (Either a b -> c) -> Either a b -> c
forall a. HasLub a => a -> a -> a
`lub` (a -> c) -> (b -> c) -> Either a b -> c
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> c
f b -> c
g

-- | Laxer variant of 'maybe'
maybeL :: (HasLub b, HasGlb b) =>
           b -> (a -> b) -> (Maybe a -> b)
maybeL :: b -> (a -> b) -> Maybe a -> b
maybeL b
n a -> b
j = b -> Maybe a -> b
forall a b. a -> b -> a
const (b
n b -> b -> b
forall a. HasGlb a => a -> a -> a
`glb` a -> b
j a
forall a. HasCallStack => a
undefined) (Maybe a -> b) -> (Maybe a -> b) -> Maybe a -> b
forall a. HasLub a => a -> a -> a
`lub` b -> (a -> b) -> Maybe a -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
n a -> b
j

-- | Laxer variant of 'foldr' for lists
foldrL :: (HasLub b, HasGlb b) => (a -> b -> b) -> b -> [a] -> b
foldrL :: (a -> b -> b) -> b -> [a] -> b
foldrL a -> b -> b
c b
n = b -> [a] -> b
forall a b. a -> b -> a
const b
fallback ([a] -> b) -> ([a] -> b) -> [a] -> b
forall a. HasLub a => a -> a -> a
`lub` [a] -> b
go
  where
    fallback :: b
fallback = b
n b -> b -> b
forall a. HasGlb a => a -> a -> a
`glb` a -> b -> b
c a
forall a. HasCallStack => a
undefined b
forall a. HasCallStack => a
undefined
    go :: [a] -> b
go [] = b
n
    go (a
x : [a]
xs) = a -> b -> b
c a
x (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$ b
fallback b -> b -> b
forall a. HasLub a => a -> a -> a
`lub` [a] -> b
go [a]
xs

-- | A version of 'zipWith' that succeeds if either list
-- ends at the same time the other one bottoms out.
--
-- Laws:
--
-- > fairZipWith >= zipWith
-- > flip . fairZipWith = fairZipWith . flip
fairZipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
fairZipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
fairZipWith a -> b -> c
f [a]
as [b]
bs =
  (() -> a -> b -> c) -> [()] -> [a] -> [b] -> [c]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3
    ((a -> b -> c) -> () -> a -> b -> c
forall a b. a -> b -> a
const a -> b -> c
f)
    ([()] -> [()] -> [()]
forall a. HasLub a => a -> a -> a
lub ((a -> b -> ()) -> [a] -> [b] -> [()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> b -> ()
forall p p. p -> p -> ()
discard [a]
as [b]
bs) ((b -> a -> ()) -> [b] -> [a] -> [()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith b -> a -> ()
forall p p. p -> p -> ()
discard [b]
bs [a]
as))
    [a]
as
    [b]
bs
  where
    discard :: p -> p -> ()
discard p
_ p
_ = ()

-- | @fairZip = fairZipWith (,)@
fairZip :: [a] -> [b] -> [(a, b)]
fairZip :: [a] -> [b] -> [(a, b)]
fairZip = (a -> b -> (a, b)) -> [a] -> [b] -> [(a, b)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
fairZipWith (,)

{- -- Examples:

-- It takes care to check that some of these examples are computed
-- correctly, since printing stops at the first error.  For instance, ask
-- for t5!!1 .

q :: Int
q = undefined `unamb` 5

t0 :: Int
t0 = condL 3 4 True

t1,t2 :: Int
t1 = condL 6 8 undefined  -- _|_
t2 = condL 7 7 undefined  -- 7

t3,t4 :: (Int,Int)
t3 = condL (3,4) (4,5) undefined  -- (_|_,_|_)
t4 = condL (3,4) (3,5) undefined  -- (3,_|_)

t5 :: [Int]
t5 = condL [2,3,5] [1,3] undefined  -- _|_:3:_|_


fe1 :: Either Float Bool -> (Int,String)
fe1 = eitherL (\ x -> (3,"beetle " ++ show x)) (\ b -> (3,"battle " ++ show b))

s1 :: (Int,String)
s1 = fe1 undefined
-- (3,"b*** Exception: glb: bottom (flat & unequal)

s2 :: String
s2 = (tail.tail.tail.snd) (fe1 undefined)
-- "tle *** Exception: Prelude.undefined

s3 :: (Int,String)
s3 = fe1 (Left pi)

-}