]> Git — Sourcephile - haskell/symantic-base.git/blob - src/Symantic/Syntaxes/TuplesOfFunctions.hs
iface: add interpreter `LetInserter`
[haskell/symantic-base.git] / src / Symantic / Syntaxes / TuplesOfFunctions.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE ConstraintKinds #-}
3 {-# LANGUAGE DataKinds #-}
4 {-# LANGUAGE UndecidableInstances #-}
5
6 -- | This module enables the use of Tuples-of-Functions
7 -- instead of Eithers-of-Tuples.
8 module Symantic.Syntaxes.TuplesOfFunctions where
9
10 import Data.Bool (Bool (..))
11 import Data.Either (Either (..))
12 import Data.Eq (Eq)
13 import Data.Function (const, id, ($), (.))
14 import Data.Kind (Type)
15 import Data.Ord (Ord)
16 import Text.Show (Show)
17
18 -- * Type family '(-->)'
19
20 -- | Convenient alias for a Tuples of Functions transformation.
21 --
22 -- Example of a covariant semantic producing a 'Text':
23 --
24 -- @
25 -- data Texter a = { unTexter :: forall next. (a --> next) -> next }
26 -- runTexter :: Texter a -> (a --> Text) -> Text
27 -- runTexter = unTexter
28 --
29 -- @
30 --
31 -- Example of a contravariant semantic producing a 'Text':
32 --
33 -- @
34 -- data Texter a = { unTexter :: forall next. (Text -> next) -> a --> next }
35 -- runTexter :: Texter a -> a --> Text
36 -- runTexter sem = unTexter sem id
37 -- @
38 type (-->) a next = ToFIf (IsToF a) a next
39
40 infixr 0 -->
41
42 -- ** Type family 'ToFIf'
43
44 -- | Return Tuples-of-Functions instead of Eithers-of-Tuples
45 --
46 -- Useful to avoid introducing a parameter dedicated for the return value,
47 -- as in https://okmij.org/ftp/typed-formatting/index.html#DSL-FIn
48 --
49 -- Useful to avoid declaring and pattern-matching
50 -- an algebraic datatype of type @(a)@,
51 -- as the corresponding function will be called directly,
52 -- given as arguments the terms that would have been
53 -- pattern-matched from a constructor
54 -- of such algebraic datatype.
55 type family ToFIf (t :: Bool) a next :: Type where
56 -- Curry on '<.>'.
57 ToFIf 'True (a, b) next = a --> b --> next
58 -- Branch on '<+>'.
59 ToFIf 'True (Either a b) next = (a --> next, b --> next)
60 -- Skip '()' as argument.
61 ToFIf 'True () next = next
62 -- Enable a different return value for each function.
63 ToFIf 'True (Endpoint sem a) next = ToFEndpoint sem a next
64 -- Everything else becomes a new argument.
65 ToFIf 'False a next = a -> next
66
67 -- ** Type family 'IsToF'
68
69 -- | When @('IsToF' a ~ 'True')@, iif. the argument is changed by 'ToFIf'.
70 -- This being a closed type family, it enables to avoid defining
71 -- an instance of 'ToFIf' and 'ToFable' for all types.
72 type family IsToF (a :: Type) :: Bool where
73 IsToF (a, b) = 'True
74 IsToF (Either a b) = 'True
75 IsToF () = 'True
76 IsToF (Endpoint end a) = 'True
77 IsToF a = 'False
78
79 -- ** Type 'Endpoint'
80
81 -- | @('Endpoint' sem a)@ enables the function equivalent to a datatype constructor,
82 -- to return a value of type @a@.
83 --
84 -- Useful to enable functions to return different types.
85 newtype Endpoint (sem :: Type -> Type) a = Endpoint {unEndpoint :: a}
86 deriving (Eq, Ord, Show)
87
88 -- ** Type family 'ToFEndpoint'
89 type family ToFEndpoint (sem :: Type -> Type) a next :: Type
90
91 -- * Class 'ToFable'
92 class ToFable a where
93 tofOffun :: (a -> next) -> a --> next
94 funOftof :: (a --> next) -> a -> next
95 default tofOffun :: (a --> next) ~ (a -> next) => (a -> next) -> a --> next
96 default funOftof :: (a --> next) ~ (a -> next) => (a --> next) -> a -> next
97 tofOffun = id
98 funOftof = id
99 instance ToFable () where
100 tofOffun = ($ ())
101 funOftof = const
102 instance (ToFable a, ToFable b) => ToFable (a, b) where
103 tofOffun ab2n = tofOffun (\a -> tofOffun (\b -> ab2n (a, b)))
104 funOftof k (a, b) = funOftof (funOftof k a) b
105 instance (ToFable a, ToFable b) => ToFable (Either a b) where
106 tofOffun e2n = (tofOffun (e2n . Left), tofOffun (e2n . Right))
107 funOftof (ak, bk) = \case
108 Left a -> funOftof ak a
109 Right b -> funOftof bk b
110
111 -- OVERLAPPABLE could be avoided by using 'ToFIf',
112 -- but that would a be a bit more verbose and require more type annotations.
113 instance {-# OVERLAPPABLE #-} IsToF a ~ 'False => ToFable a