61 lines
2.9 KiB
Text
61 lines
2.9 KiB
Text
/-
|
||
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
|
||
Released under Apache 2.0 license as described in the file LICENSE.
|
||
Authors: Leonardo de Moura, Sebastian Ullrich
|
||
-/
|
||
prelude
|
||
import init.category.functor
|
||
open function
|
||
universes u v
|
||
|
||
class has_pure (f : Type u → Type v) :=
|
||
(pure : Π {α : Type u}, α → f α)
|
||
|
||
-- make `f` implicit, like in Haskell
|
||
@[reducible, inline] def pure {f : Type u → Type v} [has_pure f] {α : Type u} : α → f α :=
|
||
has_pure.pure f
|
||
|
||
class has_seq (f : Type u → Type v) : Type (max (u+1) v) :=
|
||
(seq : Π {α β : Type u}, f (α → β) → f α → f β)
|
||
|
||
infixl ` <*> `:60 := has_seq.seq
|
||
|
||
class has_seq_left (f : Type u → Type v) : Type (max (u+1) v) :=
|
||
(seq_left : Π {α β : Type u}, f α → f β → f α)
|
||
|
||
infixl ` <* `:60 := has_seq_left.seq_left
|
||
|
||
class has_seq_right (f : Type u → Type v) : Type (max (u+1) v) :=
|
||
(seq_right : Π {α β : Type u}, f α → f β → f β)
|
||
|
||
infixl ` *> `:60 := has_seq_right.seq_right
|
||
|
||
section
|
||
set_option auto_param.check_exists false
|
||
|
||
class applicative (f : Type u → Type v) extends functor f, has_pure f, has_seq f, has_seq_left f, has_seq_right f :=
|
||
(map := λ _ _ x y, pure x <*> y)
|
||
(seq_left := λ α β a b, const β <$> a <*> b)
|
||
(seq_right := λ α β a b, const α id <$> a <*> b)
|
||
(seq_left_eq : ∀ {α β : Type u} (a : f α) (b : f β), a <* b = const β <$> a <*> b . control_laws_tac)
|
||
(seq_right_eq : ∀ {α β : Type u} (a : f α) (b : f β), a *> b = const α id <$> a <*> b . control_laws_tac)
|
||
-- applicative laws
|
||
(pure_seq_eq_map : ∀ {α β : Type u} (g : α → β) (x : f α), pure g <*> x = g <$> x) -- . control_laws_tac)
|
||
(map_pure : ∀ {α β : Type u} (g : α → β) (x : α), g <$> pure x = pure (g x))
|
||
(seq_pure : ∀ {α β : Type u} (g : f (α → β)) (x : α), g <*> pure x = (λ g : α → β, g x) <$> g)
|
||
(seq_assoc : ∀ {α β γ : Type u} (x : f α) (g : f (α → β)) (h : f (β → γ)), h <*> (g <*> x) = (@comp α β γ <$> h) <*> g <*> x)
|
||
-- defaulted functor law
|
||
(map_comp :=
|
||
λ α β γ g h x, calc
|
||
(h ∘ g) <$> x = pure (h ∘ g) <*> x : eq.symm $ pure_seq_eq_map _ _
|
||
... = (comp h <$> pure g) <*> x : eq.rec rfl $ map_pure (comp h) g
|
||
... = pure (@comp α β γ h) <*> pure g <*> x : eq.rec rfl $ eq.symm $ pure_seq_eq_map (comp h) (pure g)
|
||
... = (@comp α β γ <$> pure h) <*> pure g <*> x : eq.rec rfl $ map_pure (@comp α β γ) h
|
||
... = pure h <*> (pure g <*> x) : eq.symm $ seq_assoc _ _ _
|
||
... = h <$> (pure g <*> x) : pure_seq_eq_map _ _
|
||
... = h <$> g <$> x : congr_arg _ $ pure_seq_eq_map _ _)
|
||
end
|
||
|
||
-- applicative "law" derivable from other laws
|
||
theorem applicative.pure_id_seq {α β : Type u} {f : Type u → Type v} [applicative f] (x : f α) : pure id <*> x = x :=
|
||
eq.trans (applicative.pure_seq_eq_map _ _) (functor.id_map _)
|