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

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



module AsyncRattus.Strict
  ( List(..),
    singleton,
    fromList,
    toList,
    init',
    reverse',
    (+++),
    listToMaybe',
    map',
    zip',
    zipWith',
    mapMaybe',
    (:*)(..),
    Maybe'(..),
    maybe',
    fromMaybe',
    fst',
    snd',
    curry',
    uncurry'
  )where

import Prelude hiding (map)
import Data.VectorSpace

infixr 2 :*
infixr 8 :!

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

singleton :: a -> List a
singleton :: forall a. a -> List a
singleton a
x = a
x a -> List a -> List a
forall a. a -> List a -> List a
:! List a
forall a. List a
Nil

fromList :: [a] -> List a
fromList :: forall a. [a] -> List a
fromList [] = List a
forall a. List a
Nil
fromList (a
x : [a]
xs) = a
x a -> List a -> List a
forall a. a -> List a -> List a
:! [a] -> List a
forall a. [a] -> List a
fromList [a]
xs

toList :: List a -> [a]
toList :: forall a. List a -> [a]
toList List a
Nil = []
toList (a
x :! List a
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: List a -> [a]
forall a. List a -> [a]
toList List a
xs

-- | Remove the last element from a list if there is one, otherwise
-- return 'Nil'.
init' :: List a -> List a
init' :: forall a. List a -> List a
init' List a
Nil = List a
forall a. List a
Nil
init' (a
_ :! List a
Nil) = List a
forall a. List a
Nil
init' (a
x :! List a
xs) = a
x a -> List a -> List a
forall a. a -> List a -> List a
:! List a -> List a
forall a. List a -> List a
init' List a
xs

-- | Reverse a list.
reverse' :: List a -> List a
reverse' :: forall a. 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' :: forall a. List a -> Maybe' a
listToMaybe' List a
Nil = Maybe' a
forall a. Maybe' a
Nothing'
listToMaybe' (a
x :! List a
_) = a -> Maybe' a
forall a. a -> Maybe' a
Just' a
x

-- | Append two lists.
(+++) :: List a -> List a -> List a
+++ :: forall {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


map' :: (a -> b) -> List a -> List b
map' :: forall a b. (a -> b) -> List a -> List b
map' a -> b
_ List a
Nil = List b
forall a. List a
Nil
map' a -> b
f (a
x :! List a
xs) = a -> b
f a
x b -> List b -> List b
forall a. a -> List a -> List a
:! (a -> b) -> List a -> List b
forall a b. (a -> b) -> List a -> List b
map' a -> b
f List a
xs

zip' :: List a -> List b -> List (a :* b)
zip' :: forall a b. List a -> List b -> List (a :* b)
zip' List a
Nil List b
_ = List (a :* b)
forall a. List a
Nil
zip' List a
_ List b
Nil = List (a :* b)
forall a. List a
Nil
zip' (a
x :! List a
xs) (b
y :! List b
ys) = (a
x a -> b -> a :* b
forall a b. a -> b -> a :* b
:* b
y) (a :* b) -> List (a :* b) -> List (a :* b)
forall a. a -> List a -> List a
:! List a -> List b -> List (a :* b)
forall a b. List a -> List b -> List (a :* b)
zip' List a
xs List b
ys

zipWith' :: (a -> b -> c) -> List a -> List b -> List c
zipWith' :: forall a b c. (a -> b -> c) -> List a -> List b -> List c
zipWith' a -> b -> c
_ List a
Nil List b
_ = List c
forall a. List a
Nil
zipWith' a -> b -> c
_ List a
_ List b
Nil = List c
forall a. List a
Nil
zipWith' a -> b -> c
f (a
x :! List a
xs) (b
y :! List b
ys) = a -> b -> c
f a
x b
y c -> List c -> List c
forall a. a -> List a -> List a
:! (a -> b -> c) -> List a -> List b -> List c
forall a b c. (a -> b -> c) -> List a -> List b -> List c
zipWith' a -> b -> c
f List a
xs List b
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' :: forall a b. (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 :: forall m a. Monoid m => (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 :: forall a b. (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 :: forall b a. (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 :: forall a. Eq a => 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 :: forall a b. (a -> b) -> List a -> List b
fmap = (a -> b) -> List a -> List b
forall a b. (a -> b) -> List a -> List b
map'

instance Eq a => Eq (List a) where
  List a
Nil == :: List a -> List a -> Bool
== List a
Nil = Bool
True
  List a
Nil == List a
_ = Bool
False
  List a
_ == List a
Nil = Bool
False
  (a
x :! List a
xs) == (a
y :! List a
ys) = if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y then List a
xs List a -> List a -> Bool
forall a. Eq a => a -> a -> Bool
== List a
ys else Bool
False

instance Show a => Show (List a) where
  show :: List a -> String
show List a
Nil = String
"Nil"
  show (a
x :! List a
xs) = a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :! " String -> ShowS
forall a. [a] -> [a] -> [a]
++ List a -> String
forall a. Show a => a -> String
show List a
xs

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

instance Eq a => Eq (Maybe' a) where
  Maybe' a
Nothing' == :: Maybe' a -> Maybe' a -> Bool
== Maybe' a
Nothing' = Bool
True
  Just' a
x == Just' a
y = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
  Maybe' a
_ == Maybe' a
_ = Bool
False

instance Show a => Show (Maybe' a) where
  show :: Maybe' a -> String
show Maybe' a
Nothing' = String
"Nothing'"
  show (Just' a
x) = String
"Just' " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x

-- | 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' :: forall b a. 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

fromMaybe' :: a -> Maybe' a -> a
fromMaybe' :: forall a. a -> Maybe' a -> a
fromMaybe' a
_ (Just' a
x) = a
x
fromMaybe' a
d Maybe' a
Nothing' = a
d

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

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

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

curry' :: ((a :* b) -> c) -> a -> b -> c
curry' :: forall a b c. ((a :* b) -> c) -> a -> b -> c
curry' (a :* b) -> c
f a
x b
y = (a :* b) -> c
f (a
x a -> b -> a :* b
forall a b. a -> b -> a :* b
:* b
y)

uncurry' :: (a -> b -> c) -> (a :* b) -> c
uncurry' :: forall a b c. (a -> b -> c) -> (a :* b) -> c
uncurry' a -> b -> c
f (a
x :* b
y) = a -> b -> c
f a
x b
y


instance Functor ((:*) a) where
  fmap :: forall a b. (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
")"

instance (Eq a, Eq b) => Eq (a :* b) where
  (a
x1 :* b
y1) == :: (a :* b) -> (a :* b) -> Bool
== (a
x2 :* b
y2) = a
x1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x2 Bool -> Bool -> Bool
&& b
y1 b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
y2


instance (VectorSpace v a, VectorSpace w a, Floating a, Eq a) => VectorSpace (v :* w) a where
  zeroVector :: v :* w
zeroVector = v
forall v a. VectorSpace v a => v
zeroVector v -> w -> v :* w
forall a b. a -> b -> a :* b
:* w
forall v a. VectorSpace v a => v
zeroVector

  a
a *^ :: a -> (v :* w) -> v :* w
*^ (v
x :* w
y) = (a
a a -> v -> v
forall v a. VectorSpace v a => a -> v -> v
*^ v
x) v -> w -> v :* w
forall a b. a -> b -> a :* b
:* (a
a a -> w -> w
forall v a. VectorSpace v a => a -> v -> v
*^ w
y)

  (v
x :* w
y) ^/ :: (v :* w) -> a -> v :* w
^/ a
a = (v
x v -> a -> v
forall v a. VectorSpace v a => v -> a -> v
^/ a
a) v -> w -> v :* w
forall a b. a -> b -> a :* b
:* (w
y w -> a -> w
forall v a. VectorSpace v a => v -> a -> v
^/ a
a)

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

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

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

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