{-# 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 ")"