{-# OPTIONS_GHC -Wno-orphans #-}
-- | Semantics for Alp's Expr
module SemanticAlp where

import Syntax
import qualified Control.Monad.Trans.State.Strict as MT

-- | An untyped expression.
-- This is only to keep Alp's initial algebra for the demo.
-- Would require a GADT to enforce type-preservation.
-- Would require to be replaced by final algebras (like 'Abstractable') to stay extensible,
-- at the cost of pattern-matchability, though it could be recovered
-- by using an existentialized data family indexed by the syntax type-classes.
-- Though there are 'V'ariables, there is no lambda constructor in this 'Expr',
-- but one could be added if wanted, then 'MT.State' could be replaced
-- by 'MT.Reader' to use DeBruijn indices instead of a global counter
-- (not necessarily quicker though).
data Expr v k = K k | V v | Unop Unop (Expr v k) | Binop Binop (Expr v k) (Expr v k)
  deriving (Show)
data Unop = Negate | Abs | Signum | FromInteger | Inv
  deriving (Show)
data Binop = Add | Mul | Sub | Div | App {- added to support (.@) -}
  deriving (Show)

-- * An example of representation : generating an 'Expr'

data E a = E { unE :: MT.State Int (Expr Int Float) }
compile :: E a -> Expr Int Float
compile = (`MT.evalState` 0) . unE
instance Abstractable E where
  f .@ x = E $ Binop App <$> unE f <*> unE x
  lam f = E $ do
    v <- MT.get
    MT.put (succ v)
    unE (f (E (return (V v))))
instance Num a => Num (E a) where
  x + y = E $ Binop Add <$> unE x <*> unE y
  x * y = E $ Binop Mul <$> unE x <*> unE y
  x - y = E $ Binop Sub <$> unE x <*> unE y
  abs x = E $ Unop Abs <$> unE x
  signum x = E $ Unop Signum <$> unE x
  fromInteger i = E $ return (K (fromInteger i))
  negate x = E $ Unop Negate <$> unE x
instance Fractional a => Fractional (E a) where
  fromRational r = E $ return (K (fromRational r))
  recip x = E $ Unop Inv <$> unE x
  x / y = E $ Binop Div <$> unE x <*> unE y