Some.hs

------------------------------------------------------------------------
-- |
-- Module           : Data.Parameterized.Some
-- Copyright        : (c) Galois, Inc 2014-2019
-- Maintainer       : Joe Hendrix <jhendrix@galois.com>
-- Description : a GADT that hides a type parameter
--
-- This module provides 'Some', a GADT that hides a type parameter.
------------------------------------------------------------------------
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
module Data.Parameterized.Some
  ( Some(..)
  , viewSome
  , mapSome
  , traverseSome
  , traverseSome_
  , someLens
  ) where

import Data.Hashable
import Data.Kind (Type)
import Data.Parameterized.Classes
import Data.Parameterized.TraversableF
import Lens.Micro (Lens', lens, (&), (^.), (.~))


data Some (f:: k -> Type) = forall x . Some (f x)

instance TestEquality f => Eq (Some f) where
  Some x == Some y = isJust (testEquality x y)

instance OrdF f => Ord (Some f) where
  compare (Some x) (Some y) = toOrdering (compareF x y)

instance (HashableF f, TestEquality f) => Hashable (Some f) where
  hashWithSalt s (Some x) = hashWithSaltF s x
  hash (Some x) = hashF x

instance ShowF f => Show (Some f) where
  show (Some x) = showF x

-- | Project out of Some.
viewSome :: (forall tp . f tp -> r) -> Some f -> r
viewSome f (Some x) = f x

-- | Apply function to inner value.
mapSome :: (forall tp . f tp -> g tp) -> Some f -> Some g
mapSome f (Some x) = Some $! f x

{-# INLINE traverseSome #-}
-- | Modify the inner value.
traverseSome :: Functor m
             => (forall tp . f tp -> m (g tp))
             -> Some f
             -> m (Some g)
traverseSome f (Some x) = Some `fmap` f x

{-# INLINE traverseSome_ #-}
-- | Modify the inner value.
traverseSome_ :: Functor m => (forall tp . f tp -> m ()) -> Some f -> m ()
traverseSome_ f (Some x) = (\_ -> ()) `fmap` f x

instance FunctorF     Some where fmapF     = mapSome
instance FoldableF    Some where foldMapF  = foldMapFDefault
instance TraversableF Some where traverseF = traverseSome

-- | A lens that is polymorphic in the index may be used on a value with an
-- existentially-quantified index.
someLens :: (forall tp. Lens' (f tp) a) -> Lens' (Some f) a
someLens l = lens (\(Some x) -> x ^. l) (\(Some x) v -> Some (x & l .~ v))