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