{- |
   The HList library

   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke

   Result-type-driven operations on typeful heterogeneous lists.
-}

module Data.HList.HOccurs (
    module Data.HList.HOccurs,
    ) where

import Data.HList.FakePrelude
import Data.HList.HListPrelude
import Data.HList.HList

-- --------------------------------------------------------------------------
-- Given an HList l and an element type e return the suffix of l
-- whose head has the type e. Return HNil if l does not have
-- an element of type e.

class HOccurrence (e1 :: *) (l :: [*]) (l' :: [*]) | e1 l -> l' where
    hOccurrence :: Proxy e1 -> HList l -> HList l'

instance HOccurrence e1 '[] '[] where
    hOccurrence :: Proxy e1 -> HList '[] -> HList '[]
hOccurrence Proxy e1
_ = HList '[] -> HList '[]
forall a. a -> a
id

instance (HEq e1 e b, HOccurrence' b e1 (e ': l) l')
    => HOccurrence e1 (e ': l) l' where
    hOccurrence :: Proxy e1 -> HList (e : l) -> HList l'
hOccurrence = Proxy b -> Proxy e1 -> HList (e : l) -> HList l'
forall (b :: Bool) e1 (l :: [*]) (l' :: [*]).
HOccurrence' b e1 l l' =>
Proxy b -> Proxy e1 -> HList l -> HList l'
hOccurrence' (Proxy b
forall k (t :: k). Proxy t
Proxy::Proxy b)

class HOccurrence' (b :: Bool) (e1 :: *) (l :: [*]) (l' :: [*]) | b e1 l -> l' where
    hOccurrence' :: Proxy b -> Proxy e1 -> HList l -> HList l'

instance HOccurrence' True e1 (e ': l) (e ': l) where
    hOccurrence' :: Proxy 'True -> Proxy e1 -> HList (e : l) -> HList (e : l)
hOccurrence' Proxy 'True
_ Proxy e1
_ = HList (e : l) -> HList (e : l)
forall a. a -> a
id

instance HOccurrence e1 l l' => HOccurrence' False e1 (e ': l) l' where
    hOccurrence' :: Proxy 'False -> Proxy e1 -> HList (e : l) -> HList l'
hOccurrence' Proxy 'False
_ Proxy e1
e (HCons _ l) = Proxy e1 -> HList l -> HList l'
forall e1 (l :: [*]) (l' :: [*]).
HOccurrence e1 l l' =>
Proxy e1 -> HList l -> HList l'
hOccurrence Proxy e1
e HList l
l


-- --------------------------------------------------------------------------
-- Zero or more occurrences

class HOccursMany e (l :: [*]) where
  hOccursMany :: HList l -> [e]

instance (HOccurrence e l l', HOccursMany' e l')
    => HOccursMany e l
 where
  hOccursMany :: HList l -> [e]
hOccursMany HList l
l = HList l' -> [e]
forall e (l :: [*]). HOccursMany' e l => HList l -> [e]
hOccursMany' (Proxy e -> HList l -> HList l'
forall e1 (l :: [*]) (l' :: [*]).
HOccurrence e1 l l' =>
Proxy e1 -> HList l -> HList l'
hOccurrence (Proxy e
forall k (t :: k). Proxy t
Proxy::Proxy e) HList l
l)

class HOccursMany' e l where
  hOccursMany' :: HList l -> [e]

instance HOccursMany' e '[] where
  hOccursMany' :: HList '[] -> [e]
hOccursMany' HList '[]
_ = []

instance (e ~ e1, HOccursMany e l) => HOccursMany' e (e1 ': l) where
  hOccursMany' :: HList (e1 : l) -> [e]
hOccursMany' (HCons e l) = e1
e e1 -> [e1] -> [e1]
forall a. a -> [a] -> [a]
: HList l -> [e1]
forall e (l :: [*]). HOccursMany e l => HList l -> [e]
hOccursMany HList l
l


-- --------------------------------------------------------------------------
-- One or more occurrences

hOccursMany1 :: forall e l l'.
                (HOccurrence e l (e ': l'), HOccursMany e l') =>
                HList l -> (e,[e])
hOccursMany1 :: HList l -> (e, [e])
hOccursMany1 HList l
l = case Proxy e -> HList l -> HList (e : l')
forall e1 (l :: [*]) (l' :: [*]).
HOccurrence e1 l l' =>
Proxy e1 -> HList l -> HList l'
hOccurrence (Proxy e
forall k (t :: k). Proxy t
Proxy :: Proxy e) HList l
l of
                   (HCons e l') -> (e
e,HList l' -> [e]
forall e (l :: [*]). HOccursMany e l => HList l -> [e]
hOccursMany (HList l'
l'::HList l'))

-- --------------------------------------------------------------------------
-- The first occurrence

hOccursFst :: forall e l l'. HOccurrence e l (e ': l') => HList l -> e
hOccursFst :: HList l -> e
hOccursFst HList l
l = case Proxy e -> HList l -> HList (e : l')
forall e1 (l :: [*]) (l' :: [*]).
HOccurrence e1 l l' =>
Proxy e1 -> HList l -> HList l'
hOccurrence (Proxy e
forall k (t :: k). Proxy t
Proxy::Proxy e) HList l
l of HCons e _ -> e
e

-- --------------------------------------------------------------------------
-- One occurrence and nothing is left
-- This constraint is used in many places

data TypeNotFound e

instance (HOccurrence e (x ': y) l', HOccurs' e l' (x ': y))
    => HOccurs e (HList (x ': y)) where
    hOccurs :: HList (x : y) -> e
hOccurs = Proxy (x : y) -> HList l' -> e
forall e (l :: [*]) (l0 :: [*]).
HOccurs' e l l0 =>
Proxy l0 -> HList l -> e
hOccurs' (Proxy (x : y)
forall k (t :: k). Proxy t
Proxy :: Proxy (x ': y)) (HList l' -> e)
-> (HList (x : y) -> HList l') -> HList (x : y) -> e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy e -> HList (x : y) -> HList l'
forall e1 (l :: [*]) (l' :: [*]).
HOccurrence e1 l l' =>
Proxy e1 -> HList l -> HList l'
hOccurrence (Proxy e
forall k (t :: k). Proxy t
Proxy ::Proxy e)

-- | l0 is the original list so that when we reach the end of l
-- without finding an e, we can report an error that gives an
-- idea about what the original list was.
class HOccurs' e l (l0 :: [*]) where
    hOccurs' :: Proxy l0 -> HList l -> e

instance Fail (FieldNotFound e (HList l0)) => HOccurs' e '[] l0 where
    hOccurs' :: Proxy l0 -> HList '[] -> e
hOccurs' = [Char] -> Proxy l0 -> HList '[] -> e
forall a. HasCallStack => [Char] -> a
error [Char]
"HOccurs'' Fail failed"

instance HOccursNot e l => HOccurs' e (e ': l) l0 where
    hOccurs' :: Proxy l0 -> HList (e : l) -> e
hOccurs' Proxy l0
_ (HCons e _) = e
e

-- | lookup a value in the collection (TIP usually) and return the TIP with that
-- element deleted. Used to implement 'tipyTuple'.
hOccursRest :: r v -> (l, r v')
hOccursRest r v
tip = case r v -> l
forall e l. HOccurs e l => l -> e
hOccurs r v
tip of
  l
x -> (l
x, Label l -> r v -> r v'
forall k (r :: [*] -> *) (l :: k) (v :: [*]) (v' :: [*]).
HDeleteAtLabel r l v v' =>
Label l -> r v -> r v'
hDeleteAtLabel (l -> Label l
forall x. x -> Label x
asLabel l
x) r v
tip)
  where asLabel :: x -> Label x
        asLabel :: x -> Label x
asLabel x
_ = Label x
forall k (l :: k). Label l
Label


-- --------------------------------------------------------------------------
-- Zero or at least one occurrence

hOccursOpt :: forall e l l'.
              (HOccurrence e l l', HOccursOpt' e l') => HList l -> Maybe e
hOccursOpt :: HList l -> Maybe e
hOccursOpt = HList l' -> Maybe e
forall e (l :: [*]). HOccursOpt' e l => HList l -> Maybe e
hOccursOpt' (HList l' -> Maybe e)
-> (HList l -> HList l') -> HList l -> Maybe e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy e -> HList l -> HList l'
forall e1 (l :: [*]) (l' :: [*]).
HOccurrence e1 l l' =>
Proxy e1 -> HList l -> HList l'
hOccurrence (Proxy e
forall k (t :: k). Proxy t
Proxy :: Proxy e)

class HOccursOpt' e l where
  hOccursOpt' :: HList l -> Maybe e

instance HOccursOpt' e '[] where
  hOccursOpt' :: HList '[] -> Maybe e
hOccursOpt' HList '[]
_ = Maybe e
forall a. Maybe a
Nothing

instance e ~ e1 => HOccursOpt' e (e1 ': l) where
  hOccursOpt' :: HList (e1 : l) -> Maybe e
hOccursOpt' (HCons e _) = e1 -> Maybe e1
forall a. a -> Maybe a
Just e1
e

-- --------------------------------------------------------------------------
-- Class to test that a type is "free" in a type sequence

instance HOccursNot1 e xs xs => HOccursNot e xs

class HOccursNot1 (e :: k) (xs :: [k]) (xs0 :: [k])

instance HOccursNot1 (e :: k) ('[]::[k]) l0
instance (HEq e e1 b, HOccursNot2 b e l l0) => HOccursNot1 e (e1 ': l) l0
class HOccursNot2 (b :: Bool) e (l :: [k]) (l0 :: [k])
instance Fail (ExcessFieldFound e l0) => HOccursNot2 True e l l0
instance HOccursNot1 e l l0 => HOccursNot2 False e l l0


-- --------------------------------------------------------------------------

instance HProject (HList l) (HList '[]) where
  hProject :: HList l -> HList '[]
hProject HList l
_ = HList '[]
HNil

instance (HOccurs e l, HProject l (HList l'))
      =>   HProject l (HList (e ': l'))
 where
  hProject :: l -> HList (e : l')
hProject l
l = e -> HList l' -> HList (e : l')
forall x (xs :: [*]). x -> HList xs -> HList (x : xs)
HCons (l -> e
forall e l. HOccurs e l => l -> e
hOccurs l
l) (l -> HList l'
forall l l'. HProject l l' => l -> l'
hProject l
l)


-- --------------------------------------------------------------------------

-- * Illustration of typical test scenarios
{- $example

Retrieve the Breed of an animal.

> ghci-or-hugs> hOccurs myAnimal :: Breed
> Cow


Normal hOccurs requires specification of the result type even if the result
type is determined by the fact that we are faced with a singleton list.

> ghci-or-hugs> hOccurs (HCons 1 HNil)
>
> <interactive>:1:
>     No instance for (HOccurs e1 (HCons e HNil))


However, hOccurs can be elaborated as improved as follows:

> ghci-or-hugs> hLookup (HCons 1 HNil)
> 1

-}