SemanticAlp.hs

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