SemanticAlp.hs

   1 {-# OPTIONS_GHC -Wno-orphans #-}
   2 -- | Semantics for Alp's Expr
   3 module SemanticAlp where
   4
   5 import Syntax
   6 import qualified Control.Monad.Trans.State.Strict as MT
   7
   8 -- | An untyped expression.
   9 -- This is only to keep Alp's initial algebra for the demo.
  10 -- Would require a GADT to enforce type-preservation.
  11 -- Would require to be replaced by final algebras (like 'Abstractable') to stay extensible,
  12 -- at the cost of pattern-matchability, though it could be recovered
  13 -- by using an existentialized data family indexed by the syntax type-classes.
  14 -- Though there are 'V'ariables, there is no lambda constructor in this 'Expr',
  15 -- but one could be added if wanted, then 'MT.State' could be replaced
  16 -- by 'MT.Reader' to use DeBruijn indices instead of a global counter
  17 -- (not necessarily quicker though).
  18 data Expr v k = K k | V v | Unop Unop (Expr v k) | Binop Binop (Expr v k) (Expr v k)
  19   deriving (Show)
  20 data Unop = Negate | Abs | Signum | FromInteger | Inv
  21   deriving (Show)
  22 data Binop = Add | Mul | Sub | Div | App {- added to support (.@) -}
  23   deriving (Show)
  24
  25 -- * An example of representation : generating an 'Expr'
  26
  27 data E a = E { unE :: MT.State Int (Expr Int Float) }
  28 compile :: E a -> Expr Int Float
  29 compile = (`MT.evalState` 0) . unE
  30 instance Abstractable E where
  31   f .@ x = E $ Binop App <$> unE f <*> unE x
  32   lam f = E $ do
  33     v <- MT.get
  34     MT.put (succ v)
  35     unE (f (E (return (V v))))
  36 instance Num a => Num (E a) where
  37   x + y = E $ Binop Add <$> unE x <*> unE y
  38   x * y = E $ Binop Mul <$> unE x <*> unE y
  39   x - y = E $ Binop Sub <$> unE x <*> unE y
  40   abs x = E $ Unop Abs <$> unE x
  41   signum x = E $ Unop Signum <$> unE x
  42   fromInteger i = E $ return (K (fromInteger i))
  43   negate x = E $ Unop Negate <$> unE x
  44 instance Fractional a => Fractional (E a) where
  45   fromRational r = E $ return (K (fromRational r))
  46   recip x = E $ Unop Inv <$> unE x
  47   x / y = E $ Binop Div <$> unE x <*> unE y