src/Symantic/Semantics/Identity.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2
   3 -- | This module provides the 'Identity' and 'IdentityT' semantics
   4 -- which interprets the combinators as a Haskell value.
   5 module Symantic.Semantics.Identity (
   6   Identity (..),
   7   IdentityT (..),
   8 ) where
   9
  10 import Control.Applicative qualified as App
  11 import Control.Monad.Trans.Identity (IdentityT (..))
  12 import Data.Either qualified as Either
  13 import Data.Eq qualified as Eq
  14 import Data.Function qualified as Fun
  15 import Data.Functor.Identity (Identity (..))
  16 import Data.Maybe qualified as Maybe
  17
  18 import Debug.Trace (traceShow)
  19 import Text.Show (Show)
  20
  21 import Symantic.Syntaxes.Classes
  22 import Symantic.Syntaxes.Derive
  23
  24 -- * Type 'IdentityT'
  25
  26 type instance Derived (IdentityT sem) = sem
  27 instance Derivable (IdentityT sem) where
  28   derive = runIdentityT
  29 instance LiftDerived (IdentityT sem) where
  30   liftDerived = IdentityT
  31 instance LiftDerived1 (IdentityT sem) where
  32   liftDerived1 f = IdentityT Fun.. f Fun.. runIdentityT
  33 instance LiftDerived2 (IdentityT sem) where
  34   liftDerived2 f x y = IdentityT (f (runIdentityT x) (runIdentityT y))
  35 instance LiftDerived3 (IdentityT sem) where
  36   liftDerived3 f x y z = IdentityT (f (runIdentityT x) (runIdentityT y) (runIdentityT z))
  37 instance LiftDerived4 (IdentityT sem) where
  38   liftDerived4 f w x y z = IdentityT (f (runIdentityT w) (runIdentityT x) (runIdentityT y) (runIdentityT z))
  39
  40 instance Abstractable sem => Abstractable (IdentityT sem)
  41 instance Abstractable1 sem => Abstractable1 (IdentityT sem)
  42 instance Anythingable sem => Anythingable (IdentityT sem)
  43 instance Constantable c sem => Constantable c (IdentityT sem)
  44 instance Eitherable sem => Eitherable (IdentityT sem)
  45 instance Equalable sem => Equalable (IdentityT sem)
  46 instance IfThenElseable sem => IfThenElseable (IdentityT sem)
  47 instance Instantiable sem => Instantiable (IdentityT sem)
  48 instance LetRecable idx sem => LetRecable idx (IdentityT sem)
  49 instance Listable sem => Listable (IdentityT sem)
  50 instance Maybeable sem => Maybeable (IdentityT sem)
  51 instance Unabstractable sem => Unabstractable (IdentityT sem)
  52 instance Varable sem => Varable (IdentityT sem)
  53
  54 -- * Type 'Identity'
  55 instance Abstractable Identity where
  56   lam f = Identity (runIdentity Fun.. f Fun.. Identity)
  57 instance Abstractable1 Identity where
  58   lam1 f = Identity (runIdentity Fun.. f Fun.. Identity)
  59 instance Anythingable Identity
  60 instance Constantable c Identity where
  61   constant = Identity
  62 instance Eitherable Identity where
  63   either = Identity Either.either
  64   left = Identity Either.Left
  65   right = Identity Either.Right
  66 instance Equalable Identity where
  67   equal = Identity (Eq.==)
  68 instance IfThenElseable Identity where
  69   ifThenElse test ok ko =
  70     Identity
  71       ( if runIdentity test
  72           then runIdentity ok
  73           else runIdentity ko
  74       )
  75 instance Instantiable Identity where
  76   Identity f .@ Identity x = Identity (f x)
  77 instance Listable Identity where
  78   cons = Identity (:)
  79   nil = Identity []
  80 instance Maybeable Identity where
  81   nothing = Identity Maybe.Nothing
  82   just = Identity Maybe.Just
  83 instance Unabstractable Identity where
  84   ap = Identity (App.<*>)
  85   const = Identity Fun.const
  86   id = Identity Fun.id
  87   (.) = Identity (Fun..)
  88   flip = Identity Fun.flip
  89   ($) = Identity (Fun.$)
  90 instance Varable Identity where
  91   var = Fun.id
  92 instance Letable Identity where
  93   let_ e body = body e
  94 instance Show idx => LetRecable idx Identity where
  95   letRec _idx f body =
  96     Identity Fun.$
  97       -- traceShow ["Identity", "letRec"] Fun.$
  98       let self idx =
  99             -- traceShow (["Identity", "letRec", "self"], ("idx", idx)) Fun.$
 100             runIdentity (f (Identity Fun.. self) idx)
 101       in runIdentity (body (Identity Fun.. self))