{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- | This module contains strict versions of some standard data
-- structures.



module Rattus.Strict
  ( List(..),
    reverse',
    (+++),
    listToMaybe',
    mapMaybe',
    (:*)(..),
    Maybe'(..),
    maybe',
   fst',
   snd',
  )where

import Data.VectorSpace

infixr 2 :*
infixr 8 :!

-- | Strict list type.
data List a = Nil | !a :! !(List a)

-- | Reverse a list.
reverse' :: List a -> List a
reverse' :: List a -> List a
reverse' List a
l =  List a -> List a -> List a
forall a. List a -> List a -> List a
rev List a
l List a
forall a. List a
Nil
  where
    rev :: List a -> List a -> List a
rev List a
Nil     List a
a = List a
a
    rev (a
x:!List a
xs) List a
a = List a -> List a -> List a
rev List a
xs (a
xa -> List a -> List a
forall a. a -> List a -> List a
:!List a
a)
    
-- | Returns @'Nothing''@ on an empty list or @'Just'' a@ where @a@ is the
-- first element of the list.
listToMaybe' :: List a -> Maybe' a
listToMaybe' :: List a -> Maybe' a
listToMaybe' = (a -> Maybe' a -> Maybe' a) -> Maybe' a -> List a -> Maybe' a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Maybe' a -> Maybe' a -> Maybe' a
forall a b. a -> b -> a
const (Maybe' a -> Maybe' a -> Maybe' a)
-> (a -> Maybe' a) -> a -> Maybe' a -> Maybe' a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe' a
forall a. a -> Maybe' a
Just') Maybe' a
forall a. Maybe' a
Nothing'

-- | Append two lists.
(+++) :: List a -> List a -> List a
+++ :: List a -> List a -> List a
(+++) List a
Nil     List a
ys = List a
ys
(+++) (a
x:!List a
xs) List a
ys = a
x a -> List a -> List a
forall a. a -> List a -> List a
:! List a
xs List a -> List a -> List a
forall a. List a -> List a -> List a
+++ List a
ys


-- | A version of 'map' which can throw out elements.  In particular,
-- the function argument returns something of type @'Maybe'' b@.  If
-- this is 'Nothing'', no element is added on to the result list.  If
-- it is @'Just'' b@, then @b@ is included in the result list.
mapMaybe'          :: (a -> Maybe' b) -> List a -> List b
mapMaybe' :: (a -> Maybe' b) -> List a -> List b
mapMaybe' a -> Maybe' b
_ List a
Nil     = List b
forall a. List a
Nil
mapMaybe' a -> Maybe' b
f (a
x:!List a
xs) =
 let rs :: List b
rs = (a -> Maybe' b) -> List a -> List b
forall a b. (a -> Maybe' b) -> List a -> List b
mapMaybe' a -> Maybe' b
f List a
xs in
 case a -> Maybe' b
f a
x of
  Maybe' b
Nothing' -> List b
rs
  Just' b
r  -> b
rb -> List b -> List b
forall a. a -> List a -> List a
:!List b
rs

instance Foldable List where
  
  foldMap :: (a -> m) -> List a -> m
foldMap a -> m
f = List a -> m
run where
    run :: List a -> m
run List a
Nil = m
forall a. Monoid a => a
mempty
    run (a
x :! List a
xs) = a -> m
f a
x m -> m -> m
forall a. Semigroup a => a -> a -> a
<> List a -> m
run List a
xs
  foldr :: (a -> b -> b) -> b -> List a -> b
foldr a -> b -> b
f = b -> List a -> b
run where
    run :: b -> List a -> b
run b
b List a
Nil = b
b
    run b
b (a
a :! List a
as) = (b -> List a -> b
run (b -> List a -> b) -> b -> List a -> b
forall a b. (a -> b) -> a -> b
$! (a -> b -> b
f a
a b
b)) List a
as
  foldl :: (b -> a -> b) -> b -> List a -> b
foldl b -> a -> b
f = b -> List a -> b
run where
    run :: b -> List a -> b
run b
a List a
Nil = b
a
    run b
a (a
b :! List a
bs) = (b -> List a -> b
run (b -> List a -> b) -> b -> List a -> b
forall a b. (a -> b) -> a -> b
$! (b -> a -> b
f b
a a
b)) List a
bs
  elem :: a -> List a -> Bool
elem a
a = List a -> Bool
run where
    run :: List a -> Bool
run List a
Nil = Bool
False
    run (a
x :! List a
xs)
      | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x = Bool
True
      | Bool
otherwise = List a -> Bool
run List a
xs
    
  
instance Functor List where
  fmap :: (a -> b) -> List a -> List b
fmap a -> b
f = List a -> List b
run where
    run :: List a -> List b
run List a
Nil = List b
forall a. List a
Nil
    run (a
x :! List a
xs) = a -> b
f a
x b -> List b -> List b
forall a. a -> List a -> List a
:! List a -> List b
run List a
xs


-- | Strict variant of 'Maybe'.
data Maybe' a = Just' ! a | Nothing'

-- | takes a default value, a function, and a 'Maybe'' value.  If the
-- 'Maybe'' value is 'Nothing'', the function returns the default
-- value.  Otherwise, it applies the function to the value inside the
-- 'Just'' and returns the result.
maybe' :: b -> (a -> b) -> Maybe' a -> b
maybe' :: b -> (a -> b) -> Maybe' a -> b
maybe' b
n a -> b
_ Maybe' a
Nothing'  = b
n
maybe' b
_ a -> b
f (Just' a
x) = a -> b
f a
x

-- | Strict pair type.
data a :* b = !a :* !b

-- | First projection function.
fst' :: (a :* b) -> a
fst' :: (a :* b) -> a
fst' (a
a:*b
_) = a
a

-- | Second projection function.
snd' :: (a :* b) -> b
snd' :: (a :* b) -> b
snd' (a
_:*b
b) = b
b


instance RealFloat a => VectorSpace (a :* a) a where
    zeroVector :: a :* a
zeroVector = a
0 a -> a -> a :* a
forall a b. a -> b -> a :* b
:* a
0

    a
a *^ :: a -> (a :* a) -> a :* a
*^ (a
x :* a
y) = (a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
x) a -> a -> a :* a
forall a b. a -> b -> a :* b
:* (a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
y)

    (a
x :* a
y) ^/ :: (a :* a) -> a -> a :* a
^/ a
a = (a
x a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
a) a -> a -> a :* a
forall a b. a -> b -> a :* b
:* (a
y a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
a)

    negateVector :: (a :* a) -> a :* a
negateVector (a
x :* a
y) = (-a
x) a -> a -> a :* a
forall a b. a -> b -> a :* b
:* (-a
y)

    (a
x1 :* a
y1) ^+^ :: (a :* a) -> (a :* a) -> a :* a
^+^ (a
x2 :* a
y2) = (a
x1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
x2) a -> a -> a :* a
forall a b. a -> b -> a :* b
:* (a
y1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
y2)

    (a
x1 :* a
y1) ^-^ :: (a :* a) -> (a :* a) -> a :* a
^-^ (a
x2 :* a
y2) = (a
x1 a -> a -> a
forall a. Num a => a -> a -> a
- a
x2) a -> a -> a :* a
forall a b. a -> b -> a :* b
:* (a
y1 a -> a -> a
forall a. Num a => a -> a -> a
- a
y2)

    (a
x1 :* a
y1) dot :: (a :* a) -> (a :* a) -> a
`dot` (a
x2 :* a
y2) = a
x1 a -> a -> a
forall a. Num a => a -> a -> a
* a
x2 a -> a -> a
forall a. Num a => a -> a -> a
+ a
y1 a -> a -> a
forall a. Num a => a -> a -> a
* a
y2

instance Functor ((:*) a) where
  fmap :: (a -> b) -> (a :* a) -> a :* b
fmap a -> b
f (a
x:*a
y) = (a
x a -> b -> a :* b
forall a b. a -> b -> a :* b
:* a -> b
f a
y)
  
instance (Show a, Show b) => Show (a:*b) where
  show :: (a :* b) -> String
show (a
a :* b
b) = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :* " String -> ShowS
forall a. [a] -> [a] -> [a]
++ b -> String
forall a. Show a => a -> String
show b
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"