{-# OPTIONS -fplugin=Rattus.Plugin #-}

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

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



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

import Data.VectorSpace
import Rattus.Primitives
import Rattus.Plugin.Annotation

infixr 2 :*
infixr 8 :!

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


{-# ANN module Rattus #-}
-- All recursive functions in this module are defined by structural
-- induction on a strict type.
{-# ANN module AllowRecursion #-}

-- | Turns a list of delayed computations into a delayed computation
-- that produces a list of values.
listDelay :: List (O a) -> O (List a)
listDelay :: forall a. List (O a) -> O (List a)
listDelay List (O a)
Nil = forall a. a -> O a
delay forall a. List a
Nil
listDelay (O a
x :! List (O a)
xs) = let xs' :: O (List a)
xs' = forall a. List (O a) -> O (List a)
listDelay List (O a)
xs in forall a. a -> O a
delay (forall a. O a -> a
adv O a
x forall a. a -> List a -> List a
:! forall a. O a -> a
adv O (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 = forall a. List a
Nil
init' (a
_ :! List a
Nil) = forall a. List a
Nil
init' (a
x :! List a
xs) = a
x forall a. 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 =  forall {a}. List a -> List a -> List a
rev List a
l 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
xforall 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' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe' a
Just') forall a. Maybe' a
Nothing'

-- | 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 forall a. a -> List a -> List a
:! List a
xs 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' :: forall a b. (a -> Maybe' b) -> List a -> List b
mapMaybe' a -> Maybe' b
_ List a
Nil     = forall a. List a
Nil
mapMaybe' a -> Maybe' b
f (a
x:!List a
xs) =
 let rs :: List b
rs = 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
rforall 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 = forall a. Monoid a => a
mempty
    run (a
x :! List a
xs) = a -> m
f a
x 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 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 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 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
f = List a -> List b
run where
    run :: List a -> List b
run List a
Nil = forall a. List a
Nil
    run (a
x :! List a
xs) = a -> b
f a
x 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' :: 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

-- | 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


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

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

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

    negateVector :: (a :* a) -> a :* a
negateVector (a
x :* a
y) = (-a
x) 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 forall a. Num a => a -> a -> a
+ a
x2) forall a b. a -> b -> a :* b
:* (a
y1 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 forall a. Num a => a -> a -> a
- a
x2) forall a b. a -> b -> a :* b
:* (a
y1 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 forall a. Num a => a -> a -> a
* a
x2 forall a. Num a => a -> a -> a
+ a
y1 forall a. Num a => a -> a -> a
* a
y2

instance Functor ((:*) a) where
  fmap :: forall a b. (a -> b) -> (a :* a) -> a :* b
fmap a -> b
f (a
x:*a
y) = (a
x 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
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
a forall a. [a] -> [a] -> [a]
++ String
" :* " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show b
b forall a. [a] -> [a] -> [a]
++ String
")"