src/Symantic/Semantics/ToFer.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE ConstraintKinds #-}
   3 {-# LANGUAGE DataKinds #-}
   4 {-# LANGUAGE InstanceSigs #-}
   5 {-# LANGUAGE RankNTypes #-}
   6 {-# LANGUAGE UndecidableInstances #-}
   7
   8 module Symantic.Semantics.ToFer where
   9
  10 import Control.Monad (Monad, (>=>))
  11 import Data.Function qualified as Fun
  12 import Data.Functor (Functor, (<$>))
  13 import GHC.Generics (Generic)
  14
  15 import Symantic.Syntaxes.ADT
  16 import Symantic.Syntaxes.Classes
  17 import Symantic.Syntaxes.TuplesOfFunctions
  18
  19 -- * Type 'TuplesOfFunctions'
  20
  21 -- | The 'ToFer' intermediate interpreter
  22 -- return Tuples-of-Functions instead of Eithers-of-Tuples.
  23 --
  24 -- In other words, if transforms 'SumFunctor' into functions returning @(sem next)@
  25 -- and 'ProductFunctor' into arguments of those functions.
  26 --
  27 -- This is like using an extension parameter introduced in
  28 -- https://okmij.org/ftp/typed-formatting/index.html#DSL-FIn
  29 -- but here only a single type parameter @(a)@ is exposed
  30 -- instead of two.
  31 --
  32 -- Useful to avoid declaring and pattern-matching
  33 -- an algebraic datatype of type @(a)@,
  34 -- as the corresponding function will be called directly,
  35 -- given as arguments the terms that would have been
  36 -- pattern-matched from a constructor
  37 -- of such algebraic datatype.
  38 data ToFer sem a = ToFer
  39   { tuplesOfFunctions :: forall next. ToF a next -> sem next
  40   , eithersOfTuples :: sem a
  41   }
  42
  43 instance (ProductFunctor sem, Monad sem) => ProductFunctor (ToFer sem) where
  44   a <.> b =
  45     ToFer
  46       { tuplesOfFunctions = tuplesOfFunctions a >=> tuplesOfFunctions b
  47       , eithersOfTuples = eithersOfTuples a <.> eithersOfTuples b
  48       }
  49   a .> b =
  50     ToFer
  51       { tuplesOfFunctions = tuplesOfFunctions a >=> tuplesOfFunctions b
  52       , eithersOfTuples = eithersOfTuples a .> eithersOfTuples b
  53       }
  54   a <. b =
  55     ToFer
  56       { tuplesOfFunctions = tuplesOfFunctions a >=> tuplesOfFunctions b
  57       , eithersOfTuples = eithersOfTuples a <. eithersOfTuples b
  58       }
  59 instance (SumFunctor sem, AlternativeFunctor sem) => SumFunctor (ToFer sem) where
  60   a <+> b =
  61     ToFer
  62       { tuplesOfFunctions = \(l, r) -> tuplesOfFunctions a l <|> tuplesOfFunctions b r
  63       , eithersOfTuples = eithersOfTuples a <+> eithersOfTuples b
  64       }
  65 instance (Optionable sem, Functor sem) => Optionable (ToFer sem) where
  66   optional ma = ToFer{tuplesOfFunctions = (<$> sem), eithersOfTuples = sem}
  67     where
  68       sem = optional (eithersOfTuples ma)
  69 instance Functor sem => Dataable (ToFer sem) where
  70   data_ ::
  71     forall a.
  72     Generic a =>
  73     RepOfEoT a =>
  74     UnToF a =>
  75     ToFer sem (EoT (ADT a)) ->
  76     ToFer sem a
  77   data_ a =
  78     ToFer
  79       { tuplesOfFunctions = \f -> unToF @(IsToF a) @a f Fun.. adtOfeot <$> eithersOfTuples a
  80       , eithersOfTuples = adtOfeot <$> eithersOfTuples a
  81       }